Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/addfi.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/addfi.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/addfi.F90	(revision 5105)
@@ -178,4 +178,4 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE addfi
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/advect.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/advect.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/advect.F90	(revision 5105)
@@ -162,4 +162,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE advect
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/bilan_dyn.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/bilan_dyn.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/bilan_dyn.F90	(revision 5105)
@@ -578,4 +578,4 @@
   !=====================================================================
 
-  return
+
 END SUBROUTINE  bilan_dyn
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/covnat.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/covnat.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/covnat.F90	(revision 5105)
@@ -44,4 +44,4 @@
 
   ENDDO
-  RETURN
+
 END SUBROUTINE covnat
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/dissip.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/dissip.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/dissip.F90	(revision 5105)
@@ -142,4 +142,4 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE dissip
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/dteta1.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/dteta1.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/dteta1.F90	(revision 5105)
@@ -60,4 +60,4 @@
 
   !
-  RETURN
+
 END SUBROUTINE dteta1
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv1.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv1.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv1.F90	(revision 5105)
@@ -49,4 +49,4 @@
     !
   END DO
-  RETURN
+
 END SUBROUTINE dudv1
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv2.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv2.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv2.F90	(revision 5105)
@@ -58,4 +58,4 @@
   END DO
   !
-  RETURN
+
 END SUBROUTINE dudv2
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F90	(revision 5105)
@@ -158,4 +158,4 @@
   ENDIF ! if iadvtr.EQ.istdyn
 
-  RETURN
+
 END SUBROUTINE fluxstokenc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/friction.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/friction.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/friction.F90	(revision 5105)
@@ -125,5 +125,5 @@
   endif
 
-  RETURN
+
 END SUBROUTINE friction
 
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/groupe.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/groupe.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/groupe.F90	(revision 5105)
@@ -104,5 +104,5 @@
   CALL vitvert(zconvmm, wm)
 
-  return
+
 END SUBROUTINE  groupe
 
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/groupeun.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/groupeun.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/groupeun.F90	(revision 5105)
@@ -127,5 +127,5 @@
   !$OMP END DO NOWAIT
 
-  RETURN
+
 END SUBROUTINE groupeun
 
@@ -196,4 +196,4 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE INIT_GROUPEUN
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/guide_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/guide_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/guide_mod.F90	(revision 5105)
@@ -425,5 +425,5 @@
                 CALL massdair(p,masse)
             ENDIF
-            RETURN
+
         ENDIF
 ! Verification structure guidage
@@ -1811,5 +1811,5 @@
          enddo
      enddo
-     return
+
   END SUBROUTINE  correctbid
 
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/iniinterp_horiz.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/iniinterp_horiz.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/iniinterp_horiz.F90	(revision 5105)
@@ -176,4 +176,4 @@
   ! END DO
 
-  return
+
 END SUBROUTINE  iniinterp_horiz
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/integrd.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/integrd.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/integrd.F90	(revision 5105)
@@ -250,4 +250,4 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE integrd
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/interp_horiz.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/interp_horiz.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/interp_horiz.F90	(revision 5105)
@@ -143,4 +143,4 @@
   !---------------------------------------------------------------
 
-  return
+
 END SUBROUTINE  interp_horiz
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/leapfrog.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/leapfrog.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/leapfrog.F90	(revision 5105)
@@ -227,7 +227,7 @@
   !   -----
 
-  jD_cur = jD_ref + day_ini - day_ref +                             & &
+  jD_cur = jD_ref + day_ini - day_ref +                             &
   (itau+1)/day_step
-  jH_cur = jH_ref + start_time +                                    & &
+  jH_cur = jH_ref + start_time +                                    &
           mod(itau+1, day_step)/float(day_step)
   jD_cur = jD_cur + int(jH_cur)
@@ -405,5 +405,5 @@
     !       jH_cur = jH_ref +                                            &
     ! &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
-    jD_cur = jD_ref + day_ini - day_ref +                        & &
+    jD_cur = jD_ref + day_ini - day_ref +                        &
     (itau+1)/day_step
 
@@ -413,5 +413,5 @@
     ENDIF
 
-    jH_cur = jH_ref + start_time +                               & &
+    jH_cur = jH_ref + start_time +                               &
             mod(itau+1, day_step)/float(day_step)
     jD_cur = jD_cur + int(jH_cur)
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/qminimum.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/qminimum.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/qminimum.F90	(revision 5105)
@@ -190,4 +190,4 @@
 
   !
-  RETURN
+
 END SUBROUTINE qminimum
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j.F90	(revision 5105)
@@ -133,4 +133,4 @@
 
   !
-  RETURN
+
 END SUBROUTINE tetaleveli1j
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j1.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j1.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j1.F90	(revision 5105)
@@ -133,4 +133,4 @@
 
   !
-  RETURN
+
 END SUBROUTINE tetaleveli1j1
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/vlsplt.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/vlsplt.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/vlsplt.F90	(revision 5105)
@@ -102,5 +102,5 @@
   enddo
 
-  RETURN
+
 END SUBROUTINE vlsplt
 RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
@@ -419,5 +419,5 @@
   enddo
 
-  RETURN
+
 END SUBROUTINE vlx
 RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
@@ -746,5 +746,5 @@
   ! !write(*,*) 'vly 853: sortie'
 
-  RETURN
+
 END SUBROUTINE vly
 RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
@@ -889,5 +889,5 @@
   enddo
 
-  RETURN
+
 END SUBROUTINE vlz
 
@@ -901,5 +901,5 @@
   real :: zq(ip1jmp1,llm)
   real :: zzq(iip1,jjp1,llm)
-  return
+
 END SUBROUTINE  minmaxq
 
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/vlspltqs.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/vlspltqs.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/vlspltqs.F90	(revision 5105)
@@ -173,5 +173,5 @@
   ! !write(*,*) 'vlspltqs 183: fin de la routine'
 
-  RETURN
+
 END SUBROUTINE vlspltqs
 SUBROUTINE vlxqs(q, pente_max, masse, u_m, qsat, iq)
@@ -506,5 +506,5 @@
   ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
 
-  RETURN
+
 END SUBROUTINE vlxqs
 SUBROUTINE vlyqs(q, pente_max, masse, masse_adv_v, qsat, iq)
@@ -840,4 +840,4 @@
   ! !write(*,*) 'vly 879'
 
-  RETURN
+
 END SUBROUTINE vlyqs
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d/wrgrads.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d/wrgrads.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d/wrgrads.f90	(revision 5105)
@@ -125,5 +125,5 @@
   endif ! writectl
 
-  return
+
 
 END SUBROUTINE wrgrads
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.F	(revision 5104)
+++ 	(revision )
@@ -1,53 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE adaptdt(nadv,dtbon,n,pbaru,
-     c                   masse)
-
-      USE comconst_mod, ONLY: dtvr
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comdissip.h"
-      include "comgeom2.h"
-      include "description.h"
-
-c----------------------------------------------------------
-c     Arguments
-c----------------------------------------------------------
-      INTEGER n,nadv
-      REAL dtbon 
-      REAL pbaru(iip1,jjp1,llm)
-      REAL masse(iip1,jjp1,llm)
-c----------------------------------------------------------    
-c     Local
-c----------------------------------------------------------
-      INTEGER i,j,l
-      REAL CFLmax,aaa,bbb
-      
-        CFLmax=0.
-        do l=1,llm
-         do j=2,jjm
-          do i=1,iim
-             aaa=pbaru(i,j,l)*dtvr/masse(i,j,l)
-             CFLmax=max(CFLmax,aaa)
-             bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l)
-             CFLmax=max(CFLmax,bbb)
-          enddo
-         enddo
-        enddo              
-        n=int(CFLmax)+1
-c pour reproduire cas VL du code qui appele x,y,z,y,x
-c        if (nadv.eq.30) n=n/2   ! Pour Prather
-        dtbon=dtvr/n
-        
-       return
-       end
-
-
-
-
-
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.f90	(revision 5105)
@@ -0,0 +1,53 @@
+
+! $Id$
+
+SUBROUTINE adaptdt(nadv,dtbon,n,pbaru, &
+        masse)
+
+  USE comconst_mod, ONLY: dtvr
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissip.h"
+  include "comgeom2.h"
+  include "description.h"
+
+  !----------------------------------------------------------
+  ! Arguments
+  !----------------------------------------------------------
+  INTEGER :: n,nadv
+  REAL :: dtbon
+  REAL :: pbaru(iip1,jjp1,llm)
+  REAL :: masse(iip1,jjp1,llm)
+  !----------------------------------------------------------
+  ! Local
+  !----------------------------------------------------------
+  INTEGER :: i,j,l
+  REAL :: CFLmax,aaa,bbb
+
+    CFLmax=0.
+    do l=1,llm
+     do j=2,jjm
+      do i=1,iim
+         aaa=pbaru(i,j,l)*dtvr/masse(i,j,l)
+         CFLmax=max(CFLmax,aaa)
+         bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l)
+         CFLmax=max(CFLmax,bbb)
+      enddo
+     enddo
+    enddo
+    n=int(CFLmax)+1
+  ! pour reproduire cas VL du code qui appele x,y,z,y,x
+     ! if (nadv.eq.30) n=n/2   ! Pour Prather
+    dtbon=dtvr/n
+
+   return
+end subroutine adaptdt
+
+
+
+
+
+
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advn.F	(revision 5104)
+++ 	(revision )
@@ -1,951 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode)
-c
-c     Auteur : F. Hourdin
-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   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 "comgeom.h"
-      include "iniprint.h"
-
-c
-c   Arguments:
-c   ----------
-      integer mode
-      real masse(ip1jmp1,llm)
-      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 zm(ip1jmp1,llm),newmasse
-      real mu(ip1jmp1,llm)
-      real mv(ip1jm,llm)
-      real mw(ip1jmp1,llm+1)
-      real zq(ip1jmp1,llm),zz,qpn,qps
-      real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm)
-      real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm)
-      real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm)
-      real temps0,temps1,temps2,temps3
-      real ztemps1,ztemps2,ssum
-      save temps1,temps2,temps3
-      real zzpbar,zzw
-
-      real qmin,qmax
-      data qmin,qmax/0.,1./
-      data temps1,temps2,temps3/0.,0.,0./
-
-      zzpbar = 0.5 * pdt
-      zzw    = pdt
-
-      DO l=1,llm
-        DO ij = iip2,ip1jm
-            mu(ij,l)=pbaru(ij,l) * zzpbar
-         ENDDO
-         DO ij=1,ip1jm
-            mv(ij,l)=pbarv(ij,l) * zzpbar
-         ENDDO
-         DO ij=1,ip1jmp1
-            mw(ij,l)=w(ij,l) * zzw
-         ENDDO
-      ENDDO
-
-      DO ij=1,ip1jmp1
-         mw(ij,llm+1)=0.
-      ENDDO
-
-      do l=1,llm
-         qpn=0.
-         qps=0.
-         do ij=1,iim
-            qpn=qpn+q(ij,l)*masse(ij,l)
-            qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l)
-         enddo
-         qpn=qpn/ssum(iim,masse(1,l),1)
-         qps=qps/ssum(iim,masse(ip1jm+1,l),1)
-         do ij=1,iip1
-            q(ij,l)=qpn
-            q(ip1jm+ij,l)=qps
-         enddo
-      enddo
-
-      do ij=1,ip1jmp1
-         mw(ij,llm+1)=0.
-      enddo
-      do l=1,llm
-         do ij=1,ip1jmp1
-            zq(ij,l)=q(ij,l)
-            zm(ij,l)=masse(ij,l)
-         enddo
-      enddo
-
-c     CALL minmaxq(zq,qmin,qmax,'avant vlx     ')
-      CALL advnqx(zq,zqg,zqd)
-      CALL advnx(zq,zqg,zqd,zm,mu,mode)
-      CALL advnqy(zq,zqs,zqn)
-      CALL advny(zq,zqs,zqn,zm,mv)
-      CALL advnqz(zq,zqh,zqb)
-      CALL advnz(zq,zqh,zqb,zm,mw)
-c     CALL vlz(zq,0.,zm,mw)
-      CALL advnqy(zq,zqs,zqn)
-      CALL advny(zq,zqs,zqn,zm,mv)
-      CALL advnqx(zq,zqg,zqd)
-      CALL advnx(zq,zqg,zqd,zm,mu,mode)
-c     CALL minmaxq(zq,qmin,qmax,'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
-
-      SUBROUTINE advnqx(q,qg,qd)
-c
-c     Auteurs:   Calcul des valeurs de q aux point u.
-c
-c   --------------------------------------------------------------------
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm)
-c
-c      Local
-c   ---------
-c
-      INTEGER ij,l
-c
-      real dxqu(ip1jmp1),zqu(ip1jmp1)
-      real zqmax(ip1jmp1),zqmin(ip1jmp1)
-      logical extremum(ip1jmp1)
-
-      integer mode
-      save mode
-      data mode/1/
-
-c   calcul des pentes en u:
-c   -----------------------
-      if (mode==0) then
-         do l=1,llm
-            do ij=1,ip1jm
-               qd(ij,l)=q(ij,l)
-               qg(ij,l)=q(ij,l)
-            enddo
-         enddo
-      else
-      do l = 1, llm
-         do ij=iip2,ip1jm-1
-            dxqu(ij)=q(ij+1,l)-q(ij,l)
-            zqu(ij)=0.5*(q(ij+1,l)+q(ij,l))
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            dxqu(ij)=dxqu(ij-iim)
-            zqu(ij)=zqu(ij-iim)
-         enddo
-         do ij=iip2,ip1jm-1
-            zqu(ij)=zqu(ij)-dxqu(ij+1)/12.
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            zqu(ij)=zqu(ij-iim)
-         enddo
-         do ij=iip2+1,ip1jm
-            zqu(ij)=zqu(ij)+dxqu(ij-1)/12.
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            zqu(ij-iim)=zqu(ij)
-         enddo
-
-c   calcul des valeurs max et min acceptees aux interfaces
-
-         do ij=iip2,ip1jm-1
-            zqmax(ij)=max(q(ij+1,l),q(ij,l))
-            zqmin(ij)=min(q(ij+1,l),q(ij,l))
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            zqmax(ij)=zqmax(ij-iim)
-            zqmin(ij)=zqmin(ij-iim)
-         enddo
-         do ij=iip2+1,ip1jm
-            extremum(ij)=dxqu(ij)*dxqu(ij-1)<=0.
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            extremum(ij-iim)=extremum(ij)
-         enddo
-         do ij=iip2,ip1jm
-            zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij))
-         enddo
-         do ij=iip2+1,ip1jm
-            if(extremum(ij)) then
-               qg(ij,l)=q(ij,l)
-               qd(ij,l)=q(ij,l)
-            else
-               qd(ij,l)=zqu(ij)
-               qg(ij,l)=zqu(ij-1)
-            endif
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            qd(ij-iim,l)=qd(ij,l)
-            qg(ij-iim,l)=qg(ij,l)
-         enddo
-
-         goto 8888
-
-         do ij=iip2+1,ip1jm
-            if(extremum(ij).and..not.extremum(ij-1))
-     s         qd(ij-1,l)=q(ij,l)
-         enddo
-
-         do ij=iip1+iip1,ip1jm,iip1
-            qd(ij-iim,l)=qd(ij,l)
-         enddo
-         do ij=iip2,ip1jm-1
-            if (extremum(ij).and..not.extremum(ij+1))
-     s         qg(ij+1,l)=q(ij,l)
-         enddo
-
-         do ij=iip1+iip1,ip1jm,iip1
-            qg(ij,l)=qg(ij-iim,l)
-         enddo
-8888     continue
-      enddo
-      endif
-      RETURN
-      END
-      SUBROUTINE advnqy(q,qs,qn)
-c
-c     Auteurs:   Calcul des valeurs de q aux point v.
-c
-c   --------------------------------------------------------------------
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm)
-c
-c      Local
-c   ---------
-c
-      INTEGER ij,l
-c
-      real dyqv(ip1jm),zqv(ip1jm,llm)
-      real zqmax(ip1jm),zqmin(ip1jm)
-      logical extremum(ip1jmp1)
-
-      integer mode
-      save mode
-      data mode/1/
-
-      if (mode==0) then
-         do l=1,llm
-            do ij=1,ip1jmp1
-               qn(ij,l)=q(ij,l)
-               qs(ij,l)=q(ij,l)
-            enddo
-         enddo
-      else
-
-c   calcul des pentes en u:
-c   -----------------------
-      do l = 1, llm
-         do ij=1,ip1jm
-            dyqv(ij)=q(ij,l)-q(ij+iip1,l)
-         enddo
-
-         do ij=iip2,ip1jm-iip1
-            zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l))
-            zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12.
-         enddo
-
-         do ij=iip2,ip1jm
-            extremum(ij)=dyqv(ij)*dyqv(ij-iip1)<=0.
-         enddo
-
-c Pas de pentes aux poles
-         do ij=1,iip1
-            zqv(ij,l)=q(ij,l)
-            zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l)
-            extremum(ij)=.TRUE.
-            extremum(ip1jmp1-iip1+ij)=.TRUE.
-         enddo
-
-c   calcul des valeurs max et min acceptees aux interfaces
-         do ij=1,ip1jm
-            zqmax(ij)=max(q(ij+iip1,l),q(ij,l))
-            zqmin(ij)=min(q(ij+iip1,l),q(ij,l))
-         enddo
-
-         do ij=1,ip1jm
-            zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij))
-         enddo
-
-         do ij=iip2,ip1jm
-            if(extremum(ij)) then
-               qs(ij,l)=q(ij,l)
-               qn(ij,l)=q(ij,l)
-c              if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l)
-c              if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l)
-            else
-               qs(ij,l)=zqv(ij,l)
-               qn(ij,l)=zqv(ij-iip1,l)
-            endif
-         enddo
-
-         do ij=1,iip1
-            qs(ij,l)=q(ij,l)
-            qn(ij,l)=q(ij,l)
-            qs(ip1jm+ij,l)=q(ip1jm+ij,l)
-            qn(ip1jm+ij,l)=q(ip1jm+ij,l)
-         enddo
-
-      enddo
-      endif
-      RETURN
-      END
-
-      SUBROUTINE advnqz(q,qh,qb)
-c
-c     Auteurs:   Calcul des valeurs de q aux point v.
-c
-c   --------------------------------------------------------------------
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm)
-c
-c      Local
-c   ---------
-c
-      INTEGER ij,l
-c
-      real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1)
-      real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm)
-      logical extremum(ip1jmp1,llm)
-
-      integer mode
-      save mode
-
-      data mode/1/
-
-c   calcul des pentes en u:
-c   -----------------------
-
-      if (mode==0) then
-         do l=1,llm
-            do ij=1,ip1jmp1
-               qb(ij,l)=q(ij,l)
-               qh(ij,l)=q(ij,l)
-            enddo
-         enddo
-      else
-      do l = 2, llm
-         do ij=1,ip1jmp1
-            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
-            zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l))
-         enddo
-      enddo
-      do ij=1,ip1jmp1
-         dzqw(ij,1)=0.
-         dzqw(ij,llm+1)=0.
-      enddo
-      do l=2,llm
-         do ij=1,ip1jmp1
-            zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12.
-         enddo
-      enddo
-      do l=2,llm-1
-         do ij=1,ip1jmp1
-            extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1)<=0.
-         enddo
-      enddo
-
-c Pas de pentes en bas et en haut
-         do ij=1,ip1jmp1
-            zqw(ij,2)=q(ij,1)
-            zqw(ij,llm)=q(ij,llm)
-            extremum(ij,1)=.TRUE.
-            extremum(ij,llm)=.TRUE.
-         enddo
-
-c   calcul des valeurs max et min acceptees aux interfaces
-      do l=2,llm
-         do ij=1,ip1jmp1
-            zqmax(ij,l)=max(q(ij,l-1),q(ij,l))
-            zqmin(ij,l)=min(q(ij,l-1),q(ij,l))
-         enddo
-      enddo
-
-      do l=2,llm
-         do ij=1,ip1jmp1
-            zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l))
-         enddo
-      enddo
-
-      do l=2,llm-1
-         do ij=1,ip1jmp1
-            if(extremum(ij,l)) then
-               qh(ij,l)=q(ij,l)
-               qb(ij,l)=q(ij,l)
-            else
-               qh(ij,l)=zqw(ij,l+1)
-               qb(ij,l)=zqw(ij,l)
-            endif
-         enddo
-      enddo
-c     do l=2,llm-1
-c        do ij=1,ip1jmp1
-c           if(extremum(ij,l)) then
-c              if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l)
-c              if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l)
-c           endif
-c        enddo
-c     enddo
-
-      do ij=1,ip1jmp1
-         qb(ij,1)=q(ij,1)
-         qh(ij,1)=q(ij,1)
-         qb(ij,llm)=q(ij,llm)
-         qh(ij,llm)=q(ij,llm)
-      enddo
-
-      endif
-
-      RETURN
-      END
-
-      SUBROUTINE advnx(q,qg,qd,masse,u_m,mode)
-c
-c     Auteur : F. Hourdin
-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 "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      integer mode
-      real masse(ip1jmp1,llm)
-      real u_m( ip1jmp1,llm )
-      real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm)
-c
-c      Local
-c   ---------
-c
-      INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq
-      integer n0,nl(llm)
-c
-      real new_m,zu_m,zdq,zz
-      real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig
-      real u_mq(ip1jmp1,llm)
-
-      real zm,zq,zsigm,zsigp,zqm,zqp,zu
-
-      logical ladvplus(ip1jmp1,llm)
-
-      real prec
-      save prec
-
-      data prec/1.e-15/
-
-      do l=1,llm
-            do ij=iip2,ip1jm
-               zdq=qd(ij,l)-qg(ij,l)
-c              if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then
-c                 PRINT*,'probleme au point ij=',ij,'  l=',l
-c                 PRINT*,qd(ij,l),q(ij,l),qg(ij,l)
-c                 qd(ij,l)=q(ij,l)
-c                 qg(ij,l)=q(ij,l)
-c              endif
-               if(abs(zdq)>prec) then
-                  zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq
-                  zsigg(ij,l)=1.-zsigd(ij,l)
-c                 if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and.
-c    s               zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then
-c                    PRINT*,'probleme au point ij=',ij,'  l=',l
-c                    PRINT*,'sigg=',zsigg(ij,l),'  sigd=',zsigd(ij,l)
-c                    PRINT*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq
-c                    stop
-c                 endif
-               else
-                  zsigd(ij,l)=0.5
-                  zsigg(ij,l)=0.5
-                  qd(ij,l)=q(ij,l)
-                  qg(ij,l)=q(ij,l)
-               endif
-            enddo
-       enddo
-
-c   calcul de la pente maximum dans la maille en valeur absolue
-
-       do l=1,llm
-       do ij=iip2,ip1jm-1
-          if (u_m(ij,l)>=0.) then
-             zsigp=zsigd(ij,l)
-             zsigm=zsigg(ij,l)
-             zqp=qd(ij,l)
-             zqm=qg(ij,l)
-             zm=masse(ij,l)
-             zq=q(ij,l)
-          else
-             zsigm=zsigd(ij+1,l)
-             zsigp=zsigg(ij+1,l)
-             zqm=qd(ij+1,l)
-             zqp=qg(ij+1,l)
-             zm=masse(ij+1,l)
-             zq=q(ij+1,l)
-          endif
-          zu=abs(u_m(ij,l))
-          ladvplus(ij,l)=zu>zm
-          zsig=zu/zm
-          if(zsig==0.) zsigp=0.1
-          if (mode==1) then
-             if (zsig<=zsigp) then
-                 u_mq(ij,l)=u_m(ij,l)*zqp
-             else if (mode==1) then
-                 u_mq(ij,l)=
-     s           sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm)
-             endif
-          else
-             if (zsig<=zsigp) then
-                 u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
-             else
-                zz=0.5*(zsig-zsigp)/zsigm
-                u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp
-     s          +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
-             endif
-          endif
-c         if(zsig.lt.0.) then
-c            PRINT*,'au point ij=',ij,'  l=',l,'  sig=',zsig
-c            stop
-c         endif
-      enddo
-      enddo
-
-      do l=1,llm
-       do ij=iip1+iip1,ip1jm,iip1
-          u_mq(ij,l)=u_mq(ij-iim,l)
-          ladvplus(ij,l)=ladvplus(ij-iim,l)
-       enddo
-      enddo
-
-c=================================================================
-C   SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES
-c=================================================================
-c   tris des regions a traiter
-      n0=0
-      do l=1,llm
-         nl(l)=0
-         do ij=iip2,ip1jm
-            if(ladvplus(ij,l)) then
-               nl(l)=nl(l)+1
-               u_mq(ij,l)=0.
-            endif
-         enddo
-         n0=n0+nl(l)
-      enddo
-
-      if(n0>1) then
-      IF (prt_level > 9) WRITE(lunout,*)
-     & 'Nombre de points pour lesquels on advect plus que le'
-     &       ,'contenu de la maille : ',n0
-
-         do l=1,llm
-            if(nl(l)>0) then
-               iju=0
-c   indicage des mailles concernees par le traitement special
-               do ij=iip2,ip1jm
-                  if(ladvplus(ij,l).and.mod(ij,iip1)/=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>0.) then
-                     ijq=ij
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(zu_m>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   MODIFS SPECIFIQUES DU SCHEMA
-c   ajout de la maille non completement advectee
-             zsig=zu_m/masse(ijq,l)
-             if(zsig<=zsigd(ijq,l)) then
-                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l)
-     s          -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l)))
-             else
-c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
-c         goto 8888
-                zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l)
-                if(.not.(zz>0..and.zz<=0.5)) then
-                     WRITE(lunout,*)'probleme2 au point ij=',ij,
-     s               '  l=',l
-                     WRITE(lunout,*)'zz=',zz
-                     stop
-                endif
-                u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*(
-     s          0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l)
-     s        +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) )
-             endif
-                  else
-                     ijq=ij+1
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(-zu_m>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
-c 2eme MODIF SPECIFIQUE
-             zsig=-zu_m/masse(ij+1,l)
-             if(zsig<=zsigg(ijq,l)) then
-                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l)
-     s          -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l)))
-             else
-c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
-c           goto 9999
-                zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l)
-                if(.not.(zz>0..and.zz<=0.5)) then
-                     WRITE(lunout,*)'probleme22 au point ij=',ij
-     s               ,'  l=',l
-                     WRITE(lunout,*)'zz=',zz
-                     stop
-                endif
-                u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*(
-     s          0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l)
-     s          +(zsig-zsigg(ijq,l))*
-     s           (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) )
-             endif
-c   fin de la modif
-                  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=================================================================
-c   CALCUL DE LA CONVERGENCE DES FLUX
-c=================================================================
-
-      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
-
-      RETURN
-      END
-      SUBROUTINE advny(q,qs,qn,masse,v_m)
-c
-c     Auteur : F. Hourdin
-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 "comgeom.h"
-      INCLUDE "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      real masse(ip1jmp1,llm)
-      real v_m( ip1jm,llm )
-      real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm)
-c
-c      Local
-c   ---------
-c
-      INTEGER ij,l
-c
-      real new_m,zdq,zz
-      real zsigs(ip1jmp1),zsign(ip1jmp1),zsig
-      real v_mq(ip1jm,llm)
-      real convpn,convps,convmpn,convmps,massen,masses
-      real zm,zq,zsigm,zsigp,zqm,zqp
-      real ssum
-      real prec
-      save prec
-
-      data prec/1.e-15/
-      do l=1,llm
-            do ij=1,ip1jmp1
-               zdq=qn(ij,l)-qs(ij,l)
-c              if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then
-c                 PRINT*,'probleme au point ij=',ij,'  l=',l,'  advnqx'
-c                 PRINT*,qn(ij,l),q(ij,l),qs(ij,l)
-c                 qn(ij,l)=q(ij,l)
-c                 qs(ij,l)=q(ij,l)
-c              endif
-               if(abs(zdq)>prec) then
-                  zsign(ij)=(q(ij,l)-qs(ij,l))/zdq
-                  zsigs(ij)=1.-zsign(ij)
-c                 if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and.
-c    s               zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then
-c                    PRINT*,'probleme au point ij=',ij,'  l=',l
-c                    PRINT*,'sigs=',zsigs(ij),'  sign=',zsign(ij)
-c                    stop
-c                 endif
-               else
-                  zsign(ij)=0.5
-                  zsigs(ij)=0.5
-               endif
-            enddo
-
-c   calcul de la pente maximum dans la maille en valeur absolue
-
-       do ij=1,ip1jm
-          if (v_m(ij,l)>=0.) then
-             zsigp=zsign(ij+iip1)
-             zsigm=zsigs(ij+iip1)
-             zqp=qn(ij+iip1,l)
-             zqm=qs(ij+iip1,l)
-             zm=masse(ij+iip1,l)
-             zq=q(ij+iip1,l)
-          else
-             zsigm=zsign(ij)
-             zsigp=zsigs(ij)
-             zqm=qn(ij,l)
-             zqp=qs(ij,l)
-             zm=masse(ij,l)
-             zq=q(ij,l)
-          endif
-          zsig=abs(v_m(ij,l))/zm
-          if(zsig==0.) zsigp=0.1
-          if (zsig<=zsigp) then
-              v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
-          else
-              zz=0.5*(zsig-zsigp)/zsigm
-              v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp
-     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
-          endif
-       enddo
-      enddo
-
-      do l=1,llm
-         do ij=iip2,ip1jm
-            new_m=masse(ij,l)
-     &      +v_m(ij,l)-v_m(ij-iip1,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l))
-     &         /new_m
-            masse(ij,l)=new_m
-         enddo
-c.-. ancienne version
-         convpn=SSUM(iim,v_mq(1,l),1)
-         convmpn=ssum(iim,v_m(1,l),1)
-         massen=ssum(iim,masse(1,l),1)
-         new_m=massen+convmpn
-         q(1,l)=(q(1,l)*massen+convpn)/new_m
-         do ij = 1,iip1
-            q(ij,l)=q(1,l)
-            masse(ij,l)=new_m*aire(ij)/apoln
-         enddo
-
-         convps=-SSUM(iim,v_mq(ip1jm-iim,l),1)
-         convmps=-ssum(iim,v_m(ip1jm-iim,l),1)
-         masses=ssum(iim,masse(ip1jm+1,l),1)
-         new_m=masses+convmps
-         q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m
-         do ij = ip1jm+1,ip1jmp1
-            q(ij,l)=q(ip1jm+1,l)
-            masse(ij,l)=new_m*aire(ij)/apols
-         enddo
-      enddo
-
-      RETURN
-      END
-      SUBROUTINE advnz(q,qh,qb,masse,w_m)
-c
-c     Auteurs:   F.Hourdin
-c
-c    ********************************************************************
-c     Shema  d'advection " pseudo amont " .
-c     b designe le bas et h le haut
-c     il y a une correspondance entre le b en z et le d en x
-c    ********************************************************************
-c
-c
-c   --------------------------------------------------------------------
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INCLUDE "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      real masse(ip1jmp1,llm)
-      real w_m( ip1jmp1,llm+1)
-      real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm)
-
-c
-c      Local
-c   ---------
-c
-      INTEGER ij,l
-c
-      real new_m,zdq,zz
-      real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig
-      real w_mq(ip1jmp1,llm+1)
-      real zm,zq,zsigm,zsigp,zqm,zqp
-      real prec
-      save prec
-
-      data prec/1.e-13/
-
-      do l=1,llm
-            do ij=1,ip1jmp1
-               zdq=qb(ij,l)-qh(ij,l)
-c              if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then
-c                 PRINT*,'probleme au point ij=',ij,'  l=',l
-c                 PRINT*,qh(ij,l),q(ij,l),qb(ij,l)
-c                 qh(ij,l)=q(ij,l)
-c                 qb(ij,l)=q(ij,l)
-c              endif
-
-               if(abs(zdq)>prec) then
-                  zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq
-                  zsigh(ij,l)=1.-zsigb(ij,l)
-                  zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.)
-               else
-                  zsigb(ij,l)=0.5
-                  zsigh(ij,l)=0.5
-               endif
-            enddo
-       enddo
-
-c      PRINT*,'ok1'
-c   calcul de la pente maximum dans la maille en valeur absolue
-       do l=2,llm
-       do ij=1,ip1jmp1
-          if (w_m(ij,l)>=0.) then
-             zsigp=zsigb(ij,l)
-             zsigm=zsigh(ij,l)
-             zqp=qb(ij,l)
-             zqm=qh(ij,l)
-             zm=masse(ij,l)
-             zq=q(ij,l)
-          else
-             zsigm=zsigb(ij,l-1)
-             zsigp=zsigh(ij,l-1)
-             zqm=qb(ij,l-1)
-             zqp=qh(ij,l-1)
-             zm=masse(ij,l-1)
-             zq=q(ij,l-1)
-          endif
-          zsig=abs(w_m(ij,l))/zm
-          if(zsig==0.) zsigp=0.1
-          if (zsig<=zsigp) then
-              w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
-          else
-              zz=0.5*(zsig-zsigp)/zsigm
-              w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp
-     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
-          endif
-      enddo
-      enddo
-
-       do ij=1,ip1jmp1
-          w_mq(ij,llm+1)=0.
-          w_mq(ij,1)=0.
-       enddo
-
-      do l=1,llm
-         do ij=1,ip1jmp1
-            new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l)
-            q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l))
-     &         /new_m
-            masse(ij,l)=new_m
-         enddo
-      enddo
-c     PRINT*,'ok3'
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advn.f90	(revision 5105)
@@ -0,0 +1,951 @@
+
+! $Header$
+
+SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode)
+  !
+  ! Auteur : F. Hourdin
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !   pbaru,pbarv,w flux de masse en u ,v ,w
+  !   pdt pas de temps
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments:
+  !   ----------
+  integer :: mode
+  real :: masse(ip1jmp1,llm)
+  REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+  REAL :: q(ip1jmp1,llm)
+  REAL :: w(ip1jmp1,llm),pdt
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i,ij,l,j,ii
+  integer :: ijlqmin,iqmin,jqmin,lqmin
+  integer :: ismin
+  !
+  real :: zm(ip1jmp1,llm),newmasse
+  real :: mu(ip1jmp1,llm)
+  real :: mv(ip1jm,llm)
+  real :: mw(ip1jmp1,llm+1)
+  real :: zq(ip1jmp1,llm),zz,qpn,qps
+  real :: zqg(ip1jmp1,llm),zqd(ip1jmp1,llm)
+  real :: zqs(ip1jmp1,llm),zqn(ip1jmp1,llm)
+  real :: zqh(ip1jmp1,llm),zqb(ip1jmp1,llm)
+  real :: temps0,temps1,temps2,temps3
+  real :: ztemps1,ztemps2,ssum
+  save temps1,temps2,temps3
+  real :: zzpbar,zzw
+
+  real :: qmin,qmax
+  data qmin,qmax/0.,1./
+  data temps1,temps2,temps3/0.,0.,0./
+
+  zzpbar = 0.5 * pdt
+  zzw    = pdt
+
+  DO l=1,llm
+    DO ij = iip2,ip1jm
+        mu(ij,l)=pbaru(ij,l) * zzpbar
+     ENDDO
+     DO ij=1,ip1jm
+        mv(ij,l)=pbarv(ij,l) * zzpbar
+     ENDDO
+     DO ij=1,ip1jmp1
+        mw(ij,l)=w(ij,l) * zzw
+     ENDDO
+  ENDDO
+
+  DO ij=1,ip1jmp1
+     mw(ij,llm+1)=0.
+  ENDDO
+
+  do l=1,llm
+     qpn=0.
+     qps=0.
+     do ij=1,iim
+        qpn=qpn+q(ij,l)*masse(ij,l)
+        qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l)
+     enddo
+     qpn=qpn/ssum(iim,masse(1,l),1)
+     qps=qps/ssum(iim,masse(ip1jm+1,l),1)
+     do ij=1,iip1
+        q(ij,l)=qpn
+        q(ip1jm+ij,l)=qps
+     enddo
+  enddo
+
+  do ij=1,ip1jmp1
+     mw(ij,llm+1)=0.
+  enddo
+  do l=1,llm
+     do ij=1,ip1jmp1
+        zq(ij,l)=q(ij,l)
+        zm(ij,l)=masse(ij,l)
+     enddo
+  enddo
+
+  ! CALL minmaxq(zq,qmin,qmax,'avant vlx     ')
+  CALL advnqx(zq,zqg,zqd)
+  CALL advnx(zq,zqg,zqd,zm,mu,mode)
+  CALL advnqy(zq,zqs,zqn)
+  CALL advny(zq,zqs,zqn,zm,mv)
+  CALL advnqz(zq,zqh,zqb)
+  CALL advnz(zq,zqh,zqb,zm,mw)
+  ! CALL vlz(zq,0.,zm,mw)
+  CALL advnqy(zq,zqs,zqn)
+  CALL advny(zq,zqs,zqn,zm,mv)
+  CALL advnqx(zq,zqg,zqd)
+  CALL advnx(zq,zqg,zqd,zm,mu,mode)
+  ! CALL minmaxq(zq,qmin,qmax,'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 SUBROUTINE advn
+
+SUBROUTINE advnqx(q,qg,qd)
+  !
+  ! Auteurs:   Calcul des valeurs de q aux point u.
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  real :: dxqu(ip1jmp1),zqu(ip1jmp1)
+  real :: zqmax(ip1jmp1),zqmin(ip1jmp1)
+  logical :: extremum(ip1jmp1)
+
+  integer :: mode
+  save mode
+  data mode/1/
+
+  !   calcul des pentes en u:
+  !   -----------------------
+  if (mode==0) then
+     do l=1,llm
+        do ij=1,ip1jm
+           qd(ij,l)=q(ij,l)
+           qg(ij,l)=q(ij,l)
+        enddo
+     enddo
+  else
+  do l = 1, llm
+     do ij=iip2,ip1jm-1
+        dxqu(ij)=q(ij+1,l)-q(ij,l)
+        zqu(ij)=0.5*(q(ij+1,l)+q(ij,l))
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        dxqu(ij)=dxqu(ij-iim)
+        zqu(ij)=zqu(ij-iim)
+     enddo
+     do ij=iip2,ip1jm-1
+        zqu(ij)=zqu(ij)-dxqu(ij+1)/12.
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        zqu(ij)=zqu(ij-iim)
+     enddo
+     do ij=iip2+1,ip1jm
+        zqu(ij)=zqu(ij)+dxqu(ij-1)/12.
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        zqu(ij-iim)=zqu(ij)
+     enddo
+
+  !   calcul des valeurs max et min acceptees aux interfaces
+
+     do ij=iip2,ip1jm-1
+        zqmax(ij)=max(q(ij+1,l),q(ij,l))
+        zqmin(ij)=min(q(ij+1,l),q(ij,l))
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        zqmax(ij)=zqmax(ij-iim)
+        zqmin(ij)=zqmin(ij-iim)
+     enddo
+     do ij=iip2+1,ip1jm
+        extremum(ij)=dxqu(ij)*dxqu(ij-1)<=0.
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        extremum(ij-iim)=extremum(ij)
+     enddo
+     do ij=iip2,ip1jm
+        zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij))
+     enddo
+     do ij=iip2+1,ip1jm
+        if(extremum(ij)) then
+           qg(ij,l)=q(ij,l)
+           qd(ij,l)=q(ij,l)
+        else
+           qd(ij,l)=zqu(ij)
+           qg(ij,l)=zqu(ij-1)
+        endif
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        qd(ij-iim,l)=qd(ij,l)
+        qg(ij-iim,l)=qg(ij,l)
+     enddo
+
+     goto 8888
+
+     do ij=iip2+1,ip1jm
+        if(extremum(ij).and..not.extremum(ij-1)) &
+              qd(ij-1,l)=q(ij,l)
+     enddo
+
+     do ij=iip1+iip1,ip1jm,iip1
+        qd(ij-iim,l)=qd(ij,l)
+     enddo
+     do ij=iip2,ip1jm-1
+        if (extremum(ij).and..not.extremum(ij+1)) &
+              qg(ij+1,l)=q(ij,l)
+     enddo
+
+     do ij=iip1+iip1,ip1jm,iip1
+        qg(ij,l)=qg(ij-iim,l)
+     enddo
+8888   continue
+  enddo
+  endif
+  RETURN
+END SUBROUTINE advnqx
+SUBROUTINE advnqy(q,qs,qn)
+  !
+  ! Auteurs:   Calcul des valeurs de q aux point v.
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  real :: dyqv(ip1jm),zqv(ip1jm,llm)
+  real :: zqmax(ip1jm),zqmin(ip1jm)
+  logical :: extremum(ip1jmp1)
+
+  integer :: mode
+  save mode
+  data mode/1/
+
+  if (mode==0) then
+     do l=1,llm
+        do ij=1,ip1jmp1
+           qn(ij,l)=q(ij,l)
+           qs(ij,l)=q(ij,l)
+        enddo
+     enddo
+  else
+
+  !   calcul des pentes en u:
+  !   -----------------------
+  do l = 1, llm
+     do ij=1,ip1jm
+        dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+     enddo
+
+     do ij=iip2,ip1jm-iip1
+        zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l))
+        zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12.
+     enddo
+
+     do ij=iip2,ip1jm
+        extremum(ij)=dyqv(ij)*dyqv(ij-iip1)<=0.
+     enddo
+
+  ! Pas de pentes aux poles
+     do ij=1,iip1
+        zqv(ij,l)=q(ij,l)
+        zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l)
+        extremum(ij)=.TRUE.
+        extremum(ip1jmp1-iip1+ij)=.TRUE.
+     enddo
+
+  !   calcul des valeurs max et min acceptees aux interfaces
+     do ij=1,ip1jm
+        zqmax(ij)=max(q(ij+iip1,l),q(ij,l))
+        zqmin(ij)=min(q(ij+iip1,l),q(ij,l))
+     enddo
+
+     do ij=1,ip1jm
+        zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij))
+     enddo
+
+     do ij=iip2,ip1jm
+        if(extremum(ij)) then
+           qs(ij,l)=q(ij,l)
+           qn(ij,l)=q(ij,l)
+           ! if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l)
+           ! if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l)
+        else
+           qs(ij,l)=zqv(ij,l)
+           qn(ij,l)=zqv(ij-iip1,l)
+        endif
+     enddo
+
+     do ij=1,iip1
+        qs(ij,l)=q(ij,l)
+        qn(ij,l)=q(ij,l)
+        qs(ip1jm+ij,l)=q(ip1jm+ij,l)
+        qn(ip1jm+ij,l)=q(ip1jm+ij,l)
+     enddo
+
+  enddo
+  endif
+  RETURN
+END SUBROUTINE advnqy
+
+SUBROUTINE advnqz(q,qh,qb)
+  !
+  ! Auteurs:   Calcul des valeurs de q aux point v.
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  real :: dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1)
+  real :: zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm)
+  logical :: extremum(ip1jmp1,llm)
+
+  integer :: mode
+  save mode
+
+  data mode/1/
+
+  !   calcul des pentes en u:
+  !   -----------------------
+
+  if (mode==0) then
+     do l=1,llm
+        do ij=1,ip1jmp1
+           qb(ij,l)=q(ij,l)
+           qh(ij,l)=q(ij,l)
+        enddo
+     enddo
+  else
+  do l = 2, llm
+     do ij=1,ip1jmp1
+        dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+        zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l))
+     enddo
+  enddo
+  do ij=1,ip1jmp1
+     dzqw(ij,1)=0.
+     dzqw(ij,llm+1)=0.
+  enddo
+  do l=2,llm
+     do ij=1,ip1jmp1
+        zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12.
+     enddo
+  enddo
+  do l=2,llm-1
+     do ij=1,ip1jmp1
+        extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1)<=0.
+     enddo
+  enddo
+
+  ! Pas de pentes en bas et en haut
+     do ij=1,ip1jmp1
+        zqw(ij,2)=q(ij,1)
+        zqw(ij,llm)=q(ij,llm)
+        extremum(ij,1)=.TRUE.
+        extremum(ij,llm)=.TRUE.
+     enddo
+
+  !   calcul des valeurs max et min acceptees aux interfaces
+  do l=2,llm
+     do ij=1,ip1jmp1
+        zqmax(ij,l)=max(q(ij,l-1),q(ij,l))
+        zqmin(ij,l)=min(q(ij,l-1),q(ij,l))
+     enddo
+  enddo
+
+  do l=2,llm
+     do ij=1,ip1jmp1
+        zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l))
+     enddo
+  enddo
+
+  do l=2,llm-1
+     do ij=1,ip1jmp1
+        if(extremum(ij,l)) then
+           qh(ij,l)=q(ij,l)
+           qb(ij,l)=q(ij,l)
+        else
+           qh(ij,l)=zqw(ij,l+1)
+           qb(ij,l)=zqw(ij,l)
+        endif
+     enddo
+  enddo
+  ! do l=2,llm-1
+  !    do ij=1,ip1jmp1
+  !       if(extremum(ij,l)) then
+  !          if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l)
+  !          if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l)
+  !       endif
+  !    enddo
+  ! enddo
+
+  do ij=1,ip1jmp1
+     qb(ij,1)=q(ij,1)
+     qh(ij,1)=q(ij,1)
+     qb(ij,llm)=q(ij,llm)
+     qh(ij,llm)=q(ij,llm)
+  enddo
+
+  endif
+
+  RETURN
+END SUBROUTINE advnqz
+
+SUBROUTINE advnx(q,qg,qd,masse,u_m,mode)
+  !
+  ! Auteur : F. Hourdin
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  integer :: mode
+  real :: masse(ip1jmp1,llm)
+  real :: u_m( ip1jmp1,llm )
+  real :: q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i,j,ij,l,indu(ip1jmp1),niju,iju,ijq
+  integer :: n0,nl(llm)
+  !
+  real :: new_m,zu_m,zdq,zz
+  real :: zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig
+  real :: u_mq(ip1jmp1,llm)
+
+  real :: zm,zq,zsigm,zsigp,zqm,zqp,zu
+
+  logical :: ladvplus(ip1jmp1,llm)
+
+  real :: prec
+  save prec
+
+  data prec/1.e-15/
+
+  do l=1,llm
+        do ij=iip2,ip1jm
+           zdq=qd(ij,l)-qg(ij,l)
+           ! if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then
+           !    PRINT*,'probleme au point ij=',ij,'  l=',l
+           !    PRINT*,qd(ij,l),q(ij,l),qg(ij,l)
+           !    qd(ij,l)=q(ij,l)
+           !    qg(ij,l)=q(ij,l)
+           ! endif
+           if(abs(zdq)>prec) then
+              zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq
+              zsigg(ij,l)=1.-zsigd(ij,l)
+              ! if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and.
+  !    s               zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then
+              !    PRINT*,'probleme au point ij=',ij,'  l=',l
+              !    PRINT*,'sigg=',zsigg(ij,l),'  sigd=',zsigd(ij,l)
+              !    PRINT*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq
+              !    stop
+              ! endif
+           else
+              zsigd(ij,l)=0.5
+              zsigg(ij,l)=0.5
+              qd(ij,l)=q(ij,l)
+              qg(ij,l)=q(ij,l)
+           endif
+        enddo
+   enddo
+
+  !   calcul de la pente maximum dans la maille en valeur absolue
+
+   do l=1,llm
+   do ij=iip2,ip1jm-1
+      if (u_m(ij,l)>=0.) then
+         zsigp=zsigd(ij,l)
+         zsigm=zsigg(ij,l)
+         zqp=qd(ij,l)
+         zqm=qg(ij,l)
+         zm=masse(ij,l)
+         zq=q(ij,l)
+      else
+         zsigm=zsigd(ij+1,l)
+         zsigp=zsigg(ij+1,l)
+         zqm=qd(ij+1,l)
+         zqp=qg(ij+1,l)
+         zm=masse(ij+1,l)
+         zq=q(ij+1,l)
+      endif
+      zu=abs(u_m(ij,l))
+      ladvplus(ij,l)=zu>zm
+      zsig=zu/zm
+      if(zsig==0.) zsigp=0.1
+      if (mode==1) then
+         if (zsig<=zsigp) then
+             u_mq(ij,l)=u_m(ij,l)*zqp
+         else if (mode==1) then
+             u_mq(ij,l)= &
+                   sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm)
+         endif
+      else
+         if (zsig<=zsigp) then
+             u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+         else
+            zz=0.5*(zsig-zsigp)/zsigm
+            u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp &
+                  +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+         endif
+      endif
+      ! if(zsig.lt.0.) then
+      !    PRINT*,'au point ij=',ij,'  l=',l,'  sig=',zsig
+      !    stop
+      ! endif
+  enddo
+  enddo
+
+  do l=1,llm
+   do ij=iip1+iip1,ip1jm,iip1
+      u_mq(ij,l)=u_mq(ij-iim,l)
+      ladvplus(ij,l)=ladvplus(ij-iim,l)
+   enddo
+  enddo
+
+  !=================================================================
+  !   SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES
+  !=================================================================
+  !   tris des regions a traiter
+  n0=0
+  do l=1,llm
+     nl(l)=0
+     do ij=iip2,ip1jm
+        if(ladvplus(ij,l)) then
+           nl(l)=nl(l)+1
+           u_mq(ij,l)=0.
+        endif
+     enddo
+     n0=n0+nl(l)
+  enddo
+
+  if(n0>1) then
+  IF (prt_level > 9) WRITE(lunout,*) &
+        'Nombre de points pour lesquels on advect plus que le' &
+        ,'contenu de la maille : ',n0
+
+     do l=1,llm
+        if(nl(l)>0) then
+           iju=0
+  !   indicage des mailles concernees par le traitement special
+           do ij=iip2,ip1jm
+              if(ladvplus(ij,l).and.mod(ij,iip1)/=0) then
+                 iju=iju+1
+                 indu(iju)=ij
+              endif
+           enddo
+           niju=iju
+           ! PRINT*,'niju,nl',niju,nl(l)
+
+  !  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>0.) then
+                 ijq=ij
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(zu_m>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
+  !   MODIFS SPECIFIQUES DU SCHEMA
+  !   ajout de la maille non completement advectee
+         zsig=zu_m/masse(ijq,l)
+         if(zsig<=zsigd(ijq,l)) then
+            u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) &
+                  -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l)))
+         else
+            ! u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+      ! goto 8888
+            zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l)
+            if(.not.(zz>0..and.zz<=0.5)) then
+                 WRITE(lunout,*)'probleme2 au point ij=',ij, &
+                       '  l=',l
+                 WRITE(lunout,*)'zz=',zz
+                 stop
+            endif
+            u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( &
+                  0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) &
+                  +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) )
+         endif
+              else
+                 ijq=ij+1
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(-zu_m>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
+  !   ajout de la maille non completement advectee
+  ! 2eme MODIF SPECIFIQUE
+         zsig=-zu_m/masse(ij+1,l)
+         if(zsig<=zsigg(ijq,l)) then
+            u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) &
+                  -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l)))
+         else
+            ! u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+        ! goto 9999
+            zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l)
+            if(.not.(zz>0..and.zz<=0.5)) then
+                 WRITE(lunout,*)'probleme22 au point ij=',ij &
+                       ,'  l=',l
+                 WRITE(lunout,*)'zz=',zz
+                 stop
+            endif
+            u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( &
+                  0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) &
+                  +(zsig-zsigg(ijq,l))* &
+                  (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) )
+         endif
+  !   fin de la modif
+              endif
+           enddo
+        endif
+     enddo
+  endif  ! n0.gt.0
+
+  !   bouclage en latitude
+  do l=1,llm
+    do ij=iip1+iip1,ip1jm,iip1
+       u_mq(ij,l)=u_mq(ij-iim,l)
+    enddo
+  enddo
+
+  !=================================================================
+  !   CALCUL DE LA CONVERGENCE DES FLUX
+  !=================================================================
+
+  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
+  !   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
+
+  RETURN
+END SUBROUTINE advnx
+SUBROUTINE advny(q,qs,qn,masse,v_m)
+  !
+  ! Auteur : F. Hourdin
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: masse(ip1jmp1,llm)
+  real :: v_m( ip1jm,llm )
+  real :: q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  real :: new_m,zdq,zz
+  real :: zsigs(ip1jmp1),zsign(ip1jmp1),zsig
+  real :: v_mq(ip1jm,llm)
+  real :: convpn,convps,convmpn,convmps,massen,masses
+  real :: zm,zq,zsigm,zsigp,zqm,zqp
+  real :: ssum
+  real :: prec
+  save prec
+
+  data prec/1.e-15/
+  do l=1,llm
+        do ij=1,ip1jmp1
+           zdq=qn(ij,l)-qs(ij,l)
+           ! if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then
+           !    PRINT*,'probleme au point ij=',ij,'  l=',l,'  advnqx'
+           !    PRINT*,qn(ij,l),q(ij,l),qs(ij,l)
+           !    qn(ij,l)=q(ij,l)
+           !    qs(ij,l)=q(ij,l)
+           ! endif
+           if(abs(zdq)>prec) then
+              zsign(ij)=(q(ij,l)-qs(ij,l))/zdq
+              zsigs(ij)=1.-zsign(ij)
+              ! if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and.
+  !    s               zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then
+              !    PRINT*,'probleme au point ij=',ij,'  l=',l
+              !    PRINT*,'sigs=',zsigs(ij),'  sign=',zsign(ij)
+              !    stop
+              ! endif
+           else
+              zsign(ij)=0.5
+              zsigs(ij)=0.5
+           endif
+        enddo
+
+  !   calcul de la pente maximum dans la maille en valeur absolue
+
+   do ij=1,ip1jm
+      if (v_m(ij,l)>=0.) then
+         zsigp=zsign(ij+iip1)
+         zsigm=zsigs(ij+iip1)
+         zqp=qn(ij+iip1,l)
+         zqm=qs(ij+iip1,l)
+         zm=masse(ij+iip1,l)
+         zq=q(ij+iip1,l)
+      else
+         zsigm=zsign(ij)
+         zsigp=zsigs(ij)
+         zqm=qn(ij,l)
+         zqp=qs(ij,l)
+         zm=masse(ij,l)
+         zq=q(ij,l)
+      endif
+      zsig=abs(v_m(ij,l))/zm
+      if(zsig==0.) zsigp=0.1
+      if (zsig<=zsigp) then
+          v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+      else
+          zz=0.5*(zsig-zsigp)/zsigm
+          v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp &
+                +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+      endif
+   enddo
+  enddo
+
+  do l=1,llm
+     do ij=iip2,ip1jm
+        new_m=masse(ij,l) &
+              +v_m(ij,l)-v_m(ij-iip1,l)
+        q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) &
+              /new_m
+        masse(ij,l)=new_m
+     enddo
+  !.-. ancienne version
+     convpn=SSUM(iim,v_mq(1,l),1)
+     convmpn=ssum(iim,v_m(1,l),1)
+     massen=ssum(iim,masse(1,l),1)
+     new_m=massen+convmpn
+     q(1,l)=(q(1,l)*massen+convpn)/new_m
+     do ij = 1,iip1
+        q(ij,l)=q(1,l)
+        masse(ij,l)=new_m*aire(ij)/apoln
+     enddo
+
+     convps=-SSUM(iim,v_mq(ip1jm-iim,l),1)
+     convmps=-ssum(iim,v_m(ip1jm-iim,l),1)
+     masses=ssum(iim,masse(ip1jm+1,l),1)
+     new_m=masses+convmps
+     q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m
+     do ij = ip1jm+1,ip1jmp1
+        q(ij,l)=q(ip1jm+1,l)
+        masse(ij,l)=new_m*aire(ij)/apols
+     enddo
+  enddo
+
+  RETURN
+END SUBROUTINE advny
+SUBROUTINE advnz(q,qh,qb,masse,w_m)
+  !
+  ! Auteurs:   F.Hourdin
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  ! b designe le bas et h le haut
+  ! il y a une correspondance entre le b en z et le d en x
+  !    ********************************************************************
+  !
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: masse(ip1jmp1,llm)
+  real :: w_m( ip1jmp1,llm+1)
+  real :: q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm)
+
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  real :: new_m,zdq,zz
+  real :: zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig
+  real :: w_mq(ip1jmp1,llm+1)
+  real :: zm,zq,zsigm,zsigp,zqm,zqp
+  real :: prec
+  save prec
+
+  data prec/1.e-13/
+
+  do l=1,llm
+        do ij=1,ip1jmp1
+           zdq=qb(ij,l)-qh(ij,l)
+           ! if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then
+           !    PRINT*,'probleme au point ij=',ij,'  l=',l
+           !    PRINT*,qh(ij,l),q(ij,l),qb(ij,l)
+           !    qh(ij,l)=q(ij,l)
+           !    qb(ij,l)=q(ij,l)
+           ! endif
+
+           if(abs(zdq)>prec) then
+              zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq
+              zsigh(ij,l)=1.-zsigb(ij,l)
+              zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.)
+           else
+              zsigb(ij,l)=0.5
+              zsigh(ij,l)=0.5
+           endif
+        enddo
+   enddo
+
+   ! PRINT*,'ok1'
+  !   calcul de la pente maximum dans la maille en valeur absolue
+   do l=2,llm
+   do ij=1,ip1jmp1
+      if (w_m(ij,l)>=0.) then
+         zsigp=zsigb(ij,l)
+         zsigm=zsigh(ij,l)
+         zqp=qb(ij,l)
+         zqm=qh(ij,l)
+         zm=masse(ij,l)
+         zq=q(ij,l)
+      else
+         zsigm=zsigb(ij,l-1)
+         zsigp=zsigh(ij,l-1)
+         zqm=qb(ij,l-1)
+         zqp=qh(ij,l-1)
+         zm=masse(ij,l-1)
+         zq=q(ij,l-1)
+      endif
+      zsig=abs(w_m(ij,l))/zm
+      if(zsig==0.) zsigp=0.1
+      if (zsig<=zsigp) then
+          w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+      else
+          zz=0.5*(zsig-zsigp)/zsigm
+          w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp &
+                +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+      endif
+  enddo
+  enddo
+
+   do ij=1,ip1jmp1
+      w_mq(ij,llm+1)=0.
+      w_mq(ij,1)=0.
+   enddo
+
+  do l=1,llm
+     do ij=1,ip1jmp1
+        new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l)
+        q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) &
+              /new_m
+        masse(ij,l)=new_m
+     enddo
+  enddo
+  ! PRINT*,'ok3'
+  RETURN
+END SUBROUTINE advnz
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advx.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advx.F	(revision 5104)
+++ 	(revision )
@@ -1,501 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE  advx(limit,dtx,pbaru,sm,s0,
-     $     sx,sy,sz,lati,latf)
-      IMPLICIT NONE
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                C
-C  first-order moments (FOM) advection of tracer in X direction  C
-C                                                                C
-C  Source : Pascal Simon (Meteo,CNRM)                            C
-C  Adaptation : A.Armengaud (LGGE) juin 94                       C
-C                                                                C
-C  limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C
-C  sont des arguments d'entree pour le s-pg...                   C
-C                                                                C
-C  sm,s0,sx,sy,sz                                                C
-C  sont les arguments de sortie pour le s-pg                     C
-C                                                                C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C  parametres principaux du modele
-C
-      include "dimensions.h"
-      include "paramet.h"
-
-C  Arguments :
-C  -----------
-C  dtx : frequence fictive d'appel du transport 
-C  pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1
-
-       INTEGER ntra
-       PARAMETER (ntra = 1)
-
-C ATTENTION partout ou on trouve ntra, insertion de boucle
-C           possible dans l'avenir.
-
-      REAL dtx
-      REAL pbaru ( iip1,jjp1,llm )
-
-C  moments: SM  total mass in each grid box
-C           S0  mass of tracer in each grid box
-C           Si  1rst order moment in i direction
-C
-      REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra)
-      REAL sx(iip1,jjp1,llm,ntra)
-     $    ,sy(iip1,jjp1,llm,ntra)
-      REAL sz(iip1,jjp1,llm,ntra)
-
-C  Local :
-C  ------- 
-
-C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
-C  mass fluxes in kg
-C  declaration :
-
-      REAL UGRI(iip1,jjp1,llm)
-
-C  Rem : VGRI et WGRI ne sont pas utilises dans 
-C  cette SUBROUTINE ( advection en x uniquement )
-C
-C  Ti are the moments for the current latitude and level
-C
-      REAL TM(iim)
-      REAL T0(iim,ntra),TX(iim,ntra)
-      REAL TY(iim,ntra),TZ(iim,ntra)
-      REAL TEMPTM                ! just a temporary variable
-C
-C  the moments F are similarly defined and used as temporary
-C  storage for portions of the grid boxes in transit
-C
-      REAL FM(iim)
-      REAL F0(iim,ntra),FX(iim,ntra)
-      REAL FY(iim,ntra),FZ(iim,ntra)
-C
-C  work arrays
-C
-      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
-C
-      REAL SMNEW(iim),UEXT(iim)
-C
-      REAL sqi,sqf
-
-      LOGICAL LIMIT
-      INTEGER NUM(jjp1),LONK,NUMK
-      INTEGER lon,lati,latf,niv
-      INTEGER i,i2,i3,j,jv,l,k,itrac 
-
-      lon = iim 
-      niv = llm 
-
-C *** Test de passage d'arguments ******
-
-
-C  -------------------------------------
-      DO j = 1,jjp1 
-         NUM(j) = 1
-      END DO
-      sqi = 0.
-      sqf = 0.
-
-      DO l = 1,llm
-         DO j = 1,jjp1
-            DO i = 1,iim
-cIM 240305            sqi = sqi + S0(i,j,l,9)
-               sqi = sqi + S0(i,j,l,ntra)
-            ENDDO
-         ENDDO
-      ENDDO
-      PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------'
-      PRINT*,'sqi=',sqi
-
-
-C  Interface : adaptation nouveau modele
-C  -------------------------------------
-C
-C  ---------------------------------------------------------
-C  Conversion des flux de masses en kg/s
-C  pbaru est en N/s d'ou :
-C  ugri est en kg/s
-
-      DO l = 1,llm
-         DO j = 1,jjm+1
-            DO i = 1,iip1
-C            ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )
-             ugri (i,j,llm+1-l) = pbaru (i,j,l)
-      END DO
-      END DO
-      END DO
-
-
-C  ---------------------------------------------------------
-C  ---------------------------------------------------------
-C  ---------------------------------------------------------
-  
-C  start here          
-C
-C  boucle principale sur les niveaux et les latitudes
-C
-      DO L=1,NIV
-      DO K=lati,latf
-C
-C  initialisation
-C
-C  program assumes periodic boundaries in X
-C
-      DO I=2,LON
-         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
-      END DO
-      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
-C
-C  modifications for extended polar zones
-C
-      NUMK=NUM(K)
-      LONK=LON/NUMK
-C
-      IF(NUMK>1) THEN
-C
-      DO I=1,LON
-         TM(I)=0.
-      END DO
-      DO JV=1,NTRA
-      DO I=1,LON
-         T0(I,JV)=0.
-         TX(I,JV)=0.
-         TY(I,JV)=0.
-         TZ(I,JV)=0.
-      END DO
-      END DO
-C
-      DO I2=1,NUMK
-C
-         DO I=1,LONK
-            I3=(I-1)*NUMK+I2
-            TM(I)=TM(I)+SM(I3,K,L)
-            ALF(I)=SM(I3,K,L)/TM(I)
-            ALF1(I)=1.-ALF(I)
-      END DO
-C
-         DO  JV=1,NTRA
-         DO  I=1,LONK
-            I3=(I-1)*NUMK+I2
-            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)
-     $          *S0(I3,K,L,JV)
-            T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV)
-            TX(I,JV)=ALF(I)  *sx(I3,K,L,JV)+
-     $       ALF1(I)*TX(I,JV) +3.*TEMPTM
-            TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV)
-            TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV)
-         ENDDO 
-         ENDDO
-C
-      END DO
-C
-      ELSE
-C
-      DO I=1,LON
-         TM(I)=SM(I,K,L)
-      END DO
-      DO JV=1,NTRA
-      DO I=1,LON
-         T0(I,JV)=S0(I,K,L,JV)
-         TX(I,JV)=sx(I,K,L,JV)
-         TY(I,JV)=sy(I,K,L,JV)
-         TZ(I,JV)=sz(I,K,L,JV)
-      END DO
-      END DO
-C
-      ENDIF
-C
-      DO I=1,LONK
-         UEXT(I)=UGRI(I*NUMK,K,L)
-      END DO
-C
-C  place limits on appropriate moments before transport
-C      (if flux-limiting is to be applied)
-C
-      IF(.NOT.LIMIT) GO TO 13
-C
-      DO JV=1,NTRA
-      DO I=1,LONK
-        TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))
-      END DO
-      END DO
-C
- 13   CONTINUE
-C
-C  calculate flux and moments between adjacent boxes
-C  1- create temporary moments/masses for partial boxes in transit
-C  2- reajusts moments remaining in the box
-C
-C  flux from IP to I if U(I).lt.0
-C
-      DO I=1,LONK-1
-         IF(UEXT(I)<0.) THEN
-           FM(I)=-UEXT(I)*DTX
-           ALF(I)=FM(I)/TM(I+1)
-           TM(I+1)=TM(I+1)-FM(I)
-         ENDIF
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)<0.) THEN
-        FM(I)=-UEXT(I)*DTX
-        ALF(I)=FM(I)/TM(1)
-        TM(1)=TM(1)-FM(I)
-      ENDIF
-C
-C  flux from I to IP if U(I).gt.0
-C
-      DO I=1,LONK
-         IF(UEXT(I)>=0.) THEN
-           FM(I)=UEXT(I)*DTX
-           ALF(I)=FM(I)/TM(I)
-           TM(I)=TM(I)-FM(I)
-         ENDIF
-      END DO
-C
-      DO I=1,LONK
-         ALFQ(I)=ALF(I)*ALF(I)
-         ALF1(I)=1.-ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LONK-1
-C
-         IF(UEXT(I)<0.) THEN
-C
-           F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) )
-           FX(I,JV)=ALFQ(I)*TX(I+1,JV)
-           FY(I,JV)=ALF (I)*TY(I+1,JV)
-           FZ(I,JV)=ALF (I)*TZ(I+1,JV)
-C
-           T0(I+1,JV)=T0(I+1,JV)-F0(I,JV)
-           TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV)
-           TY(I+1,JV)=TY(I+1,JV)-FY(I,JV)
-           TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)<0.) THEN
-C
-        DO JV=1,NTRA
-C
-           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) )
-           FX (I,JV)=ALFQ(I)*TX(1,JV)
-           FY (I,JV)=ALF (I)*TY(1,JV)
-           FZ (I,JV)=ALF (I)*TZ(1,JV)
-C
-           T0(1,JV)=T0(1,JV)-F0(I,JV)
-           TX(1,JV)=ALF1Q(I)*TX(1,JV)
-           TY(1,JV)=TY(1,JV)-FY(I,JV)
-           TZ(1,JV)=TZ(1,JV)-FZ(I,JV)
-C
-      END DO
-C
-      ENDIF
-C
-      DO JV=1,NTRA
-      DO I=1,LONK
-C
-         IF(UEXT(I)>=0.) THEN
-C
-           F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) )
-           FX(I,JV)=ALFQ(I)*TX(I,JV)
-           FY(I,JV)=ALF (I)*TY(I,JV)
-           FZ(I,JV)=ALF (I)*TZ(I,JV)
-C
-           T0(I,JV)=T0(I,JV)-F0(I,JV)
-           TX(I,JV)=ALF1Q(I)*TX(I,JV)
-           TY(I,JV)=TY(I,JV)-FY(I,JV)
-           TZ(I,JV)=TZ(I,JV)-FZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO I=1,LONK
-         IF(UEXT(I)<0.) THEN
-           TM(I)=TM(I)+FM(I)
-           ALF(I)=FM(I)/TM(I)
-         ENDIF
-      END DO
-C
-      DO I=1,LONK-1
-         IF(UEXT(I)>=0.) THEN
-           TM(I+1)=TM(I+1)+FM(I)
-           ALF(I)=FM(I)/TM(I+1)
-         ENDIF
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)>=0.) THEN
-        TM(1)=TM(1)+FM(I)
-        ALF(I)=FM(I)/TM(1)
-      ENDIF
-C
-      DO I=1,LONK
-         ALF1(I)=1.-ALF(I)
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LONK
-C
-         IF(UEXT(I)<0.) THEN
-C
-           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
-           T0(I,JV)=T0(I,JV)+F0(I,JV)
-           TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
-           TY(I,JV)=TY(I,JV)+FY(I,JV)
-           TZ(I,JV)=TZ(I,JV)+FZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LONK-1
-C
-         IF(UEXT(I)>=0.) THEN
-C
-           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
-           T0(I+1,JV)=T0(I+1,JV)+F0(I,JV)
-           TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM
-           TY(I+1,JV)=TY(I+1,JV)+FY(I,JV)
-           TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)>=0.) THEN
-        DO JV=1,NTRA
-           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
-           T0(1,JV)=T0(1,JV)+F0(I,JV)
-           TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
-           TY(1,JV)=TY(1,JV)+FY(I,JV)
-           TZ(1,JV)=TZ(1,JV)+FZ(I,JV)
-      END DO
-      ENDIF
-C
-C  retour aux mailles d'origine (passage des Tij aux Sij)
-C
-      IF(NUMK>1) THEN
-C
-      DO I2=1,NUMK
-C
-         DO I=1,LONK
-C
-            I3=I2+(I-1)*NUMK
-            SM(I3,K,L)=SMNEW(I3)
-            ALF(I)=SMNEW(I3)/TM(I)
-            TM(I)=TM(I)-SMNEW(I3)
-C
-            ALFQ(I)=ALF(I)*ALF(I)
-            ALF1(I)=1.-ALF(I)
-            ALF1Q(I)=ALF1(I)*ALF1(I)
-C
-      END DO
-      END DO
-C
-         DO  JV=1,NTRA
-         DO  I=1,LONK
-C
-            I3=I2+(I-1)*NUMK
-            S0(I3,K,L,JV)=ALF (I)
-     $       * (T0(I,JV)-ALF1(I)*TX(I,JV))
-            sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV)
-            sy(I3,K,L,JV)=ALF (I)*TY(I,JV)
-            sz(I3,K,L,JV)=ALF (I)*TZ(I,JV)
-C
-C   reajusts moments remaining in the box
-C
-            T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV)
-            TX(I,JV)=ALF1Q(I)*TX(I,JV)
-            TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV)
-            TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV)
-          ENDDO
-          ENDDO
-C
-C
-      ELSE
-C
-      DO I=1,LON
-         SM(I,K,L)=TM(I)
-      END DO
-      DO JV=1,NTRA
-      DO I=1,LON
-         S0(I,K,L,JV)=T0(I,JV)
-         sx(I,K,L,JV)=TX(I,JV)
-         sy(I,K,L,JV)=TY(I,JV)
-         sz(I,K,L,JV)=TZ(I,JV)
-      END DO
-      END DO
-C
-      ENDIF
-C
-      END DO
-      END DO
-C
-C ----------- AA Test en fin de ADVX ------ Controle des S*
-c OK
-c      DO 9998 l = 1, llm
-c      DO 9998 j = 1, jjp1
-c      DO 9998 i = 1, iip1
-c         IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
-c            PRINT*, '-------------------'
-c            PRINT*, 'En fin de ADVX'
-c            PRINT*,'SM(',i,j,l,')=',SM(i,j,l)
-c            PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
-c            PRINT*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
-c            PRINT*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
-c            PRINT*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
-c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1'
-cc            STOP
-c         ENDIF
-c 9998 CONTINUE
-c
-C ---------- bouclage cyclique 
-      DO itrac=1,ntra
-      DO l = 1,llm
-        DO j = lati,latf
-           SM(iip1,j,l) = SM(1,j,l)
-           S0(iip1,j,l,itrac) = S0(1,j,l,itrac)
-           sx(iip1,j,l,itrac) = sx(1,j,l,itrac)
-           sy(iip1,j,l,itrac) = sy(1,j,l,itrac)
-           sz(iip1,j,l,itrac) = sz(1,j,l,itrac)
-        END DO
-      END DO
-      ENDDO 
-
-c ----------- qqtite totale de traceur dans tte l'atmosphere
-      DO l = 1, llm
-        DO j = 1, jjp1
-          DO i = 1, iim
-cIM 240405          sqf = sqf + S0(i,j,l,9)
-             sqf = sqf + S0(i,j,l,ntra)
-          END DO  
-        END DO
-      END DO
-c
-      PRINT*,'------ DIAG DANS ADVX - SORTIE -----'
-      PRINT*,'sqf=',sqf
-c-------------
-
-      RETURN
-      END
-C_________________________________________________________________
-C_________________________________________________________________
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advx.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advx.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advx.f90	(revision 5105)
@@ -0,0 +1,501 @@
+
+! $Header$
+
+SUBROUTINE  advx(limit,dtx,pbaru,sm,s0, &
+        sx,sy,sz,lati,latf)
+  IMPLICIT NONE
+
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                C
+  !  first-order moments (FOM) advection of tracer in X direction  C
+  !                                                                C
+  !  Source : Pascal Simon (Meteo,CNRM)                            C
+  !  Adaptation : A.Armengaud (LGGE) juin 94                       C
+  !                                                                C
+  !  limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C
+  !  sont des arguments d'entree pour le s-pg...                   C
+  !                                                                C
+  !  sm,s0,sx,sy,sz                                                C
+  !  sont les arguments de sortie pour le s-pg                     C
+  !                                                                C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !
+  !  parametres principaux du modele
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+  !  Arguments :
+  !  -----------
+  !  dtx : frequence fictive d'appel du transport
+  !  pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1
+
+   INTEGER :: ntra
+   PARAMETER (ntra = 1)
+
+  ! ATTENTION partout ou on trouve ntra, insertion de boucle
+        ! possible dans l'avenir.
+
+  REAL :: dtx
+  REAL :: pbaru ( iip1,jjp1,llm )
+
+  !  moments: SM  total mass in each grid box
+        ! S0  mass of tracer in each grid box
+        ! Si  1rst order moment in i direction
+  !
+  REAL :: SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra)
+  REAL :: sx(iip1,jjp1,llm,ntra) &
+        ,sy(iip1,jjp1,llm,ntra)
+  REAL :: sz(iip1,jjp1,llm,ntra)
+
+  !  Local :
+  !  -------
+
+  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+  !  mass fluxes in kg
+  !  declaration :
+
+  REAL :: UGRI(iip1,jjp1,llm)
+
+  !  Rem : VGRI et WGRI ne sont pas utilises dans
+  !  cette SUBROUTINE ( advection en x uniquement )
+  !
+  !  Ti are the moments for the current latitude and level
+  !
+  REAL :: TM(iim)
+  REAL :: T0(iim,ntra),TX(iim,ntra)
+  REAL :: TY(iim,ntra),TZ(iim,ntra)
+  REAL :: TEMPTM                ! just a temporary variable
+  !
+  !  the moments F are similarly defined and used as temporary
+  !  storage for portions of the grid boxes in transit
+  !
+  REAL :: FM(iim)
+  REAL :: F0(iim,ntra),FX(iim,ntra)
+  REAL :: FY(iim,ntra),FZ(iim,ntra)
+  !
+  !  work arrays
+  !
+  REAL :: ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+  !
+  REAL :: SMNEW(iim),UEXT(iim)
+  !
+  REAL :: sqi,sqf
+
+  LOGICAL :: LIMIT
+  INTEGER :: NUM(jjp1),LONK,NUMK
+  INTEGER :: lon,lati,latf,niv
+  INTEGER :: i,i2,i3,j,jv,l,k,itrac
+
+  lon = iim
+  niv = llm
+
+  ! *** Test de passage d'arguments ******
+
+
+  !  -------------------------------------
+  DO j = 1,jjp1
+     NUM(j) = 1
+  END DO
+  sqi = 0.
+  sqf = 0.
+
+  DO l = 1,llm
+     DO j = 1,jjp1
+        DO i = 1,iim
+  !IM 240305            sqi = sqi + S0(i,j,l,9)
+           sqi = sqi + S0(i,j,l,ntra)
+        ENDDO
+     ENDDO
+  ENDDO
+  PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------'
+  PRINT*,'sqi=',sqi
+
+
+  !  Interface : adaptation nouveau modele
+  !  -------------------------------------
+  !
+  !  ---------------------------------------------------------
+  !  Conversion des flux de masses en kg/s
+  !  pbaru est en N/s d'ou :
+  !  ugri est en kg/s
+
+  DO l = 1,llm
+     DO j = 1,jjm+1
+        DO i = 1,iip1
+         ! ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )
+         ugri (i,j,llm+1-l) = pbaru (i,j,l)
+  END DO
+  END DO
+  END DO
+
+
+  !  ---------------------------------------------------------
+  !  ---------------------------------------------------------
+  !  ---------------------------------------------------------
+
+  !  start here
+  !
+  !  boucle principale sur les niveaux et les latitudes
+  !
+  DO L=1,NIV
+  DO K=lati,latf
+  !
+  !  initialisation
+  !
+  !  program assumes periodic boundaries in X
+  !
+  DO I=2,LON
+     SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+  END DO
+  SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+  !
+  !  modifications for extended polar zones
+  !
+  NUMK=NUM(K)
+  LONK=LON/NUMK
+  !
+  IF(NUMK>1) THEN
+  !
+  DO I=1,LON
+     TM(I)=0.
+  END DO
+  DO JV=1,NTRA
+  DO I=1,LON
+     T0(I,JV)=0.
+     TX(I,JV)=0.
+     TY(I,JV)=0.
+     TZ(I,JV)=0.
+  END DO
+  END DO
+  !
+  DO I2=1,NUMK
+  !
+     DO I=1,LONK
+        I3=(I-1)*NUMK+I2
+        TM(I)=TM(I)+SM(I3,K,L)
+        ALF(I)=SM(I3,K,L)/TM(I)
+        ALF1(I)=1.-ALF(I)
+  END DO
+  !
+     DO  JV=1,NTRA
+     DO  I=1,LONK
+        I3=(I-1)*NUMK+I2
+        TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I) &
+              *S0(I3,K,L,JV)
+        T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+        TX(I,JV)=ALF(I)  *sx(I3,K,L,JV)+ &
+              ALF1(I)*TX(I,JV) +3.*TEMPTM
+        TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV)
+        TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV)
+     ENDDO
+     ENDDO
+  !
+  END DO
+  !
+  ELSE
+  !
+  DO I=1,LON
+     TM(I)=SM(I,K,L)
+  END DO
+  DO JV=1,NTRA
+  DO I=1,LON
+     T0(I,JV)=S0(I,K,L,JV)
+     TX(I,JV)=sx(I,K,L,JV)
+     TY(I,JV)=sy(I,K,L,JV)
+     TZ(I,JV)=sz(I,K,L,JV)
+  END DO
+  END DO
+  !
+  ENDIF
+  !
+  DO I=1,LONK
+     UEXT(I)=UGRI(I*NUMK,K,L)
+  END DO
+  !
+  !  place limits on appropriate moments before transport
+  !  (if flux-limiting is to be applied)
+  !
+  IF(.NOT.LIMIT) GO TO 13
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK
+    TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))
+  END DO
+  END DO
+  !
+ 13   CONTINUE
+  !
+  !  calculate flux and moments between adjacent boxes
+  !  1- create temporary moments/masses for partial boxes in transit
+  !  2- reajusts moments remaining in the box
+  !
+  !  flux from IP to I if U(I).lt.0
+  !
+  DO I=1,LONK-1
+     IF(UEXT(I)<0.) THEN
+       FM(I)=-UEXT(I)*DTX
+       ALF(I)=FM(I)/TM(I+1)
+       TM(I+1)=TM(I+1)-FM(I)
+     ENDIF
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)<0.) THEN
+    FM(I)=-UEXT(I)*DTX
+    ALF(I)=FM(I)/TM(1)
+    TM(1)=TM(1)-FM(I)
+  ENDIF
+  !
+  !  flux from I to IP if U(I).gt.0
+  !
+  DO I=1,LONK
+     IF(UEXT(I)>=0.) THEN
+       FM(I)=UEXT(I)*DTX
+       ALF(I)=FM(I)/TM(I)
+       TM(I)=TM(I)-FM(I)
+     ENDIF
+  END DO
+  !
+  DO I=1,LONK
+     ALFQ(I)=ALF(I)*ALF(I)
+     ALF1(I)=1.-ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK-1
+  !
+     IF(UEXT(I)<0.) THEN
+  !
+       F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) )
+       FX(I,JV)=ALFQ(I)*TX(I+1,JV)
+       FY(I,JV)=ALF (I)*TY(I+1,JV)
+       FZ(I,JV)=ALF (I)*TZ(I+1,JV)
+  !
+       T0(I+1,JV)=T0(I+1,JV)-F0(I,JV)
+       TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV)
+       TY(I+1,JV)=TY(I+1,JV)-FY(I,JV)
+       TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)<0.) THEN
+  !
+    DO JV=1,NTRA
+  !
+       F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) )
+       FX (I,JV)=ALFQ(I)*TX(1,JV)
+       FY (I,JV)=ALF (I)*TY(1,JV)
+       FZ (I,JV)=ALF (I)*TZ(1,JV)
+  !
+       T0(1,JV)=T0(1,JV)-F0(I,JV)
+       TX(1,JV)=ALF1Q(I)*TX(1,JV)
+       TY(1,JV)=TY(1,JV)-FY(I,JV)
+       TZ(1,JV)=TZ(1,JV)-FZ(I,JV)
+  !
+  END DO
+  !
+  ENDIF
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK
+  !
+     IF(UEXT(I)>=0.) THEN
+  !
+       F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) )
+       FX(I,JV)=ALFQ(I)*TX(I,JV)
+       FY(I,JV)=ALF (I)*TY(I,JV)
+       FZ(I,JV)=ALF (I)*TZ(I,JV)
+  !
+       T0(I,JV)=T0(I,JV)-F0(I,JV)
+       TX(I,JV)=ALF1Q(I)*TX(I,JV)
+       TY(I,JV)=TY(I,JV)-FY(I,JV)
+       TZ(I,JV)=TZ(I,JV)-FZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO I=1,LONK
+     IF(UEXT(I)<0.) THEN
+       TM(I)=TM(I)+FM(I)
+       ALF(I)=FM(I)/TM(I)
+     ENDIF
+  END DO
+  !
+  DO I=1,LONK-1
+     IF(UEXT(I)>=0.) THEN
+       TM(I+1)=TM(I+1)+FM(I)
+       ALF(I)=FM(I)/TM(I+1)
+     ENDIF
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)>=0.) THEN
+    TM(1)=TM(1)+FM(I)
+    ALF(I)=FM(I)/TM(1)
+  ENDIF
+  !
+  DO I=1,LONK
+     ALF1(I)=1.-ALF(I)
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK
+  !
+     IF(UEXT(I)<0.) THEN
+  !
+       TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+       T0(I,JV)=T0(I,JV)+F0(I,JV)
+       TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+       TY(I,JV)=TY(I,JV)+FY(I,JV)
+       TZ(I,JV)=TZ(I,JV)+FZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK-1
+  !
+     IF(UEXT(I)>=0.) THEN
+  !
+       TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+       T0(I+1,JV)=T0(I+1,JV)+F0(I,JV)
+       TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM
+       TY(I+1,JV)=TY(I+1,JV)+FY(I,JV)
+       TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)>=0.) THEN
+    DO JV=1,NTRA
+       TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+       T0(1,JV)=T0(1,JV)+F0(I,JV)
+       TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+       TY(1,JV)=TY(1,JV)+FY(I,JV)
+       TZ(1,JV)=TZ(1,JV)+FZ(I,JV)
+  END DO
+  ENDIF
+  !
+  !  retour aux mailles d'origine (passage des Tij aux Sij)
+  !
+  IF(NUMK>1) THEN
+  !
+  DO I2=1,NUMK
+  !
+     DO I=1,LONK
+  !
+        I3=I2+(I-1)*NUMK
+        SM(I3,K,L)=SMNEW(I3)
+        ALF(I)=SMNEW(I3)/TM(I)
+        TM(I)=TM(I)-SMNEW(I3)
+  !
+        ALFQ(I)=ALF(I)*ALF(I)
+        ALF1(I)=1.-ALF(I)
+        ALF1Q(I)=ALF1(I)*ALF1(I)
+  !
+  END DO
+  END DO
+  !
+     DO  JV=1,NTRA
+     DO  I=1,LONK
+  !
+        I3=I2+(I-1)*NUMK
+        S0(I3,K,L,JV)=ALF (I) &
+              * (T0(I,JV)-ALF1(I)*TX(I,JV))
+        sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV)
+        sy(I3,K,L,JV)=ALF (I)*TY(I,JV)
+        sz(I3,K,L,JV)=ALF (I)*TZ(I,JV)
+  !
+  !   reajusts moments remaining in the box
+  !
+        T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+        TX(I,JV)=ALF1Q(I)*TX(I,JV)
+        TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV)
+        TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV)
+      ENDDO
+      ENDDO
+  !
+  !
+  ELSE
+  !
+  DO I=1,LON
+     SM(I,K,L)=TM(I)
+  END DO
+  DO JV=1,NTRA
+  DO I=1,LON
+     S0(I,K,L,JV)=T0(I,JV)
+     sx(I,K,L,JV)=TX(I,JV)
+     sy(I,K,L,JV)=TY(I,JV)
+     sz(I,K,L,JV)=TZ(I,JV)
+  END DO
+  END DO
+  !
+  ENDIF
+  !
+  END DO
+  END DO
+  !
+  ! ----------- AA Test en fin de ADVX ------ Controle des S*
+  ! OK
+  !  DO 9998 l = 1, llm
+  !  DO 9998 j = 1, jjp1
+  !  DO 9998 i = 1, iip1
+  !     IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
+  !        PRINT*, '-------------------'
+  !        PRINT*, 'En fin de ADVX'
+  !        PRINT*,'SM(',i,j,l,')=',SM(i,j,l)
+  !        PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+  !        PRINT*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+  !        PRINT*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+  !        PRINT*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+  !        WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1'
+  !c            STOP
+  !     ENDIF
+  ! 9998 CONTINUE
+  !
+  ! ---------- bouclage cyclique
+  DO itrac=1,ntra
+  DO l = 1,llm
+    DO j = lati,latf
+       SM(iip1,j,l) = SM(1,j,l)
+       S0(iip1,j,l,itrac) = S0(1,j,l,itrac)
+       sx(iip1,j,l,itrac) = sx(1,j,l,itrac)
+       sy(iip1,j,l,itrac) = sy(1,j,l,itrac)
+       sz(iip1,j,l,itrac) = sz(1,j,l,itrac)
+    END DO
+  END DO
+  ENDDO
+
+  ! ----------- qqtite totale de traceur dans tte l'atmosphere
+  DO l = 1, llm
+    DO j = 1, jjp1
+      DO i = 1, iim
+  !IM 240405          sqf = sqf + S0(i,j,l,9)
+         sqf = sqf + S0(i,j,l,ntra)
+      END DO
+    END DO
+  END DO
+  !
+  PRINT*,'------ DIAG DANS ADVX - SORTIE -----'
+  PRINT*,'sqf=',sqf
+  !-------------
+
+  RETURN
+END SUBROUTINE advx
+!_________________________________________________________________
+!_________________________________________________________________
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advxp.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advxp.F	(revision 5104)
+++ 	(revision )
@@ -1,652 +1,0 @@
-
-! $Header$
-
-       SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ
-     .                ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
-       IMPLICIT NONE
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                 C
-C  second-order moments (SOM) advection of tracer in X direction  C
-C                                                                 C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C  parametres principaux du modele
-C
-      include "dimensions.h"
-      include "paramet.h"
-
-       INTEGER ntra
-c      PARAMETER (ntra = 1)
-C
-C  definition de la grille du modele
-C
-      REAL dtx
-      REAL pbaru ( iip1,jjp1,llm )
-C
-C  moments: SM  total mass in each grid box
-C           S0  mass of tracer in each grid box
-C           Si  1rst order moment in i direction
-C           Sij 2nd  order moment in i and j directions
-C
-      REAL SM(iip1,jjp1,llm)
-     +    ,S0(iip1,jjp1,llm,ntra)
-      REAL SSX(iip1,jjp1,llm,ntra)
-     +    ,SY(iip1,jjp1,llm,ntra)
-     +    ,SZ(iip1,jjp1,llm,ntra)
-      REAL SSXX(iip1,jjp1,llm,ntra)
-     +    ,SSXY(iip1,jjp1,llm,ntra)
-     +    ,SSXZ(iip1,jjp1,llm,ntra)
-     +    ,SYY(iip1,jjp1,llm,ntra)
-     +    ,SYZ(iip1,jjp1,llm,ntra)
-     +    ,SZZ(iip1,jjp1,llm,ntra)
-
-C  Local :
-C  -------
-
-C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
-C  mass fluxes in kg
-C  declaration :
-
-       REAL UGRI(iip1,jjp1,llm)
-
-C  Rem : VGRI et WGRI ne sont pas utilises dans
-C  cette SUBROUTINE ( advection en x uniquement )
-C
-C
-C  Tij are the moments for the current latitude and level
-C
-      REAL TM (iim)
-      REAL T0 (iim,NTRA),TX (iim,NTRA)
-      REAL TY (iim,NTRA),TZ (iim,NTRA)
-      REAL TXX(iim,NTRA),TXY(iim,NTRA)
-      REAL TXZ(iim,NTRA),TYY(iim,NTRA)
-      REAL TYZ(iim,NTRA),TZZ(iim,NTRA)
-C
-C  the moments F are similarly defined and used as temporary
-C  storage for portions of the grid boxes in transit
-C
-      REAL FM (iim)
-      REAL F0 (iim,NTRA),FX (iim,NTRA)
-      REAL FY (iim,NTRA),FZ (iim,NTRA)
-      REAL FXX(iim,NTRA),FXY(iim,NTRA)
-      REAL FXZ(iim,NTRA),FYY(iim,NTRA)
-      REAL FYZ(iim,NTRA),FZZ(iim,NTRA)
-C
-C  work arrays
-C
-      REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
-      REAL ALF2(iim),ALF3(iim),ALF4(iim)
-C
-      REAL SMNEW(iim),UEXT(iim)
-      REAL sqi,sqf
-      REAL TEMPTM
-      REAL SLPMAX
-      REAL S1MAX,S1NEW,S2NEW
-
-      LOGICAL LIMIT
-      INTEGER NUM(jjp1),LONK,NUMK
-      INTEGER lon,lati,latf,niv
-      INTEGER i,i2,i3,j,jv,l,k,iter
-
-      lon = iim
-      lati=2
-      latf = jjm
-      niv = llm
-
-C *** Test de passage d'arguments ******
-
-c      DO 399 l = 1, llm
-c       DO 399 j = 1, jjp1
-c        DO 399 i = 1, iip1
-c         IF (S0(i,j,l,ntra) .lt. 0. ) THEN
-c         PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
-c             PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
-c         PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
-c         PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
-c         PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
-cc            STOP
-c         ENDIF
-c  399 CONTINUE
-
-C *** Test : diagnostique de la qtite totale de traceur
-C            dans l'atmosphere avant l'advection
-c
-      sqi =0.
-      sqf =0.
-c
-      DO l = 1, llm
-      DO j = 1, jjp1
-      DO i = 1, iim
-         sqi = sqi + S0(i,j,l,ntra)
-      END DO
-      END DO
-      END DO
-      PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
-      PRINT*,'sqi=',sqi
-c test
-c  -------------------------------------
-        DO j =1,jjp1
-         NUM(j) =1 
-      END DO
-c       DO l=1,llm
-c      NUM(2,l)=6
-c      NUM(3,l)=6
-c      NUM(jjm-1,l)=6  
-c      NUM(jjm,l)=6
-c      ENDDO
-c        DO j=2,6
-c       NUM(j)=12
-c       ENDDO
-c       DO j=jjm-5,jjm-1 
-c       NUM(j)=12
-c       ENDDO
-
-C  Interface : adaptation nouveau modele
-C  -------------------------------------
-C
-C  ---------------------------------------------------------
-C  Conversion des flux de masses en kg/s
-C  pbaru est en N/s d'ou :
-C  ugri est en kg/s
-
-       DO l = 1,llm
-       DO j = 1,jjp1
-       DO i = 1,iip1
-       ugri (i,j,llm+1-l) =pbaru (i,j,l) 
-      END DO
-      END DO
-      END DO
-
-C  ---------------------------------------------------------
-C  start here
-C
-C  boucle principale sur les niveaux et les latitudes
-C     
-      DO L=1,NIV
-      DO K=lati,latf
-
-C
-C  initialisation
-C
-C  program assumes periodic boundaries in X
-C
-      DO I=2,LON
-         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
-      END DO
-      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
-C
-C  modifications for extended polar zones
-C
-      NUMK=NUM(K)
-      LONK=LON/NUMK
-C
-      IF(NUMK>1) THEN
-C
-      DO I=1,LON
-         TM(I)=0.
-      END DO
-      DO JV=1,NTRA
-      DO I=1,LON
-         T0 (I,JV)=0.
-         TX (I,JV)=0.
-         TY (I,JV)=0.
-         TZ (I,JV)=0.
-         TXX(I,JV)=0.
-         TXY(I,JV)=0.
-         TXZ(I,JV)=0.
-         TYY(I,JV)=0.
-         TYZ(I,JV)=0.
-         TZZ(I,JV)=0.
-      END DO
-      END DO
-C
-      DO I2=1,NUMK
-C
-         DO I=1,LONK
-            I3=(I-1)*NUMK+I2
-            TM(I)=TM(I)+SM(I3,K,L)
-            ALF(I)=SM(I3,K,L)/TM(I)
-            ALF1(I)=1.-ALF(I)
-            ALFQ(I)=ALF(I)*ALF(I)
-            ALF1Q(I)=ALF1(I)*ALF1(I)
-            ALF2(I)=ALF1(I)-ALF(I)
-            ALF3(I)=ALF(I)*ALF1(I)
-      END DO
-C
-         DO JV=1,NTRA
-         DO I=1,LONK
-            I3=(I-1)*NUMK+I2
-            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
-            T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
-            TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV)
-     +        +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
-            TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
-            TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV)
-     +           +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
-            TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV)
-     +           +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
-            TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
-            TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
-            TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
-            TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
-            TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
-      END DO
-      END DO
-C
-      END DO
-C
-      ELSE
-C
-      DO I=1,LON
-         TM(I)=SM(I,K,L)
-      END DO
-      DO JV=1,NTRA
-      DO I=1,LON
-         T0 (I,JV)=S0 (I,K,L,JV)
-         TX (I,JV)=SSX (I,K,L,JV)
-         TY (I,JV)=SY (I,K,L,JV)
-         TZ (I,JV)=SZ (I,K,L,JV)
-         TXX(I,JV)=SSXX(I,K,L,JV)
-         TXY(I,JV)=SSXY(I,K,L,JV)
-         TXZ(I,JV)=SSXZ(I,K,L,JV)
-         TYY(I,JV)=SYY(I,K,L,JV)
-         TYZ(I,JV)=SYZ(I,K,L,JV)
-         TZZ(I,JV)=SZZ(I,K,L,JV)
-      END DO
-      END DO
-C
-      ENDIF
-C
-      DO I=1,LONK
-         UEXT(I)=UGRI(I*NUMK,K,L)
-      END DO
-C
-C  place limits on appropriate moments before transport
-C      (if flux-limiting is to be applied)
-C
-      IF(.NOT.LIMIT) GO TO 13
-C
-      DO JV=1,NTRA
-      DO I=1,LONK
-        IF(T0(I,JV)>0.) THEN
-          SLPMAX=T0(I,JV)
-          S1MAX=1.5*SLPMAX
-          S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
-          S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
-     +                 AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
-          TX (I,JV)=S1NEW
-          TXX(I,JV)=S2NEW
-          TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
-          TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
-        ELSE
-          TX (I,JV)=0.
-          TXX(I,JV)=0.
-          TXY(I,JV)=0.
-          TXZ(I,JV)=0.
-        ENDIF
-      END DO
-      END DO
-C
- 13   CONTINUE
-C
-C  calculate flux and moments between adjacent boxes
-C  1- create temporary moments/masses for partial boxes in transit
-C  2- reajusts moments remaining in the box
-C
-C  flux from IP to I if U(I).lt.0
-C
-      DO I=1,LONK-1
-         IF(UEXT(I)<0.) THEN
-           FM(I)=-UEXT(I)*DTX
-           ALF(I)=FM(I)/TM(I+1)
-           TM(I+1)=TM(I+1)-FM(I)
-         ENDIF
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)<0.) THEN
-        FM(I)=-UEXT(I)*DTX
-        ALF(I)=FM(I)/TM(1)
-        TM(1)=TM(1)-FM(I)
-      ENDIF
-C
-C  flux from I to IP if U(I).gt.0
-C
-      DO I=1,LONK
-         IF(UEXT(I)>=0.) THEN
-           FM(I)=UEXT(I)*DTX
-           ALF(I)=FM(I)/TM(I)
-           TM(I)=TM(I)-FM(I)
-         ENDIF
-      END DO
-C
-      DO I=1,LONK
-         ALFQ(I)=ALF(I)*ALF(I)
-         ALF1(I)=1.-ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-         ALF2(I)=ALF1(I)-ALF(I)
-         ALF3(I)=ALF(I)*ALFQ(I)
-         ALF4(I)=ALF1(I)*ALF1Q(I)
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LONK-1
-C
-         IF(UEXT(I)<0.) THEN
-C
-           F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
-     +             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
-           FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
-           FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
-           FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
-           FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
-           FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
-           FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
-           FYY(I,JV)=ALF (I)*TYY(I+1,JV)
-           FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
-           FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
-C
-           T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
-           TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
-           TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
-           TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
-           TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
-           TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
-           TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
-           TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
-           TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
-           TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)<0.) THEN
-C
-        DO JV=1,NTRA
-C
-           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
-     +             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
-           FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
-           FXX(I,JV)=ALF3(I)*TXX(1,JV)
-           FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
-           FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
-           FXY(I,JV)=ALFQ(I)*TXY(1,JV)
-           FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
-           FYY(I,JV)=ALF (I)*TYY(1,JV)
-           FYZ(I,JV)=ALF (I)*TYZ(1,JV)
-           FZZ(I,JV)=ALF (I)*TZZ(1,JV)
-C
-           T0 (1,JV)=T0(1,JV)-F0(I,JV)
-           TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
-           TXX(1,JV)=ALF4(I)*TXX(1,JV)
-           TY (1,JV)=TY (1,JV)-FY (I,JV)
-           TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
-           TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
-           TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
-           TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
-           TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
-           TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
-C
-      END DO
-C
-      ENDIF
-C
-      DO JV=1,NTRA
-      DO I=1,LONK
-C
-         IF(UEXT(I)>=0.) THEN
-C
-           F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
-     +             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
-           FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
-           FXX(I,JV)=ALF3(I)*TXX(I,JV)
-           FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
-           FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
-           FXY(I,JV)=ALFQ(I)*TXY(I,JV)
-           FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
-           FYY(I,JV)=ALF (I)*TYY(I,JV)
-           FYZ(I,JV)=ALF (I)*TYZ(I,JV)
-           FZZ(I,JV)=ALF (I)*TZZ(I,JV)
-C
-           T0 (I,JV)=T0(I,JV)-F0(I,JV)
-           TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
-           TXX(I,JV)=ALF4(I)*TXX(I,JV)
-           TY (I,JV)=TY (I,JV)-FY (I,JV)
-           TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
-           TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
-           TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
-           TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
-           TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
-           TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO I=1,LONK
-         IF(UEXT(I)<0.) THEN
-           TM(I)=TM(I)+FM(I)
-           ALF(I)=FM(I)/TM(I)
-         ENDIF
-      END DO
-C
-      DO I=1,LONK-1
-         IF(UEXT(I)>=0.) THEN
-           TM(I+1)=TM(I+1)+FM(I)
-           ALF(I)=FM(I)/TM(I+1)
-         ENDIF
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)>=0.) THEN
-        TM(1)=TM(1)+FM(I)
-        ALF(I)=FM(I)/TM(1)
-      ENDIF
-C
-      DO I=1,LONK
-         ALF1(I)=1.-ALF(I)
-         ALFQ(I)=ALF(I)*ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-         ALF2(I)=ALF1(I)-ALF(I)
-         ALF3(I)=ALF(I)*ALF1(I)
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LONK
-C
-         IF(UEXT(I)<0.) THEN
-C
-           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
-           T0 (I,JV)=T0(I,JV)+F0(I,JV)
-           TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV)
-     +          +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
-           TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
-           TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV)
-     +          +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
-           TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV)
-     +          +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
-           TY (I,JV)=TY (I,JV)+FY (I,JV)
-           TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
-           TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
-           TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
-           TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LONK-1
-C
-         IF(UEXT(I)>=0.) THEN
-C
-           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
-           T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
-           TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV)
-     +           +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
-           TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
-           TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV)
-     +            +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
-           TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV)
-     +            +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
-           TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
-           TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
-           TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
-           TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
-           TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      I=LONK
-      IF(UEXT(I)>=0.) THEN
-        DO JV=1,NTRA
-           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
-           T0 (1,JV)=T0(1,JV)+F0(I,JV)
-           TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV)
-     +         +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
-           TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
-           TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV)
-     +          +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
-           TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV)
-     +          +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
-           TY (1,JV)=TY (1,JV)+FY (I,JV)
-           TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
-           TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
-           TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
-           TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
-      END DO
-      ENDIF
-C
-C  retour aux mailles d'origine (passage des Tij aux Sij)
-C
-      IF(NUMK>1) THEN
-C
-      DO I2=1,NUMK
-C
-         DO I=1,LONK
-C
-            I3=I2+(I-1)*NUMK
-            SM(I3,K,L)=SMNEW(I3)
-            ALF(I)=SMNEW(I3)/TM(I)
-            TM(I)=TM(I)-SMNEW(I3)
-C
-            ALFQ(I)=ALF(I)*ALF(I)
-            ALF1(I)=1.-ALF(I)
-            ALF1Q(I)=ALF1(I)*ALF1(I)
-            ALF2(I)=ALF1(I)-ALF(I)
-            ALF3(I)=ALF(I)*ALFQ(I)
-            ALF4(I)=ALF1(I)*ALF1Q(I)
-C
-      END DO
-C
-         DO JV=1,NTRA
-         DO I=1,LONK
-C
-            I3=I2+(I-1)*NUMK
-            S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
-     +              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
-            SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
-            SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
-            SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
-            SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
-            SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
-            SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
-            SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
-            SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
-            SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
-C
-C   reajusts moments remaining in the box
-C
-            T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
-            TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
-            TXX(I,JV)=ALF4 (I)*TXX(I,JV)
-            TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
-            TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
-            TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
-            TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
-            TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
-            TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
-            TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
-C
-      END DO
-      END DO
-C
-      END DO
-C
-      ELSE
-C
-      DO I=1,LON
-         SM(I,K,L)=TM(I)
-      END DO
-      DO JV=1,NTRA
-      DO I=1,LON
-         S0 (I,K,L,JV)=T0 (I,JV)
-         SSX (I,K,L,JV)=TX (I,JV)
-         SY (I,K,L,JV)=TY (I,JV)
-         SZ (I,K,L,JV)=TZ (I,JV)
-         SSXX(I,K,L,JV)=TXX(I,JV)
-         SSXY(I,K,L,JV)=TXY(I,JV)
-         SSXZ(I,K,L,JV)=TXZ(I,JV)
-         SYY(I,K,L,JV)=TYY(I,JV)
-         SYZ(I,K,L,JV)=TYZ(I,JV)
-         SZZ(I,K,L,JV)=TZZ(I,JV)
-      END DO
-      END DO
-C
-      ENDIF
-C
-      END DO
-      END DO
-C
-C ----------- AA Test en fin de ADVX ------ Controle des S*
-
-c      DO 9999 l = 1, llm
-c      DO 9999 j = 1, jjp1
-c      DO 9999 i = 1, iip1
-c           IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
-c           PRINT*, '-------------------'
-c                PRINT*, 'En fin de ADVXP'
-c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
-c                PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
-c           PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
-c               PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
-c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
-c            STOP
-c           ENDIF
-c 9999 CONTINUE
-c ---------- bouclage cyclique
-
-      DO l = 1,llm
-      DO j = 1,jjp1
-         SM(iip1,j,l) = SM(1,j,l)
-         S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
-              SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
-             SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
-             SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
-      END DO
-      END DO
-
-C ----------- qqtite totale de traceur dans tte l'atmosphere
-      DO l = 1, llm
-      DO j = 1, jjp1
-      DO i = 1, iim
-        sqf = sqf + S0(i,j,l,ntra)
-      END DO
-      END DO
-      END DO
-
-      PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
-      PRINT*,'sqf=',sqf
-c-------------------------------------------------------------
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advxp.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advxp.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advxp.f90	(revision 5105)
@@ -0,0 +1,652 @@
+
+! $Header$
+
+ SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ &
+         ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
+   IMPLICIT NONE
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                 C
+  !  second-order moments (SOM) advection of tracer in X direction  C
+  !                                                                 C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !
+  !  parametres principaux du modele
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+   INTEGER :: ntra
+   ! PARAMETER (ntra = 1)
+  !
+  !  definition de la grille du modele
+  !
+  REAL :: dtx
+  REAL :: pbaru ( iip1,jjp1,llm )
+  !
+  !  moments: SM  total mass in each grid box
+  !       S0  mass of tracer in each grid box
+  !       Si  1rst order moment in i direction
+  !       Sij 2nd  order moment in i and j directions
+  !
+  REAL :: SM(iip1,jjp1,llm) &
+        ,S0(iip1,jjp1,llm,ntra)
+  REAL :: SSX(iip1,jjp1,llm,ntra) &
+        ,SY(iip1,jjp1,llm,ntra) &
+        ,SZ(iip1,jjp1,llm,ntra)
+  REAL :: SSXX(iip1,jjp1,llm,ntra) &
+        ,SSXY(iip1,jjp1,llm,ntra) &
+        ,SSXZ(iip1,jjp1,llm,ntra) &
+        ,SYY(iip1,jjp1,llm,ntra) &
+        ,SYZ(iip1,jjp1,llm,ntra) &
+        ,SZZ(iip1,jjp1,llm,ntra)
+
+  !  Local :
+  !  -------
+
+  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+  !  mass fluxes in kg
+  !  declaration :
+
+   REAL :: UGRI(iip1,jjp1,llm)
+
+  !  Rem : VGRI et WGRI ne sont pas utilises dans
+  !  cette SUBROUTINE ( advection en x uniquement )
+  !
+  !
+  !  Tij are the moments for the current latitude and level
+  !
+  REAL :: TM (iim)
+  REAL :: T0 (iim,NTRA),TX (iim,NTRA)
+  REAL :: TY (iim,NTRA),TZ (iim,NTRA)
+  REAL :: TXX(iim,NTRA),TXY(iim,NTRA)
+  REAL :: TXZ(iim,NTRA),TYY(iim,NTRA)
+  REAL :: TYZ(iim,NTRA),TZZ(iim,NTRA)
+  !
+  !  the moments F are similarly defined and used as temporary
+  !  storage for portions of the grid boxes in transit
+  !
+  REAL :: FM (iim)
+  REAL :: F0 (iim,NTRA),FX (iim,NTRA)
+  REAL :: FY (iim,NTRA),FZ (iim,NTRA)
+  REAL :: FXX(iim,NTRA),FXY(iim,NTRA)
+  REAL :: FXZ(iim,NTRA),FYY(iim,NTRA)
+  REAL :: FYZ(iim,NTRA),FZZ(iim,NTRA)
+  !
+  !  work arrays
+  !
+  REAL :: ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+  REAL :: ALF2(iim),ALF3(iim),ALF4(iim)
+  !
+  REAL :: SMNEW(iim),UEXT(iim)
+  REAL :: sqi,sqf
+  REAL :: TEMPTM
+  REAL :: SLPMAX
+  REAL :: S1MAX,S1NEW,S2NEW
+
+  LOGICAL :: LIMIT
+  INTEGER :: NUM(jjp1),LONK,NUMK
+  INTEGER :: lon,lati,latf,niv
+  INTEGER :: i,i2,i3,j,jv,l,k,iter
+
+  lon = iim
+  lati=2
+  latf = jjm
+  niv = llm
+
+  ! *** Test de passage d'arguments ******
+
+   ! DO 399 l = 1, llm
+   !  DO 399 j = 1, jjp1
+   !   DO 399 i = 1, iip1
+   !    IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+   !    PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+   !        PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+   !    PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+   !    PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+   !    PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
+  !c            STOP
+   !    ENDIF
+  !  399 CONTINUE
+
+  ! *** Test : diagnostique de la qtite totale de traceur
+   !       dans l'atmosphere avant l'advection
+  !
+  sqi =0.
+  sqf =0.
+  !
+  DO l = 1, llm
+  DO j = 1, jjp1
+  DO i = 1, iim
+     sqi = sqi + S0(i,j,l,ntra)
+  END DO
+  END DO
+  END DO
+  PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
+  PRINT*,'sqi=',sqi
+  ! test
+  !  -------------------------------------
+    DO j =1,jjp1
+     NUM(j) =1
+  END DO
+    ! DO l=1,llm
+   ! NUM(2,l)=6
+   ! NUM(3,l)=6
+   ! NUM(jjm-1,l)=6
+   ! NUM(jjm,l)=6
+   ! ENDDO
+   !   DO j=2,6
+   !  NUM(j)=12
+   !  ENDDO
+   !  DO j=jjm-5,jjm-1
+   !  NUM(j)=12
+   !  ENDDO
+
+  !  Interface : adaptation nouveau modele
+  !  -------------------------------------
+  !
+  !  ---------------------------------------------------------
+  !  Conversion des flux de masses en kg/s
+  !  pbaru est en N/s d'ou :
+  !  ugri est en kg/s
+
+   DO l = 1,llm
+   DO j = 1,jjp1
+   DO i = 1,iip1
+   ugri (i,j,llm+1-l) =pbaru (i,j,l)
+  END DO
+  END DO
+  END DO
+
+  !  ---------------------------------------------------------
+  !  start here
+  !
+  !  boucle principale sur les niveaux et les latitudes
+  !
+  DO L=1,NIV
+  DO K=lati,latf
+
+  !
+  !  initialisation
+  !
+  !  program assumes periodic boundaries in X
+  !
+  DO I=2,LON
+     SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+  END DO
+  SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+  !
+  !  modifications for extended polar zones
+  !
+  NUMK=NUM(K)
+  LONK=LON/NUMK
+  !
+  IF(NUMK>1) THEN
+  !
+  DO I=1,LON
+     TM(I)=0.
+  END DO
+  DO JV=1,NTRA
+  DO I=1,LON
+     T0 (I,JV)=0.
+     TX (I,JV)=0.
+     TY (I,JV)=0.
+     TZ (I,JV)=0.
+     TXX(I,JV)=0.
+     TXY(I,JV)=0.
+     TXZ(I,JV)=0.
+     TYY(I,JV)=0.
+     TYZ(I,JV)=0.
+     TZZ(I,JV)=0.
+  END DO
+  END DO
+  !
+  DO I2=1,NUMK
+  !
+     DO I=1,LONK
+        I3=(I-1)*NUMK+I2
+        TM(I)=TM(I)+SM(I3,K,L)
+        ALF(I)=SM(I3,K,L)/TM(I)
+        ALF1(I)=1.-ALF(I)
+        ALFQ(I)=ALF(I)*ALF(I)
+        ALF1Q(I)=ALF1(I)*ALF1(I)
+        ALF2(I)=ALF1(I)-ALF(I)
+        ALF3(I)=ALF(I)*ALF1(I)
+  END DO
+  !
+     DO JV=1,NTRA
+     DO I=1,LONK
+        I3=(I-1)*NUMK+I2
+        TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
+        T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+        TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) &
+              +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+        TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+        TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) &
+              +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
+        TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) &
+              +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
+        TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
+        TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
+        TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
+        TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
+        TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
+  END DO
+  END DO
+  !
+  END DO
+  !
+  ELSE
+  !
+  DO I=1,LON
+     TM(I)=SM(I,K,L)
+  END DO
+  DO JV=1,NTRA
+  DO I=1,LON
+     T0 (I,JV)=S0 (I,K,L,JV)
+     TX (I,JV)=SSX (I,K,L,JV)
+     TY (I,JV)=SY (I,K,L,JV)
+     TZ (I,JV)=SZ (I,K,L,JV)
+     TXX(I,JV)=SSXX(I,K,L,JV)
+     TXY(I,JV)=SSXY(I,K,L,JV)
+     TXZ(I,JV)=SSXZ(I,K,L,JV)
+     TYY(I,JV)=SYY(I,K,L,JV)
+     TYZ(I,JV)=SYZ(I,K,L,JV)
+     TZZ(I,JV)=SZZ(I,K,L,JV)
+  END DO
+  END DO
+  !
+  ENDIF
+  !
+  DO I=1,LONK
+     UEXT(I)=UGRI(I*NUMK,K,L)
+  END DO
+  !
+  !  place limits on appropriate moments before transport
+  !  (if flux-limiting is to be applied)
+  !
+  IF(.NOT.LIMIT) GO TO 13
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK
+    IF(T0(I,JV)>0.) THEN
+      SLPMAX=T0(I,JV)
+      S1MAX=1.5*SLPMAX
+      S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
+      S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , &
+            AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
+      TX (I,JV)=S1NEW
+      TXX(I,JV)=S2NEW
+      TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
+      TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
+    ELSE
+      TX (I,JV)=0.
+      TXX(I,JV)=0.
+      TXY(I,JV)=0.
+      TXZ(I,JV)=0.
+    ENDIF
+  END DO
+  END DO
+  !
+ 13   CONTINUE
+  !
+  !  calculate flux and moments between adjacent boxes
+  !  1- create temporary moments/masses for partial boxes in transit
+  !  2- reajusts moments remaining in the box
+  !
+  !  flux from IP to I if U(I).lt.0
+  !
+  DO I=1,LONK-1
+     IF(UEXT(I)<0.) THEN
+       FM(I)=-UEXT(I)*DTX
+       ALF(I)=FM(I)/TM(I+1)
+       TM(I+1)=TM(I+1)-FM(I)
+     ENDIF
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)<0.) THEN
+    FM(I)=-UEXT(I)*DTX
+    ALF(I)=FM(I)/TM(1)
+    TM(1)=TM(1)-FM(I)
+  ENDIF
+  !
+  !  flux from I to IP if U(I).gt.0
+  !
+  DO I=1,LONK
+     IF(UEXT(I)>=0.) THEN
+       FM(I)=UEXT(I)*DTX
+       ALF(I)=FM(I)/TM(I)
+       TM(I)=TM(I)-FM(I)
+     ENDIF
+  END DO
+  !
+  DO I=1,LONK
+     ALFQ(I)=ALF(I)*ALF(I)
+     ALF1(I)=1.-ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+     ALF2(I)=ALF1(I)-ALF(I)
+     ALF3(I)=ALF(I)*ALFQ(I)
+     ALF4(I)=ALF1(I)*ALF1Q(I)
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK-1
+  !
+     IF(UEXT(I)<0.) THEN
+  !
+       F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* &
+             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
+       FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
+       FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
+       FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
+       FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
+       FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
+       FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
+       FYY(I,JV)=ALF (I)*TYY(I+1,JV)
+       FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
+       FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
+  !
+       T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
+       TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
+       TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
+       TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
+       TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
+       TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
+       TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
+       TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
+       TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
+       TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)<0.) THEN
+  !
+    DO JV=1,NTRA
+  !
+       F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* &
+             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
+       FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
+       FXX(I,JV)=ALF3(I)*TXX(1,JV)
+       FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
+       FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
+       FXY(I,JV)=ALFQ(I)*TXY(1,JV)
+       FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
+       FYY(I,JV)=ALF (I)*TYY(1,JV)
+       FYZ(I,JV)=ALF (I)*TYZ(1,JV)
+       FZZ(I,JV)=ALF (I)*TZZ(1,JV)
+  !
+       T0 (1,JV)=T0(1,JV)-F0(I,JV)
+       TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
+       TXX(1,JV)=ALF4(I)*TXX(1,JV)
+       TY (1,JV)=TY (1,JV)-FY (I,JV)
+       TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
+       TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
+       TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
+       TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
+       TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
+       TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
+  !
+  END DO
+  !
+  ENDIF
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK
+  !
+     IF(UEXT(I)>=0.) THEN
+  !
+       F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* &
+             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
+       FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
+       FXX(I,JV)=ALF3(I)*TXX(I,JV)
+       FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
+       FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
+       FXY(I,JV)=ALFQ(I)*TXY(I,JV)
+       FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
+       FYY(I,JV)=ALF (I)*TYY(I,JV)
+       FYZ(I,JV)=ALF (I)*TYZ(I,JV)
+       FZZ(I,JV)=ALF (I)*TZZ(I,JV)
+  !
+       T0 (I,JV)=T0(I,JV)-F0(I,JV)
+       TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
+       TXX(I,JV)=ALF4(I)*TXX(I,JV)
+       TY (I,JV)=TY (I,JV)-FY (I,JV)
+       TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
+       TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
+       TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
+       TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
+       TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+       TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO I=1,LONK
+     IF(UEXT(I)<0.) THEN
+       TM(I)=TM(I)+FM(I)
+       ALF(I)=FM(I)/TM(I)
+     ENDIF
+  END DO
+  !
+  DO I=1,LONK-1
+     IF(UEXT(I)>=0.) THEN
+       TM(I+1)=TM(I+1)+FM(I)
+       ALF(I)=FM(I)/TM(I+1)
+     ENDIF
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)>=0.) THEN
+    TM(1)=TM(1)+FM(I)
+    ALF(I)=FM(I)/TM(1)
+  ENDIF
+  !
+  DO I=1,LONK
+     ALF1(I)=1.-ALF(I)
+     ALFQ(I)=ALF(I)*ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+     ALF2(I)=ALF1(I)-ALF(I)
+     ALF3(I)=ALF(I)*ALF1(I)
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK
+  !
+     IF(UEXT(I)<0.) THEN
+  !
+       TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+       T0 (I,JV)=T0(I,JV)+F0(I,JV)
+       TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) &
+             +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+       TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
+       TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) &
+             +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
+       TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) &
+             +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
+       TY (I,JV)=TY (I,JV)+FY (I,JV)
+       TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
+       TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
+       TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
+       TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LONK-1
+  !
+     IF(UEXT(I)>=0.) THEN
+  !
+       TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+       T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
+       TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) &
+             +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+       TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
+       TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV) &
+             +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
+       TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV) &
+             +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
+       TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
+       TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
+       TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
+       TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
+       TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  I=LONK
+  IF(UEXT(I)>=0.) THEN
+    DO JV=1,NTRA
+       TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+       T0 (1,JV)=T0(1,JV)+F0(I,JV)
+       TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) &
+             +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+       TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+       TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) &
+             +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
+       TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) &
+             +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
+       TY (1,JV)=TY (1,JV)+FY (I,JV)
+       TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
+       TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
+       TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
+       TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
+  END DO
+  ENDIF
+  !
+  !  retour aux mailles d'origine (passage des Tij aux Sij)
+  !
+  IF(NUMK>1) THEN
+  !
+  DO I2=1,NUMK
+  !
+     DO I=1,LONK
+  !
+        I3=I2+(I-1)*NUMK
+        SM(I3,K,L)=SMNEW(I3)
+        ALF(I)=SMNEW(I3)/TM(I)
+        TM(I)=TM(I)-SMNEW(I3)
+  !
+        ALFQ(I)=ALF(I)*ALF(I)
+        ALF1(I)=1.-ALF(I)
+        ALF1Q(I)=ALF1(I)*ALF1(I)
+        ALF2(I)=ALF1(I)-ALF(I)
+        ALF3(I)=ALF(I)*ALFQ(I)
+        ALF4(I)=ALF1(I)*ALF1Q(I)
+  !
+  END DO
+  !
+     DO JV=1,NTRA
+     DO I=1,LONK
+  !
+        I3=I2+(I-1)*NUMK
+        S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* &
+              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
+        SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
+        SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
+        SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
+        SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
+        SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
+        SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
+        SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
+        SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
+        SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
+  !
+  !   reajusts moments remaining in the box
+  !
+        T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+        TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
+        TXX(I,JV)=ALF4 (I)*TXX(I,JV)
+        TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
+        TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
+        TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
+        TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
+        TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
+        TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+        TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+  !
+  END DO
+  END DO
+  !
+  END DO
+  !
+  ELSE
+  !
+  DO I=1,LON
+     SM(I,K,L)=TM(I)
+  END DO
+  DO JV=1,NTRA
+  DO I=1,LON
+     S0 (I,K,L,JV)=T0 (I,JV)
+     SSX (I,K,L,JV)=TX (I,JV)
+     SY (I,K,L,JV)=TY (I,JV)
+     SZ (I,K,L,JV)=TZ (I,JV)
+     SSXX(I,K,L,JV)=TXX(I,JV)
+     SSXY(I,K,L,JV)=TXY(I,JV)
+     SSXZ(I,K,L,JV)=TXZ(I,JV)
+     SYY(I,K,L,JV)=TYY(I,JV)
+     SYZ(I,K,L,JV)=TYZ(I,JV)
+     SZZ(I,K,L,JV)=TZZ(I,JV)
+  END DO
+  END DO
+  !
+  ENDIF
+  !
+  END DO
+  END DO
+  !
+  ! ----------- AA Test en fin de ADVX ------ Controle des S*
+
+  !  DO 9999 l = 1, llm
+  !  DO 9999 j = 1, jjp1
+  !  DO 9999 i = 1, iip1
+  !       IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
+  !       PRINT*, '-------------------'
+  !            PRINT*, 'En fin de ADVXP'
+  !       PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+  !            PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+  !       PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+  !           PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+  !        WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
+  !        STOP
+  !       ENDIF
+  ! 9999 CONTINUE
+  ! ---------- bouclage cyclique
+
+  DO l = 1,llm
+  DO j = 1,jjp1
+     SM(iip1,j,l) = SM(1,j,l)
+     S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+          SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+         SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+         SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+  END DO
+  END DO
+
+  ! ----------- qqtite totale de traceur dans tte l'atmosphere
+  DO l = 1, llm
+  DO j = 1, jjp1
+  DO i = 1, iim
+    sqf = sqf + S0(i,j,l,ntra)
+  END DO
+  END DO
+  END DO
+
+  PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
+  PRINT*,'sqf=',sqf
+  !-------------------------------------------------------------
+  RETURN
+END SUBROUTINE ADVXP
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advy.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advy.F	(revision 5104)
+++ 	(revision )
@@ -1,423 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
-      IMPLICIT NONE
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                C
-C  first-order moments (SOM) advection of tracer in Y direction  C
-C                                                                C
-C  Source : Pascal Simon ( Meteo, CNRM )                         C
-C  Adaptation : A.A. (LGGE)                                      C
-C  Derniere Modif : 15/12/94 LAST
-C                                                                C
-C  sont les arguments d'entree pour le s-pg                      C
-C                                                                C
-C  argument de sortie du s-pg                                    C
-C                                                                C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C  Rem : Probleme aux poles il faut reecrire ce cas specifique
-C        Attention au sens de l'indexation 
-C
-C  parametres principaux du modele
-C
-C
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
- 
-C  Arguments :
-C  ----------
-C  dty : frequence fictive d'appel du transport
-C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
-
-      INTEGER lon,lat,niv
-      INTEGER i,j,jv,k,kp,l
-      INTEGER ntra
-      PARAMETER (ntra = 1)
-
-      REAL dty
-      REAL pbarv ( iip1,jjm, llm )
-
-C  moments: SM  total mass in each grid box
-C           S0  mass of tracer in each grid box
-C           Si  1rst order moment in i direction
-C
-      REAL SM(iip1,jjp1,llm)
-     +    ,S0(iip1,jjp1,llm,ntra)
-      REAL sx(iip1,jjp1,llm,ntra)
-     +    ,sy(iip1,jjp1,llm,ntra)
-     +    ,sz(iip1,jjp1,llm,ntra)
-
-
-C  Local :
-C  ------- 
-
-C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
-C  mass fluxes in kg
-C  declaration :
-
-      REAL VGRI(iip1,0:jjp1,llm)
-
-C  Rem : UGRI et WGRI ne sont pas utilises dans 
-C  cette SUBROUTINE ( advection en y uniquement )
-C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
-C
-C  the moments F are similarly defined and used as temporary
-C  storage for portions of the grid boxes in transit
-C
-      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
-      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
-      REAL FZ(iim,jjm,ntra)
-      REAL S00(ntra)
-      REAL SM0             ! Just temporal variable
-C
-C  work arrays
-C
-      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
-      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
-      REAL TEMPTM          ! Just temporal variable
-c
-C  Special pour poles 
-c
-      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
-      REAL sns0(ntra),snsz(ntra),snsm
-      REAL s1v(llm),slatv(llm)
-      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
-      REAL cx1(llm,ntra), cxLAT(llm,ntra)
-      REAL cy1(llm,ntra), cyLAT(llm,ntra)
-      REAL z1(iim), zcos(iim), zsin(iim)
-      real smpn,smps,s0pn,s0ps
-      REAL SSUM
-      EXTERNAL SSUM
-C
-      REAL sqi,sqf
-      LOGICAL LIMIT
-
-      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
-      lat = jjp1        ! a cause des dim. differentes entre les
-      niv=llm
-
-C
-C  the moments Fi are used as temporary storage for
-C  portions of the grid boxes in transit at the current level
-C
-C  work arrays
-C
-
-      DO l = 1,llm
-         DO j = 1,jjm
-            DO i = 1,iip1  
-            vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)  
-            enddo
-         enddo
-         do i=1,iip1
-             vgri(i,0,l) = 0.
-             vgri(i,jjp1,l) = 0.
-         enddo
-      enddo
-
-      DO L=1,NIV
-C
-C  place limits on appropriate moments before transport
-C      (if flux-limiting is to be applied)
-C
-      IF(.NOT.LIMIT) GO TO 11
-C
-      DO JV=1,NTRA
-      DO K=1,LAT
-      DO I=1,LON
-         sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
-     +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
-      END DO
-      END DO
-      END DO
-C
- 11   CONTINUE
-C
-C  le flux a travers le pole Nord est traite separement
-C
-      SM0=0.
-      DO JV=1,NTRA
-         S00(JV)=0.
-      END DO
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)<=0.) THEN
-           FM(I,0)=-VGRI(I,0,L)*DTY
-           ALF(I,0)=FM(I,0)/SM(I,1,L)
-           SM(I,1,L)=SM(I,1,L)-FM(I,0)
-           SM0=SM0+FM(I,0)
-         ENDIF
-C
-         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
-         ALF1(I,0)=1.-ALF(I,0)
-         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)<=0.) THEN
-C
-           F0(I,0,JV)=ALF(I,0)*
-     +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
-C
-           S00(JV)=S00(JV)+F0(I,0,JV)
-           S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
-           sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
-           sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
-           sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      DO I=1,LON
-         IF(VGRI(I,0,L)>0.) THEN
-           FM(I,0)=VGRI(I,0,L)*DTY
-           ALF(I,0)=FM(I,0)/SM0
-         ENDIF
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-         IF(VGRI(I,0,L)>0.) THEN
-           F0(I,0,JV)=ALF(I,0)*S00(JV)
-         ENDIF
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)>0.) THEN
-           SM(I,1,L)=SM(I,1,L)+FM(I,0)
-           ALF(I,0)=FM(I,0)/SM(I,1,L)
-         ENDIF
-C
-         ALF1(I,0)=1.-ALF(I,0)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)>0.) THEN
-C
-         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
-         S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
-         sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-C  calculate flux and moments between adjacent boxes
-C  1- create temporary moments/masses for partial boxes in transit
-C  2- reajusts moments remaining in the box
-C
-C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
-C
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-           FM(I,K)=-VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM(I,KP,L)
-           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
-         ELSE
-           FM(I,K)=VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-           SM(I,K,L)=SM(I,K,L)-FM(I,K)
-         ENDIF
-C
-         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
-         ALF1(I,K)=1.-ALF(I,K)
-         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
-C
-      END DO
-      END DO
-C
-      DO JV=1,NTRA
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-C
-           F0(I,K,JV)=ALF (I,K)*
-     +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
-           FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
-           FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
-           FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
-C
-           S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
-           sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
-           sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
-           sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
-C
-         ELSE
-C
-           F0(I,K,JV)=ALF (I,K)*
-     +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
-           FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
-           FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
-           FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
-C
-           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
-           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
-           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
-           sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-           SM(I,K,L)=SM(I,K,L)+FM(I,K)
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-         ELSE
-           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
-           ALF(I,K)=FM(I,K)/SM(I,KP,L)
-         ENDIF
-C
-         ALF1(I,K)=1.-ALF(I,K)
-C
-      END DO
-      END DO
-C
-      DO JV=1,NTRA
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-C
-         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
-         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
-         sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV)
-     +               +3.*TEMPTM
-         sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
-         sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
-C
-         ELSE
-C
-         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
-         S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
-         sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV)
-     +                +3.*TEMPTM
-         sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
-         sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-      END DO
-C
-C  traitement special pour le pole Sud (idem pole Nord)
-C
-      K=LAT
-C
-      SM0=0.
-      DO JV=1,NTRA
-         S00(JV)=0.
-      END DO
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)>=0.) THEN
-           FM(I,K)=VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-           SM(I,K,L)=SM(I,K,L)-FM(I,K)
-           SM0=SM0+FM(I,K)
-         ENDIF
-C
-         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
-         ALF1(I,K)=1.-ALF(I,K)
-         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)>=0.) THEN
-           F0 (I,K,JV)=ALF(I,K)*
-     +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
-           S00(JV)=S00(JV)+F0(I,K,JV)
-C
-           S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
-           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
-           sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
-           sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
-         ENDIF
-C
-      END DO
-      END DO
-C
-      DO I=1,LON
-         IF(VGRI(I,K,L)<0.) THEN
-           FM(I,K)=-VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM0
-         ENDIF
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-         IF(VGRI(I,K,L)<0.) THEN
-           F0(I,K,JV)=ALF(I,K)*S00(JV)
-         ENDIF
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-           SM(I,K,L)=SM(I,K,L)+FM(I,K)
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-         ENDIF
-C
-         ALF1(I,K)=1.-ALF(I,K)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-C
-         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
-         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
-         sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      END DO
-C
-      RETURN
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advy.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advy.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advy.f90	(revision 5105)
@@ -0,0 +1,423 @@
+
+! $Header$
+
+SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
+  IMPLICIT NONE
+
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                C
+  !  first-order moments (SOM) advection of tracer in Y direction  C
+  !                                                                C
+  !  Source : Pascal Simon ( Meteo, CNRM )                         C
+  !  Adaptation : A.A. (LGGE)                                      C
+  !  Derniere Modif : 15/12/94 LAST
+                                                             ! C
+  !  sont les arguments d'entree pour le s-pg                      C
+  !                                                                C
+  !  argument de sortie du s-pg                                    C
+  !                                                                C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !
+  !  Rem : Probleme aux poles il faut reecrire ce cas specifique
+  !    Attention au sens de l'indexation
+  !
+  !  parametres principaux du modele
+  !
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  !  Arguments :
+  !  ----------
+  !  dty : frequence fictive d'appel du transport
+  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+  INTEGER :: lon,lat,niv
+  INTEGER :: i,j,jv,k,kp,l
+  INTEGER :: ntra
+  PARAMETER (ntra = 1)
+
+  REAL :: dty
+  REAL :: pbarv ( iip1,jjm, llm )
+
+  !  moments: SM  total mass in each grid box
+        ! S0  mass of tracer in each grid box
+        ! Si  1rst order moment in i direction
+  !
+  REAL :: SM(iip1,jjp1,llm) &
+        ,S0(iip1,jjp1,llm,ntra)
+  REAL :: sx(iip1,jjp1,llm,ntra) &
+        ,sy(iip1,jjp1,llm,ntra) &
+        ,sz(iip1,jjp1,llm,ntra)
+
+
+  !  Local :
+  !  -------
+
+  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+  !  mass fluxes in kg
+  !  declaration :
+
+  REAL :: VGRI(iip1,0:jjp1,llm)
+
+  !  Rem : UGRI et WGRI ne sont pas utilises dans
+  !  cette SUBROUTINE ( advection en y uniquement )
+  !  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+  !
+  !  the moments F are similarly defined and used as temporary
+  !  storage for portions of the grid boxes in transit
+  !
+  REAL :: F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+  REAL :: FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+  REAL :: FZ(iim,jjm,ntra)
+  REAL :: S00(ntra)
+  REAL :: SM0             ! Just temporal variable
+  !
+  !  work arrays
+  !
+  REAL :: ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+  REAL :: ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+  REAL :: TEMPTM          ! Just temporal variable
+  !
+  !  Special pour poles
+  !
+  REAL :: sbms,sfms,sfzs,sbmn,sfmn,sfzn
+  REAL :: sns0(ntra),snsz(ntra),snsm
+  REAL :: s1v(llm),slatv(llm)
+  REAL :: qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+  REAL :: cx1(llm,ntra), cxLAT(llm,ntra)
+  REAL :: cy1(llm,ntra), cyLAT(llm,ntra)
+  REAL :: z1(iim), zcos(iim), zsin(iim)
+  real :: smpn,smps,s0pn,s0ps
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  REAL :: sqi,sqf
+  LOGICAL :: LIMIT
+
+  lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+  lat = jjp1        ! a cause des dim. differentes entre les
+  niv=llm
+
+  !
+  !  the moments Fi are used as temporary storage for
+  !  portions of the grid boxes in transit at the current level
+  !
+  !  work arrays
+  !
+
+  DO l = 1,llm
+     DO j = 1,jjm
+        DO i = 1,iip1
+        vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)
+        enddo
+     enddo
+     do i=1,iip1
+         vgri(i,0,l) = 0.
+         vgri(i,jjp1,l) = 0.
+     enddo
+  enddo
+
+  DO L=1,NIV
+  !
+  !  place limits on appropriate moments before transport
+  !  (if flux-limiting is to be applied)
+  !
+  IF(.NOT.LIMIT) GO TO 11
+  !
+  DO JV=1,NTRA
+  DO K=1,LAT
+  DO I=1,LON
+     sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), &
+           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
+  END DO
+  END DO
+  END DO
+  !
+ 11   CONTINUE
+  !
+  !  le flux a travers le pole Nord est traite separement
+  !
+  SM0=0.
+  DO JV=1,NTRA
+     S00(JV)=0.
+  END DO
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)<=0.) THEN
+       FM(I,0)=-VGRI(I,0,L)*DTY
+       ALF(I,0)=FM(I,0)/SM(I,1,L)
+       SM(I,1,L)=SM(I,1,L)-FM(I,0)
+       SM0=SM0+FM(I,0)
+     ENDIF
+  !
+     ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+     ALF1(I,0)=1.-ALF(I,0)
+     ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)<=0.) THEN
+  !
+       F0(I,0,JV)=ALF(I,0)* &
+             ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
+  !
+       S00(JV)=S00(JV)+F0(I,0,JV)
+       S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+       sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
+       sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
+       sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  DO I=1,LON
+     IF(VGRI(I,0,L)>0.) THEN
+       FM(I,0)=VGRI(I,0,L)*DTY
+       ALF(I,0)=FM(I,0)/SM0
+     ENDIF
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+     IF(VGRI(I,0,L)>0.) THEN
+       F0(I,0,JV)=ALF(I,0)*S00(JV)
+     ENDIF
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)>0.) THEN
+       SM(I,1,L)=SM(I,1,L)+FM(I,0)
+       ALF(I,0)=FM(I,0)/SM(I,1,L)
+     ENDIF
+  !
+     ALF1(I,0)=1.-ALF(I,0)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)>0.) THEN
+  !
+     TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+     S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+     sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  !  calculate flux and moments between adjacent boxes
+  !  1- create temporary moments/masses for partial boxes in transit
+  !  2- reajusts moments remaining in the box
+  !
+  !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+  !
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+       FM(I,K)=-VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM(I,KP,L)
+       SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+     ELSE
+       FM(I,K)=VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+       SM(I,K,L)=SM(I,K,L)-FM(I,K)
+     ENDIF
+  !
+     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+     ALF1(I,K)=1.-ALF(I,K)
+     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+  !
+  END DO
+  END DO
+  !
+  DO JV=1,NTRA
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+  !
+       F0(I,K,JV)=ALF (I,K)* &
+             ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
+       FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
+       FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
+       FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
+  !
+       S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+       sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
+       sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
+       sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
+  !
+     ELSE
+  !
+       F0(I,K,JV)=ALF (I,K)* &
+             ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+       FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
+       FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
+       FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
+  !
+       S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
+       sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+       sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
+       sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+       SM(I,K,L)=SM(I,K,L)+FM(I,K)
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+     ELSE
+       SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+       ALF(I,K)=FM(I,K)/SM(I,KP,L)
+     ENDIF
+  !
+     ALF1(I,K)=1.-ALF(I,K)
+  !
+  END DO
+  END DO
+  !
+  DO JV=1,NTRA
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+  !
+     TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+     S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+     sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) &
+           +3.*TEMPTM
+     sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
+     sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
+  !
+     ELSE
+  !
+     TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+     S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+     sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) &
+           +3.*TEMPTM
+     sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
+     sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  END DO
+  !
+  !  traitement special pour le pole Sud (idem pole Nord)
+  !
+  K=LAT
+  !
+  SM0=0.
+  DO JV=1,NTRA
+     S00(JV)=0.
+  END DO
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)>=0.) THEN
+       FM(I,K)=VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+       SM(I,K,L)=SM(I,K,L)-FM(I,K)
+       SM0=SM0+FM(I,K)
+     ENDIF
+  !
+     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+     ALF1(I,K)=1.-ALF(I,K)
+     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)>=0.) THEN
+       F0 (I,K,JV)=ALF(I,K)* &
+             ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+       S00(JV)=S00(JV)+F0(I,K,JV)
+  !
+       S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+       sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+       sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
+       sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  DO I=1,LON
+     IF(VGRI(I,K,L)<0.) THEN
+       FM(I,K)=-VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM0
+     ENDIF
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+     IF(VGRI(I,K,L)<0.) THEN
+       F0(I,K,JV)=ALF(I,K)*S00(JV)
+     ENDIF
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+       SM(I,K,L)=SM(I,K,L)+FM(I,K)
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+     ENDIF
+  !
+     ALF1(I,K)=1.-ALF(I,K)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+  !
+     TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+     S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+     sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  END DO
+  !
+  RETURN
+END SUBROUTINE advy
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advyp.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advyp.F	(revision 5104)
+++ 	(revision )
@@ -1,656 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
-     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
-      IMPLICIT NONE
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                 C
-C  second-order moments (SOM) advection of tracer in Y direction  C
-C                                                                 C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                C
-C  Source : Pascal Simon ( Meteo, CNRM )                         C
-C  Adaptation : A.A. (LGGE)                                      C
-C  Derniere Modif : 19/10/95 LAST
-C                                                                C
-C  sont les arguments d'entree pour le s-pg                      C
-C                                                                C
-C  argument de sortie du s-pg                                    C
-C                                                                C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C  Rem : Probleme aux poles il faut reecrire ce cas specifique
-C        Attention au sens de l'indexation 
-C
-C  parametres principaux du modele
-C
-C
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
- 
-C  Arguments :
-C  ----------
-C  dty : frequence fictive d'appel du transport
-C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
-
-      INTEGER lon,lat,niv
-      INTEGER i,j,jv,k,kp,l
-      INTEGER ntra
-C      PARAMETER (ntra = 1)
-
-      REAL dty
-      REAL pbarv ( iip1,jjm, llm )
-
-C  moments: SM  total mass in each grid box
-C           S0  mass of tracer in each grid box
-C           Si  1rst order moment in i direction
-C
-      REAL SM(iip1,jjp1,llm)
-     +    ,S0(iip1,jjp1,llm,ntra)
-      REAL SSX(iip1,jjp1,llm,ntra)
-     +    ,SY(iip1,jjp1,llm,ntra)
-     +    ,SZ(iip1,jjp1,llm,ntra)
-     +    ,SSXX(iip1,jjp1,llm,ntra)
-     +    ,SSXY(iip1,jjp1,llm,ntra)
-     +    ,SSXZ(iip1,jjp1,llm,ntra)
-     +    ,SYY(iip1,jjp1,llm,ntra)
-     +    ,SYZ(iip1,jjp1,llm,ntra)
-     +    ,SZZ(iip1,jjp1,llm,ntra)
-C
-C  Local :
-C  ------- 
-
-C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
-C  mass fluxes in kg
-C  declaration :
-
-      REAL VGRI(iip1,0:jjp1,llm)
-
-C  Rem : UGRI et WGRI ne sont pas utilises dans 
-C  cette SUBROUTINE ( advection en y uniquement )
-C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
-C
-C  the moments F are similarly defined and used as temporary
-C  storage for portions of the grid boxes in transit
-C
-C  the moments Fij are used as temporary storage for
-C  portions of the grid boxes in transit at the current level
-C
-C  work arrays
-C
-C
-      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
-      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
-      REAL FZ(iim,jjm,ntra)
-      REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
-      REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
-      REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
-      REAL S00(ntra)
-      REAL SM0             ! Just temporal variable
-C
-C  work arrays
-C
-      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
-      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
-      REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
-      REAL ALF4(iim,0:jjp1)
-      REAL TEMPTM          ! Just temporal variable
-      REAL SLPMAX,S1MAX,S1NEW,S2NEW
-c
-C  Special pour poles 
-c
-      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
-      REAL sns0(ntra),snsz(ntra),snsm
-      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
-      REAL cx1(llm,ntra), cxLAT(llm,ntra)
-      REAL cy1(llm,ntra), cyLAT(llm,ntra)
-      REAL z1(iim), zcos(iim), zsin(iim)
-      REAL SSUM
-      EXTERNAL SSUM
-C
-      REAL sqi,sqf
-      LOGICAL LIMIT
-
-      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
-      lat = jjp1        ! a cause des dim. differentes entre les
-      niv = llm         !       tab. S et VGRI 
-                    
-c-----------------------------------------------------------------
-C initialisations
-
-      sbms = 0.
-      sfms = 0.
-      sfzs = 0.
-      sbmn = 0.
-      sfmn = 0.
-      sfzn = 0.
-
-c-----------------------------------------------------------------
-C *** Test : diag de la qtite totale de traceur dans
-C            l'atmosphere avant l'advection en Y
-c 
-      sqi = 0.
-      sqf = 0.
-
-      DO l = 1,llm
-         DO j = 1,jjp1
-           DO i = 1,iim
-              sqi = sqi + S0(i,j,l,ntra)
-           END DO
-         END DO
-      END DO
-      PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
-      PRINT*,'sqi=',sqi
-
-c-----------------------------------------------------------------
-C  Interface : adaptation nouveau modele
-C  -------------------------------------
-C
-C  Conversion des flux de masses en kg
-C-AA 20/10/94  le signe -1 est necessaire car indexation opposee
-
-      DO l = 1,llm
-         DO j = 1,jjm
-            DO i = 1,iip1
-            vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
-      END DO
-      END DO
-      END DO
-
-CAA Initialisation de flux fictifs aux bords sup. des boites pol.
-
-      DO l = 1,llm
-         DO i = 1,iip1  
-             vgri(i,0,l) = 0.
-             vgri(i,jjp1,l) = 0.
-         ENDDO
-      ENDDO
-c
-c----------------- START HERE -----------------------
-C  boucle sur les niveaux
-C
-      DO L=1,NIV
-C
-C  place limits on appropriate moments before transport
-C      (if flux-limiting is to be applied)
-C
-      IF(.NOT.LIMIT) GO TO 11
-C
-      DO JV=1,NTRA
-      DO K=1,LAT
-      DO I=1,LON
-         IF(S0(I,K,L,JV)>0.) THEN
-           SLPMAX=AMAX1(S0(I,K,L,JV),0.)
-           S1MAX=1.5*SLPMAX
-           S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
-           S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
-     +                  AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
-           SY (I,K,L,JV)=S1NEW
-           SYY(I,K,L,JV)=S2NEW
-       SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
-       SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
-         ELSE
-           SY (I,K,L,JV)=0.
-           SYY(I,K,L,JV)=0.
-           SSXY(I,K,L,JV)=0.
-           SYZ(I,K,L,JV)=0.
-         ENDIF
-      END DO
-      END DO
-      END DO
-C
- 11   CONTINUE
-C
-C  le flux a travers le pole Nord est traite separement
-C
-      SM0=0.
-      DO JV=1,NTRA
-         S00(JV)=0.
-      END DO
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)<=0.) THEN
-           FM(I,0)=-VGRI(I,0,L)*DTY
-           ALF(I,0)=FM(I,0)/SM(I,1,L)
-           SM(I,1,L)=SM(I,1,L)-FM(I,0)
-           SM0=SM0+FM(I,0)
-         ENDIF
-C
-         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
-         ALF1(I,0)=1.-ALF(I,0)
-         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
-         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
-         ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
-         ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
-C
-      END DO
-c     PRINT*,'ADVYP 21'
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)<=0.) THEN
-C
-           F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
-     +        ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
-C
-           S00(JV)=S00(JV)+F0(I,0,JV)
-           S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
-           SY (I,1,L,JV)=ALF1Q(I,0)*
-     +            (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
-           SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
-           SSX (I,1,L,JV)=ALF1 (I,0)*
-     +            (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
-           SZ (I,1,L,JV)=ALF1 (I,0)*
-     +            (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
-           SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
-           SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
-           SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
-           SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
-           SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      DO I=1,LON
-         IF(VGRI(I,0,L)>0.) THEN
-           FM(I,0)=VGRI(I,0,L)*DTY
-           ALF(I,0)=FM(I,0)/SM0
-         ENDIF
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-         IF(VGRI(I,0,L)>0.) THEN
-           F0(I,0,JV)=ALF(I,0)*S00(JV)
-         ENDIF
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-c     PRINT*,'av ADVYP 25'
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)>0.) THEN
-           SM(I,1,L)=SM(I,1,L)+FM(I,0)
-           ALF(I,0)=FM(I,0)/SM(I,1,L)
-         ENDIF
-C
-         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
-         ALF1(I,0)=1.-ALF(I,0)
-         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
-         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
-         ALF3(I,0)=ALF1(I,0)*ALF(I,0)
-C
-      END DO
-c     PRINT*,'av ADVYP 25'
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,0,L)>0.) THEN
-C
-         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
-         S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
-         SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
-     +        +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
-         SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
-      SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
-      SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-C  calculate flux and moments between adjacent boxes
-C  1- create temporary moments/masses for partial boxes in transit
-C  2- reajusts moments remaining in the box
-C
-C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
-C
-c     PRINT*,'av ADVYP 30'
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-           FM(I,K)=-VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM(I,KP,L)
-           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
-         ELSE
-           FM(I,K)=VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-           SM(I,K,L)=SM(I,K,L)-FM(I,K)
-         ENDIF
-C
-         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
-         ALF1(I,K)=1.-ALF(I,K)
-         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
-         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
-         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
-         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
-C
-      END DO
-      END DO
-c     PRINT*,'ap ADVYP 30'
-C
-      DO JV=1,NTRA
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-C
-           F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
-     +        ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
-           FY (I,K,JV)=ALFQ(I,K)*
-     +                 (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
-           FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
-           FX (I,K,JV)=ALF (I,K)*
-     +                 (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
-           FZ (I,K,JV)=ALF (I,K)*
-     +                 (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
-           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
-           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
-           FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
-           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
-           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
-C
-           S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
-           SY (I,KP,L,JV)=ALF1Q(I,K)*
-     +                 (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
-           SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
-           SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
-           SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
-           SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
-           SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
-           SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
-           SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
-           SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
-C
-         ELSE
-C
-           F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
-     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
-           FY (I,K,JV)=ALFQ(I,K)*
-     +                 (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
-           FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
-      FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
-      FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
-           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
-           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
-           FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
-           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
-           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
-C
-           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
-           SY (I,K,L,JV)=ALF1Q(I,K)*
-     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
-           SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
-           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
-           SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
-           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
-           SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
-           SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
-           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
-           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-      END DO
-c     PRINT*,'ap ADVYP 31'
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-           SM(I,K,L)=SM(I,K,L)+FM(I,K)
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-         ELSE
-           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
-           ALF(I,K)=FM(I,K)/SM(I,KP,L)
-         ENDIF
-C
-         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
-         ALF1(I,K)=1.-ALF(I,K)
-         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
-         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
-         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
-C
-      END DO
-      END DO
-c     PRINT*,'ap ADVYP 32'
-C
-      DO JV=1,NTRA
-      DO K=1,LAT-1
-      KP=K+1
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-C
-         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
-         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
-       SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV)
-     +  +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
-         SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV)
-     +            +3.*TEMPTM
-       SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV)
-     +         +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
-       SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV)
-     +         +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
-         SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
-         SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
-         SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
-         SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
-         SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
-C
-         ELSE
-C
-         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
-         S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
-       SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV)
-     +  +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
-         SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV)
-     +                 +3.*TEMPTM
-       SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV)
-     +             +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
-         SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV)
-     +             +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
-         SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
-         SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
-         SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
-         SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
-         SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-      END DO
-c     PRINT*,'ap ADVYP 33'
-C
-C  traitement special pour le pole Sud (idem pole Nord)
-C
-      K=LAT
-C
-      SM0=0.
-      DO JV=1,NTRA
-         S00(JV)=0.
-      END DO
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)>=0.) THEN
-           FM(I,K)=VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-           SM(I,K,L)=SM(I,K,L)-FM(I,K)
-           SM0=SM0+FM(I,K)
-         ENDIF
-C
-         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
-         ALF1(I,K)=1.-ALF(I,K)
-         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
-         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
-         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
-         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
-C
-      END DO
-c     PRINT*,'ap ADVYP 41'
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)>=0.) THEN
-           F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
-     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
-           S00(JV)=S00(JV)+F0(I,K,JV)
-C
-           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
-           SY (I,K,L,JV)=ALF1Q(I,K)*
-     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
-           SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
-      SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
-      SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
-           SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
-           SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
-           SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
-           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
-           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
-         ENDIF
-C
-      END DO
-      END DO
-c     PRINT*,'ap ADVYP 42'
-C
-      DO I=1,LON
-         IF(VGRI(I,K,L)<0.) THEN
-           FM(I,K)=-VGRI(I,K,L)*DTY
-           ALF(I,K)=FM(I,K)/SM0
-         ENDIF
-      END DO
-c     PRINT*,'ap ADVYP 43'
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-         IF(VGRI(I,K,L)<0.) THEN
-           F0(I,K,JV)=ALF(I,K)*S00(JV)
-         ENDIF
-      END DO
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-           SM(I,K,L)=SM(I,K,L)+FM(I,K)
-           ALF(I,K)=FM(I,K)/SM(I,K,L)
-         ENDIF
-C
-         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
-         ALF1(I,K)=1.-ALF(I,K)
-         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
-         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
-         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
-C
-      END DO
-c     PRINT*,'ap ADVYP 45'
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(VGRI(I,K,L)<0.) THEN
-C
-         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
-         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
-         SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
-     +           +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
-         SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
-      SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
-      SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-c     PRINT*,'ap ADVYP 46'
-C
-      END DO
-
-c--------------------------------------------------
-C     bouclage cyclique horizontal .
-     
-      DO l = 1,llm
-         DO jv = 1,ntra
-            DO j = 1,jjp1
-               SM(iip1,j,l) = SM(1,j,l)
-               S0(iip1,j,l,jv) = S0(1,j,l,jv)
-               SSX(iip1,j,l,jv) = SSX(1,j,l,jv)   
-               SY(iip1,j,l,jv) = SY(1,j,l,jv)
-               SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
-            END DO
-         END DO
-      END DO
-
-c -------------------------------------------------------------------
-C *** Test  negativite:
-
-c      DO jv = 1,ntra
-c       DO l = 1,llm
-c         DO j = 1,jjp1
-c           DO i = 1,iip1
-c              IF (s0( i,j,l,jv ).lt.0.) THEN
-c                 PRINT*, '------ S0 < 0 en FIN ADVYP ---'
-c                 PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
-cc                 STOP
-c              ENDIF
-c           ENDDO
-c         ENDDO
-c       ENDDO
-c      ENDDO
- 
-   
-c -------------------------------------------------------------------
-C *** Test : diag de la qtite totale de traceur dans
-C            l'atmosphere avant l'advection en Y
- 
-       DO l = 1,llm
-         DO j = 1,jjp1
-           DO i = 1,iim
-              sqf = sqf + S0(i,j,l,ntra)
-           END DO
-         END DO
-       END DO
-      PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
-      PRINT*,'sqf=',sqf
-c     PRINT*,'ap ADVYP fin'
-
-c-----------------------------------------------------------------
-C
-      RETURN
-      END
-
-
-
-
-
-
-
-
-
-
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advyp.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advyp.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advyp.f90	(revision 5105)
@@ -0,0 +1,656 @@
+
+! $Header$
+
+SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ &
+        ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+  IMPLICIT NONE
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                 C
+  !  second-order moments (SOM) advection of tracer in Y direction  C
+  !                                                                 C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                             ! C
+  !  Source : Pascal Simon ( Meteo, CNRM )                         C
+  !  Adaptation : A.A. (LGGE)                                      C
+  !  Derniere Modif : 19/10/95 LAST
+                                                             ! C
+  !  sont les arguments d'entree pour le s-pg                      C
+  !                                                                C
+  !  argument de sortie du s-pg                                    C
+  !                                                                C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !
+  !  Rem : Probleme aux poles il faut reecrire ce cas specifique
+  !    Attention au sens de l'indexation
+  !
+  !  parametres principaux du modele
+  !
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  !  Arguments :
+  !  ----------
+  !  dty : frequence fictive d'appel du transport
+  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+  INTEGER :: lon,lat,niv
+  INTEGER :: i,j,jv,k,kp,l
+  INTEGER :: ntra
+   ! PARAMETER (ntra = 1)
+
+  REAL :: dty
+  REAL :: pbarv ( iip1,jjm, llm )
+
+  !  moments: SM  total mass in each grid box
+        ! S0  mass of tracer in each grid box
+        ! Si  1rst order moment in i direction
+  !
+  REAL :: SM(iip1,jjp1,llm) &
+        ,S0(iip1,jjp1,llm,ntra)
+  REAL :: SSX(iip1,jjp1,llm,ntra) &
+        ,SY(iip1,jjp1,llm,ntra) &
+        ,SZ(iip1,jjp1,llm,ntra) &
+        ,SSXX(iip1,jjp1,llm,ntra) &
+        ,SSXY(iip1,jjp1,llm,ntra) &
+        ,SSXZ(iip1,jjp1,llm,ntra) &
+        ,SYY(iip1,jjp1,llm,ntra) &
+        ,SYZ(iip1,jjp1,llm,ntra) &
+        ,SZZ(iip1,jjp1,llm,ntra)
+  !
+  !  Local :
+  !  -------
+
+  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+  !  mass fluxes in kg
+  !  declaration :
+
+  REAL :: VGRI(iip1,0:jjp1,llm)
+
+  !  Rem : UGRI et WGRI ne sont pas utilises dans
+  !  cette SUBROUTINE ( advection en y uniquement )
+  !  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+  !
+  !  the moments F are similarly defined and used as temporary
+  !  storage for portions of the grid boxes in transit
+  !
+  !  the moments Fij are used as temporary storage for
+  !  portions of the grid boxes in transit at the current level
+  !
+  !  work arrays
+  !
+  !
+  REAL :: F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+  REAL :: FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+  REAL :: FZ(iim,jjm,ntra)
+  REAL :: FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
+  REAL :: FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
+  REAL :: FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
+  REAL :: S00(ntra)
+  REAL :: SM0             ! Just temporal variable
+  !
+  !  work arrays
+  !
+  REAL :: ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+  REAL :: ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+  REAL :: ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
+  REAL :: ALF4(iim,0:jjp1)
+  REAL :: TEMPTM          ! Just temporal variable
+  REAL :: SLPMAX,S1MAX,S1NEW,S2NEW
+  !
+  !  Special pour poles
+  !
+  REAL :: sbms,sfms,sfzs,sbmn,sfmn,sfzn
+  REAL :: sns0(ntra),snsz(ntra),snsm
+  REAL :: qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+  REAL :: cx1(llm,ntra), cxLAT(llm,ntra)
+  REAL :: cy1(llm,ntra), cyLAT(llm,ntra)
+  REAL :: z1(iim), zcos(iim), zsin(iim)
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  REAL :: sqi,sqf
+  LOGICAL :: LIMIT
+
+  lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+  lat = jjp1        ! a cause des dim. differentes entre les
+  niv = llm         !       tab. S et VGRI
+
+  !-----------------------------------------------------------------
+  ! initialisations
+
+  sbms = 0.
+  sfms = 0.
+  sfzs = 0.
+  sbmn = 0.
+  sfmn = 0.
+  sfzn = 0.
+
+  !-----------------------------------------------------------------
+  ! *** Test : diag de la qtite totale de traceur dans
+         ! l'atmosphere avant l'advection en Y
+  !
+  sqi = 0.
+  sqf = 0.
+
+  DO l = 1,llm
+     DO j = 1,jjp1
+       DO i = 1,iim
+          sqi = sqi + S0(i,j,l,ntra)
+       END DO
+     END DO
+  END DO
+  PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
+  PRINT*,'sqi=',sqi
+
+  !-----------------------------------------------------------------
+  !  Interface : adaptation nouveau modele
+  !  -------------------------------------
+  !
+  !  Conversion des flux de masses en kg
+  !-AA 20/10/94  le signe -1 est necessaire car indexation opposee
+
+  DO l = 1,llm
+     DO j = 1,jjm
+        DO i = 1,iip1
+        vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
+  END DO
+  END DO
+  END DO
+
+  !AA Initialisation de flux fictifs aux bords sup. des boites pol.
+
+  DO l = 1,llm
+     DO i = 1,iip1
+         vgri(i,0,l) = 0.
+         vgri(i,jjp1,l) = 0.
+     ENDDO
+  ENDDO
+  !
+  !----------------- START HERE -----------------------
+  !  boucle sur les niveaux
+  !
+  DO L=1,NIV
+  !
+  !  place limits on appropriate moments before transport
+  !  (if flux-limiting is to be applied)
+  !
+  IF(.NOT.LIMIT) GO TO 11
+  !
+  DO JV=1,NTRA
+  DO K=1,LAT
+  DO I=1,LON
+     IF(S0(I,K,L,JV)>0.) THEN
+       SLPMAX=AMAX1(S0(I,K,L,JV),0.)
+       S1MAX=1.5*SLPMAX
+       S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
+       S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , &
+             AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
+       SY (I,K,L,JV)=S1NEW
+       SYY(I,K,L,JV)=S2NEW
+   SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
+   SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+     ELSE
+       SY (I,K,L,JV)=0.
+       SYY(I,K,L,JV)=0.
+       SSXY(I,K,L,JV)=0.
+       SYZ(I,K,L,JV)=0.
+     ENDIF
+  END DO
+  END DO
+  END DO
+  !
+ 11   CONTINUE
+  !
+  !  le flux a travers le pole Nord est traite separement
+  !
+  SM0=0.
+  DO JV=1,NTRA
+     S00(JV)=0.
+  END DO
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)<=0.) THEN
+       FM(I,0)=-VGRI(I,0,L)*DTY
+       ALF(I,0)=FM(I,0)/SM(I,1,L)
+       SM(I,1,L)=SM(I,1,L)-FM(I,0)
+       SM0=SM0+FM(I,0)
+     ENDIF
+  !
+     ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+     ALF1(I,0)=1.-ALF(I,0)
+     ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+     ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+     ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
+     ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
+  !
+  END DO
+  ! PRINT*,'ADVYP 21'
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)<=0.) THEN
+  !
+       F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* &
+             ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
+  !
+       S00(JV)=S00(JV)+F0(I,0,JV)
+       S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+       SY (I,1,L,JV)=ALF1Q(I,0)* &
+             (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
+       SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
+       SSX (I,1,L,JV)=ALF1 (I,0)* &
+             (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
+       SZ (I,1,L,JV)=ALF1 (I,0)* &
+             (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
+       SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
+       SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
+       SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
+       SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
+       SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  DO I=1,LON
+     IF(VGRI(I,0,L)>0.) THEN
+       FM(I,0)=VGRI(I,0,L)*DTY
+       ALF(I,0)=FM(I,0)/SM0
+     ENDIF
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+     IF(VGRI(I,0,L)>0.) THEN
+       F0(I,0,JV)=ALF(I,0)*S00(JV)
+     ENDIF
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  ! PRINT*,'av ADVYP 25'
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)>0.) THEN
+       SM(I,1,L)=SM(I,1,L)+FM(I,0)
+       ALF(I,0)=FM(I,0)/SM(I,1,L)
+     ENDIF
+  !
+     ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+     ALF1(I,0)=1.-ALF(I,0)
+     ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+     ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+     ALF3(I,0)=ALF1(I,0)*ALF(I,0)
+  !
+  END DO
+  ! PRINT*,'av ADVYP 25'
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,0,L)>0.) THEN
+  !
+     TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+     S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+     SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) &
+           +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
+     SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
+  SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
+  SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  !  calculate flux and moments between adjacent boxes
+  !  1- create temporary moments/masses for partial boxes in transit
+  !  2- reajusts moments remaining in the box
+  !
+  !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+  !
+  ! PRINT*,'av ADVYP 30'
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+       FM(I,K)=-VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM(I,KP,L)
+       SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+     ELSE
+       FM(I,K)=VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+       SM(I,K,L)=SM(I,K,L)-FM(I,K)
+     ENDIF
+  !
+     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+     ALF1(I,K)=1.-ALF(I,K)
+     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+     ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+     ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+     ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+  !
+  END DO
+  END DO
+  ! PRINT*,'ap ADVYP 30'
+  !
+  DO JV=1,NTRA
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+  !
+       F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* &
+             ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
+       FY (I,K,JV)=ALFQ(I,K)* &
+             (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
+       FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
+       FX (I,K,JV)=ALF (I,K)* &
+             (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
+       FZ (I,K,JV)=ALF (I,K)* &
+             (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
+       FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
+       FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
+       FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
+       FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
+       FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
+  !
+       S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+       SY (I,KP,L,JV)=ALF1Q(I,K)* &
+             (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
+       SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
+       SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
+       SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
+       SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
+       SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
+       SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
+       SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
+       SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
+  !
+     ELSE
+  !
+       F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* &
+             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+       FY (I,K,JV)=ALFQ(I,K)* &
+             (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
+       FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
+  FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
+  FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
+       FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
+       FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
+       FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
+       FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
+       FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
+  !
+       S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+       SY (I,K,L,JV)=ALF1Q(I,K)* &
+             (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+       SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
+       SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
+       SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
+       SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
+       SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
+       SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
+       SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+       SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  END DO
+  ! PRINT*,'ap ADVYP 31'
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+       SM(I,K,L)=SM(I,K,L)+FM(I,K)
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+     ELSE
+       SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+       ALF(I,K)=FM(I,K)/SM(I,KP,L)
+     ENDIF
+  !
+     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+     ALF1(I,K)=1.-ALF(I,K)
+     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+     ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+     ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+  !
+  END DO
+  END DO
+  ! PRINT*,'ap ADVYP 32'
+  !
+  DO JV=1,NTRA
+  DO K=1,LAT-1
+  KP=K+1
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+  !
+     TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+     S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+   SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) &
+         +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
+     SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) &
+           +3.*TEMPTM
+   SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) &
+         +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
+   SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) &
+         +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
+     SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
+     SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
+     SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
+     SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
+     SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
+  !
+     ELSE
+  !
+     TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+     S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+   SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) &
+         +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
+     SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) &
+           +3.*TEMPTM
+   SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) &
+         +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
+     SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) &
+           +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
+     SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
+     SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
+     SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
+     SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
+     SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  END DO
+  ! PRINT*,'ap ADVYP 33'
+  !
+  !  traitement special pour le pole Sud (idem pole Nord)
+  !
+  K=LAT
+  !
+  SM0=0.
+  DO JV=1,NTRA
+     S00(JV)=0.
+  END DO
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)>=0.) THEN
+       FM(I,K)=VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+       SM(I,K,L)=SM(I,K,L)-FM(I,K)
+       SM0=SM0+FM(I,K)
+     ENDIF
+  !
+     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+     ALF1(I,K)=1.-ALF(I,K)
+     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+     ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+     ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+     ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+  !
+  END DO
+  ! PRINT*,'ap ADVYP 41'
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)>=0.) THEN
+       F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* &
+             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+       S00(JV)=S00(JV)+F0(I,K,JV)
+  !
+       S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+       SY (I,K,L,JV)=ALF1Q(I,K)* &
+             (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+       SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
+  SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
+  SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
+       SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
+       SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
+       SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
+       SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+       SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+     ENDIF
+  !
+  END DO
+  END DO
+  ! PRINT*,'ap ADVYP 42'
+  !
+  DO I=1,LON
+     IF(VGRI(I,K,L)<0.) THEN
+       FM(I,K)=-VGRI(I,K,L)*DTY
+       ALF(I,K)=FM(I,K)/SM0
+     ENDIF
+  END DO
+  ! PRINT*,'ap ADVYP 43'
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+     IF(VGRI(I,K,L)<0.) THEN
+       F0(I,K,JV)=ALF(I,K)*S00(JV)
+     ENDIF
+  END DO
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+       SM(I,K,L)=SM(I,K,L)+FM(I,K)
+       ALF(I,K)=FM(I,K)/SM(I,K,L)
+     ENDIF
+  !
+     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+     ALF1(I,K)=1.-ALF(I,K)
+     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+     ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+     ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+  !
+  END DO
+  ! PRINT*,'ap ADVYP 45'
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(VGRI(I,K,L)<0.) THEN
+  !
+     TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+     S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+     SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) &
+           +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
+     SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
+  SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
+  SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  ! PRINT*,'ap ADVYP 46'
+  !
+  END DO
+
+  !--------------------------------------------------
+  ! bouclage cyclique horizontal .
+
+  DO l = 1,llm
+     DO jv = 1,ntra
+        DO j = 1,jjp1
+           SM(iip1,j,l) = SM(1,j,l)
+           S0(iip1,j,l,jv) = S0(1,j,l,jv)
+           SSX(iip1,j,l,jv) = SSX(1,j,l,jv)
+           SY(iip1,j,l,jv) = SY(1,j,l,jv)
+           SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
+        END DO
+     END DO
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! *** Test  negativite:
+
+   ! DO jv = 1,ntra
+   !  DO l = 1,llm
+   !    DO j = 1,jjp1
+   !      DO i = 1,iip1
+   !         IF (s0( i,j,l,jv ).lt.0.) THEN
+   !            PRINT*, '------ S0 < 0 en FIN ADVYP ---'
+   !            PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
+  !c                 STOP
+   !         ENDIF
+   !      ENDDO
+   !    ENDDO
+   !  ENDDO
+   ! ENDDO
+
+
+  ! -------------------------------------------------------------------
+  ! *** Test : diag de la qtite totale de traceur dans
+   !       l'atmosphere avant l'advection en Y
+
+   DO l = 1,llm
+     DO j = 1,jjp1
+       DO i = 1,iim
+          sqf = sqf + S0(i,j,l,ntra)
+       END DO
+     END DO
+   END DO
+  PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
+  PRINT*,'sqf=',sqf
+  ! PRINT*,'ap ADVYP fin'
+
+  !-----------------------------------------------------------------
+  !
+  RETURN
+END SUBROUTINE ADVYP
+
+
+
+
+
+
+
+
+
+
+
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advz.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advz.F	(revision 5104)
+++ 	(revision )
@@ -1,323 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
-      IMPLICIT NONE
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                C
-C  first-order moments (FOM) advection of tracer in Z direction  C
-C                                                                C
-C  Source : Pascal Simon (Meteo,CNRM)                            C
-C  Adaptation : A.Armengaud (LGGE) juin 94                       C
-C                                                                C
-C                                                                C
-C  sont des arguments d'entree pour le s-pg...                   C
-C                                                                C
-C  dq est l'argument de sortie pour le s-pg                      C
-C                                                                C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C  parametres principaux du modele
-C
-      include "dimensions.h"
-      include "paramet.h"
-
-C     INCLUDE "traceur.h"
-
-C  Arguments :
-C  -----------
-C  dtz : frequence fictive d'appel du transport 
-C  w : flux de masse en z en Pa.m2.s-1
-
-      INTEGER ntra
-      PARAMETER (ntra = 1)
-
-      REAL dtz
-      REAL w ( iip1,jjp1,llm )
-    
-C  moments: SM  total mass in each grid box
-C           S0  mass of tracer in each grid box
-C           Si  1rst order moment in i direction
-C
-      REAL SM(iip1,jjp1,llm)
-     +    ,S0(iip1,jjp1,llm,ntra)
-      REAL sx(iip1,jjp1,llm,ntra)
-     +    ,sy(iip1,jjp1,llm,ntra)
-     +    ,sz(iip1,jjp1,llm,ntra)
-
-
-C  Local :
-C  ------- 
-
-C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
-C  mass fluxes in kg
-C  declaration :
-
-      REAL WGRI(iip1,jjp1,0:llm)
-
-C
-C  the moments F are used as temporary  storage for 
-C  portions of grid boxes in transit at the current latitude
-C
-      REAL FM(iim,llm)
-      REAL F0(iim,llm,ntra),FX(iim,llm,ntra)
-      REAL FY(iim,llm,ntra),FZ(iim,llm,ntra)
-C
-C  work arrays
-C
-      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
-      REAL TEMPTM            ! Just temporal variable
-      REAL sqi,sqf
-C
-      LOGICAL LIMIT
-      INTEGER lon,lat,niv
-      INTEGER i,j,jv,k,l,lp
-
-      lon = iim
-      lat = jjp1
-      niv = llm 
-
-C *** Test de passage d'arguments ******
- 
-c     DO 399 l = 1, llm
-c     DO 399 j = 1, jjp1
-c     DO 399 i = 1, iip1
-c        IF (S0(i,j,l,ntra) .lt. 0. ) THEN
-c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
-c           PRINT*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
-c           PRINT*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
-c           PRINT*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
-c           PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
-c            STOP
-c        ENDIF
-  399 CONTINUE
-
-C-----------------------------------------------------------------
-C *** Test : diag de la qqtite totale de traceur 
-C            dans l'atmosphere avant l'advection en z
-      sqi = 0.
-      sqf = 0.
-
-      DO l = 1,llm
-         DO j = 1,jjp1
-            DO i = 1,iim
-cIM 240305            sqi = sqi + S0(i,j,l,9)
-               sqi = sqi + S0(i,j,l,ntra)
-            ENDDO
-         ENDDO
-      ENDDO
-      PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
-      PRINT*,'sqi=',sqi
-
-C-----------------------------------------------------------------
-C  Interface : adaptation nouveau modele
-C  -------------------------------------
-C
-C  Conversion du flux de masse en kg.s-1
-
-      DO l = 1,llm
-         DO j = 1,jjp1
-            DO i = 1,iip1  
-c            wgri (i,j,llm+1-l) =  w (i,j,l) / g 
-               wgri (i,j,llm+1-l) =  w (i,j,l) 
-c             wgri (i,j,0) = 0.                ! a detruire ult.
-c             wgri (i,j,l) = 0.1               !    w (i,j,l) 
-c             wgri (i,j,llm) = 0.              ! a detruire ult.
-      END DO
-      END DO
-      END DO
-         DO  j = 1,jjp1
-            DO i = 1,iip1  
-               wgri(i,j,0)=0.
-            enddo
-         enddo
-
-C-----------------------------------------------------------------
-  
-C  start here          
-C  boucle sur les latitudes
-C
-      DO K=1,LAT
-C
-C  place limits on appropriate moments before transport
-C      (if flux-limiting is to be applied)
-C
-      IF(.NOT.LIMIT) GO TO 101
-C
-      DO JV=1,NTRA
-      DO L=1,NIV
-         DO I=1,LON
-            sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
-     +                              ABS(sz(I,K,L,JV))),sz(I,K,L,JV))
-      END DO
-      END DO
-      END DO
-C
- 101  CONTINUE
-C
-C  boucle sur les niveaux intercouches de 1 a NIV-1
-C   (flux nul au sommet L=0 et a la base L=NIV)
-C
-C  calculate flux and moments between adjacent boxes
-C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
-C  1- create temporary moments/masses for partial boxes in transit
-C  2- reajusts moments remaining in the box
-C
-      DO L=1,NIV-1
-      LP=L+1
-C
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-           FM(I,L)=-WGRI(I,K,L)*DTZ
-           ALF(I)=FM(I,L)/SM(I,K,LP)
-           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
-         ELSE
-           FM(I,L)=WGRI(I,K,L)*DTZ
-           ALF(I)=FM(I,L)/SM(I,K,L)
-           SM(I,K,L)=SM(I,K,L)-FM(I,L)
-         ENDIF
-C
-         ALFQ (I)=ALF(I)*ALF(I)
-         ALF1 (I)=1.-ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-C
-           F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) )
-           FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
-           FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
-           FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
-C
-           S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
-           sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
-           sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
-           sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
-C
-         ELSE
-C
-           F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) )
-           FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
-           FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
-           FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
-C
-           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
-           sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
-           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
-           sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO L=1,NIV-1
-      LP=L+1
-C
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-           SM(I,K,L)=SM(I,K,L)+FM(I,L)
-           ALF(I)=FM(I,L)/SM(I,K,L)
-         ELSE
-           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
-           ALF(I)=FM(I,L)/SM(I,K,LP)
-         ENDIF
-C
-         ALF1(I)=1.-ALF(I)
-         ALFQ(I)=ALF(I)*ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-C
-           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
-           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
-           sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM
-           sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
-           sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
-C
-         ELSE
-C
-           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
-           S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
-           sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV)
-     +                  +3.*TEMPTM
-           sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
-           sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      END DO
-C
-C  fin de la boucle principale sur les latitudes
-C
-      END DO
-C
-C-------------------------------------------------------------
-C
-C ----------- AA Test en fin de ADVX ------ Controle des S*
-
-c     DO 9999 l = 1, llm
-c     DO 9999 j = 1, jjp1
-c     DO 9999 i = 1, iip1
-c        IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
-c           PRINT*, '-------------------'
-c           PRINT*, 'En fin de ADVZ'
-c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
-c           PRINT*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
-c           PRINT*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
-c           PRINT*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
-c           WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1'
-c            STOP
-c        ENDIF
- 9999 CONTINUE
-
-C *** ------------------- bouclage cyclique  en X ------------
-      
-c      DO l = 1,llm
-c         DO j = 1,jjp1
-c            SM(iip1,j,l) = SM(1,j,l)
-c            S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
-C            sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
-c            sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
-c            sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
-c         ENDDO
-c      ENDDO
-           
-C-------------------------------------------------------------
-C *** Test : diag de la qqtite totale de traceur 
-C            dans l'atmosphere avant l'advection en z
-      DO l = 1,llm
-         DO j = 1,jjp1
-            DO i = 1,iim
-cIM 240305            sqf = sqf + S0(i,j,l,9)
-               sqf = sqf + S0(i,j,l,ntra)
-            ENDDO
-         ENDDO
-      ENDDO
-      PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
-      PRINT*,'sqf=', sqf
-
-C-------------------------------------------------------------
-      RETURN
-      END
-C_______________________________________________________________
-C_______________________________________________________________
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advz.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advz.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advz.f90	(revision 5105)
@@ -0,0 +1,323 @@
+
+! $Header$
+
+SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
+  IMPLICIT NONE
+
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                C
+  !  first-order moments (FOM) advection of tracer in Z direction  C
+  !                                                                C
+  !  Source : Pascal Simon (Meteo,CNRM)                            C
+  !  Adaptation : A.Armengaud (LGGE) juin 94                       C
+  !                                                                C
+  !                                                                C
+  !  sont des arguments d'entree pour le s-pg...                   C
+  !                                                                C
+  !  dq est l'argument de sortie pour le s-pg                      C
+  !                                                                C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !
+  !  parametres principaux du modele
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+  ! INCLUDE "traceur.h"
+
+  !  Arguments :
+  !  -----------
+  !  dtz : frequence fictive d'appel du transport
+  !  w : flux de masse en z en Pa.m2.s-1
+
+  INTEGER :: ntra
+  PARAMETER (ntra = 1)
+
+  REAL :: dtz
+  REAL :: w ( iip1,jjp1,llm )
+
+  !  moments: SM  total mass in each grid box
+        ! S0  mass of tracer in each grid box
+        ! Si  1rst order moment in i direction
+  !
+  REAL :: SM(iip1,jjp1,llm) &
+        ,S0(iip1,jjp1,llm,ntra)
+  REAL :: sx(iip1,jjp1,llm,ntra) &
+        ,sy(iip1,jjp1,llm,ntra) &
+        ,sz(iip1,jjp1,llm,ntra)
+
+
+  !  Local :
+  !  -------
+
+  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+  !  mass fluxes in kg
+  !  declaration :
+
+  REAL :: WGRI(iip1,jjp1,0:llm)
+
+  !
+  !  the moments F are used as temporary  storage for
+  !  portions of grid boxes in transit at the current latitude
+  !
+  REAL :: FM(iim,llm)
+  REAL :: F0(iim,llm,ntra),FX(iim,llm,ntra)
+  REAL :: FY(iim,llm,ntra),FZ(iim,llm,ntra)
+  !
+  !  work arrays
+  !
+  REAL :: ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+  REAL :: TEMPTM            ! Just temporal variable
+  REAL :: sqi,sqf
+  !
+  LOGICAL :: LIMIT
+  INTEGER :: lon,lat,niv
+  INTEGER :: i,j,jv,k,l,lp
+
+  lon = iim
+  lat = jjp1
+  niv = llm
+
+  ! *** Test de passage d'arguments ******
+
+  ! DO 399 l = 1, llm
+  ! DO 399 j = 1, jjp1
+  ! DO 399 i = 1, iip1
+  !    IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+  !       PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+  !       PRINT*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+  !       PRINT*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+  !       PRINT*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+  !       PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
+  !        STOP
+  !    ENDIF
+  399   CONTINUE
+
+  !-----------------------------------------------------------------
+  ! *** Test : diag de la qqtite totale de traceur
+         ! dans l'atmosphere avant l'advection en z
+  sqi = 0.
+  sqf = 0.
+
+  DO l = 1,llm
+     DO j = 1,jjp1
+        DO i = 1,iim
+  !IM 240305            sqi = sqi + S0(i,j,l,9)
+           sqi = sqi + S0(i,j,l,ntra)
+        ENDDO
+     ENDDO
+  ENDDO
+  PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
+  PRINT*,'sqi=',sqi
+
+  !-----------------------------------------------------------------
+  !  Interface : adaptation nouveau modele
+  !  -------------------------------------
+  !
+  !  Conversion du flux de masse en kg.s-1
+
+  DO l = 1,llm
+     DO j = 1,jjp1
+        DO i = 1,iip1
+         ! wgri (i,j,llm+1-l) =  w (i,j,l) / g
+           wgri (i,j,llm+1-l) =  w (i,j,l)
+          ! wgri (i,j,0) = 0.                ! a detruire ult.
+          ! wgri (i,j,l) = 0.1               !    w (i,j,l)
+          ! wgri (i,j,llm) = 0.              ! a detruire ult.
+  END DO
+  END DO
+  END DO
+     DO  j = 1,jjp1
+        DO i = 1,iip1
+           wgri(i,j,0)=0.
+        enddo
+     enddo
+
+  !-----------------------------------------------------------------
+
+  !  start here
+  !  boucle sur les latitudes
+  !
+  DO K=1,LAT
+  !
+  !  place limits on appropriate moments before transport
+  !  (if flux-limiting is to be applied)
+  !
+  IF(.NOT.LIMIT) GO TO 101
+  !
+  DO JV=1,NTRA
+  DO L=1,NIV
+     DO I=1,LON
+        sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), &
+              ABS(sz(I,K,L,JV))),sz(I,K,L,JV))
+  END DO
+  END DO
+  END DO
+  !
+ 101   CONTINUE
+  !
+  !  boucle sur les niveaux intercouches de 1 a NIV-1
+  !   (flux nul au sommet L=0 et a la base L=NIV)
+  !
+  !  calculate flux and moments between adjacent boxes
+  ! (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+  !  1- create temporary moments/masses for partial boxes in transit
+  !  2- reajusts moments remaining in the box
+  !
+  DO L=1,NIV-1
+  LP=L+1
+  !
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+       FM(I,L)=-WGRI(I,K,L)*DTZ
+       ALF(I)=FM(I,L)/SM(I,K,LP)
+       SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+     ELSE
+       FM(I,L)=WGRI(I,K,L)*DTZ
+       ALF(I)=FM(I,L)/SM(I,K,L)
+       SM(I,K,L)=SM(I,K,L)-FM(I,L)
+     ENDIF
+  !
+     ALFQ (I)=ALF(I)*ALF(I)
+     ALF1 (I)=1.-ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+  !
+       F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) )
+       FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
+       FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
+       FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
+  !
+       S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
+       sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
+       sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
+       sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
+  !
+     ELSE
+  !
+       F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) )
+       FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
+       FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
+       FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
+  !
+       S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
+       sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
+       sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
+       sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO L=1,NIV-1
+  LP=L+1
+  !
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+       SM(I,K,L)=SM(I,K,L)+FM(I,L)
+       ALF(I)=FM(I,L)/SM(I,K,L)
+     ELSE
+       SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+       ALF(I)=FM(I,L)/SM(I,K,LP)
+     ENDIF
+  !
+     ALF1(I)=1.-ALF(I)
+     ALFQ(I)=ALF(I)*ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+  !
+       TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+       S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+       sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM
+       sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
+       sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
+  !
+     ELSE
+  !
+       TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+       S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+       sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV) &
+             +3.*TEMPTM
+       sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
+       sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  END DO
+  !
+  !  fin de la boucle principale sur les latitudes
+  !
+  END DO
+  !
+  !-------------------------------------------------------------
+  !
+  ! ----------- AA Test en fin de ADVX ------ Controle des S*
+
+  ! DO 9999 l = 1, llm
+  ! DO 9999 j = 1, jjp1
+  ! DO 9999 i = 1, iip1
+  !    IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
+  !       PRINT*, '-------------------'
+  !       PRINT*, 'En fin de ADVZ'
+  !       PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+  !       PRINT*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+  !       PRINT*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+  !       PRINT*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+  !       WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1'
+  !        STOP
+  !    ENDIF
+ 9999   CONTINUE
+
+  ! *** ------------------- bouclage cyclique  en X ------------
+
+   ! DO l = 1,llm
+   !    DO j = 1,jjp1
+   !       SM(iip1,j,l) = SM(1,j,l)
+   !       S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+   !       sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
+   !       sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
+   !       sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
+   !    ENDDO
+   ! ENDDO
+
+  !-------------------------------------------------------------
+  ! *** Test : diag de la qqtite totale de traceur
+   !       dans l'atmosphere avant l'advection en z
+  DO l = 1,llm
+     DO j = 1,jjp1
+        DO i = 1,iim
+  !IM 240305            sqf = sqf + S0(i,j,l,9)
+           sqf = sqf + S0(i,j,l,ntra)
+        ENDDO
+     ENDDO
+  ENDDO
+  PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+  PRINT*,'sqf=', sqf
+
+  !-------------------------------------------------------------
+  RETURN
+END SUBROUTINE advz
+!_______________________________________________________________
+!_______________________________________________________________
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.F	(revision 5104)
+++ 	(revision )
@@ -1,379 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ
-     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
-
-      IMPLICIT NONE
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                 C
-C  second-order moments (SOM) advection of tracer in Z direction  C
-C                                                                 C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                 C
-C  Source : Pascal Simon ( Meteo, CNRM )                          C
-C  Adaptation : A.A. (LGGE)                                       C
-C  Derniere Modif : 19/11/95 LAST                                 C
-C                                                                 C
-C  sont les arguments d'entree pour le s-pg                       C
-C                                                                 C
-C  argument de sortie du s-pg                                     C
-C                                                                 C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C Rem : Probleme aux poles il faut reecrire ce cas specifique
-C        Attention au sens de l'indexation
-C
-
-C
-C  parametres principaux du modele
-C
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-C
-C  Arguments :
-C  ----------
-C  dty : frequence fictive d'appel du transport
-C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
-c
-        INTEGER lon,lat,niv
-        INTEGER i,j,jv,k,kp,l,lp
-        INTEGER ntra
-c        PARAMETER (ntra = 1)
-c
-        REAL dtz
-        REAL w ( iip1,jjp1,llm )
-c
-C  moments: SM  total mass in each grid box
-C           S0  mass of tracer in each grid box
-C           Si  1rst order moment in i direction
-C
-      REAL SM(iip1,jjp1,llm)
-     +    ,S0(iip1,jjp1,llm,ntra)
-      REAL SSX(iip1,jjp1,llm,ntra)
-     +    ,SY(iip1,jjp1,llm,ntra)
-     +    ,SZ(iip1,jjp1,llm,ntra)
-     +    ,SSXX(iip1,jjp1,llm,ntra)
-     +    ,SSXY(iip1,jjp1,llm,ntra)
-     +    ,SSXZ(iip1,jjp1,llm,ntra)
-     +    ,SYY(iip1,jjp1,llm,ntra)
-     +    ,SYZ(iip1,jjp1,llm,ntra)
-     +    ,SZZ(iip1,jjp1,llm,ntra)
-C
-C  Local :
-C  -------
-C
-C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
-C  mass fluxes in kg
-C  declaration :
-C
-      REAL WGRI(iip1,jjp1,0:llm)
-
-C Rem : UGRI et VGRI ne sont pas utilises dans
-C  cette SUBROUTINE ( advection en z uniquement )
-C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
-C         attention a celui de WGRI
-C
-C  the moments F are similarly defined and used as temporary
-C  storage for portions of the grid boxes in transit
-C
-C  the moments Fij are used as temporary storage for
-C  portions of the grid boxes in transit at the current level
-C
-C  work arrays
-C
-C
-      REAL F0(iim,llm,ntra),FM(iim,llm)
-      REAL FX(iim,llm,ntra),FY(iim,llm,ntra)
-      REAL FZ(iim,llm,ntra)
-      REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra)
-      REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
-      REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
-      REAL S00(ntra)
-      REAL SM0             ! Just temporal variable
-C
-C  work arrays
-C
-      REAL ALF(iim),ALF1(iim)
-      REAL ALFQ(iim),ALF1Q(iim)
-      REAL ALF2(iim),ALF3(iim)
-      REAL ALF4(iim)
-      REAL TEMPTM          ! Just temporal variable
-      REAL SLPMAX,S1MAX,S1NEW,S2NEW
-c
-      REAL sqi,sqf
-      LOGICAL LIMIT
-
-      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
-      lat = jjp1        ! a cause des dim. differentes entre les
-      niv = llm         !       tab. S et VGRI 
-                    
-c-----------------------------------------------------------------
-C *** Test : diag de la qtite totale de traceur dans
-C            l'atmosphere avant l'advection en Y
-c 
-      sqi = 0.
-      sqf = 0.
-c
-      DO l = 1,llm
-         DO j = 1,jjp1
-           DO i = 1,iim
-              sqi = sqi + S0(i,j,l,ntra)
-           END DO
-         END DO
-      END DO
-      PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
-      PRINT*,'sqi=',sqi
-
-c-----------------------------------------------------------------
-C  Interface : adaptation nouveau modele
-C  -------------------------------------
-C
-C  Conversion des flux de masses en kg
-
-      DO l = 1,llm
-         DO j = 1,jjp1
-            DO i = 1,iip1  
-            wgri (i,j,llm+1-l) = w (i,j,l)  
-      END DO
-      END DO
-      END DO
-      do j=1,jjp1
-         do i=1,iip1
-            wgri(i,j,0)=0.
-         enddo
-      enddo
-c
-cAA rem : Je ne suis pas sur du signe  
-cAA       Je ne suis pas sur pour le 0:llm
-c
-c-----------------------------------------------------------------
-C---------------------- START HERE -------------------------------
-C
-C  boucle sur les latitudes
-C
-      DO K=1,LAT
-C
-C  place limits on appropriate moments before transport
-C      (if flux-limiting is to be applied)
-C
-      IF(.NOT.LIMIT) GO TO 101
-C
-      DO JV=1,NTRA
-      DO L=1,NIV
-         DO I=1,LON
-            IF(S0(I,K,L,JV)>0.) THEN
-              SLPMAX=S0(I,K,L,JV)
-              S1MAX =1.5*SLPMAX
-              S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
-              S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
-     +                     AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
-              SZ (I,K,L,JV)=S1NEW
-              SZZ(I,K,L,JV)=S2NEW
-              SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
-              SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
-            ELSE
-              SZ (I,K,L,JV)=0.
-              SZZ(I,K,L,JV)=0.
-              SSXZ(I,K,L,JV)=0.
-              SYZ(I,K,L,JV)=0.
-            ENDIF
-      END DO
-      END DO
-      END DO
-C
- 101  CONTINUE
-C
-C  boucle sur les niveaux intercouches de 1 a NIV-1
-C   (flux nul au sommet L=0 et a la base L=NIV)
-C
-C  calculate flux and moments between adjacent boxes
-C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
-C  1- create temporary moments/masses for partial boxes in transit
-C  2- reajusts moments remaining in the box
-C
-      DO L=1,NIV-1
-      LP=L+1
-C
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-           FM(I,L)=-WGRI(I,K,L)*DTZ
-           ALF(I)=FM(I,L)/SM(I,K,LP)
-           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
-         ELSE
-           FM(I,L)=WGRI(I,K,L)*DTZ
-           ALF(I)=FM(I,L)/SM(I,K,L)
-           SM(I,K,L)=SM(I,K,L)-FM(I,L)
-         ENDIF
-C
-         ALFQ (I)=ALF(I)*ALF(I)
-         ALF1 (I)=1.-ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-         ALF2 (I)=ALF1(I)-ALF(I)
-         ALF3 (I)=ALF(I)*ALFQ(I)
-         ALF4 (I)=ALF1(I)*ALF1Q(I)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-C
-           F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)*
-     +          ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
-           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
-           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
-           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
-           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
-           FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
-           FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
-           FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
-           FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
-           FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
-C
-           S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
-           SZ (I,K,LP,JV)=ALF1Q(I)
-     +                   *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
-           SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
-           SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
-           SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
-           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
-           SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
-           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
-           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
-           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
-C
-         ELSE
-C
-           F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV)
-     +           +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
-           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
-           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
-           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
-           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
-           FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
-           FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
-           FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
-           FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
-           FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
-C
-           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
-           SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
-           SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
-           SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
-           SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
-           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
-           SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
-           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
-           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
-           SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      END DO
-C
-C  puts the temporary moments Fi into appropriate neighboring boxes
-C
-      DO L=1,NIV-1
-      LP=L+1
-C
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-           SM(I,K,L)=SM(I,K,L)+FM(I,L)
-           ALF(I)=FM(I,L)/SM(I,K,L)
-         ELSE
-           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
-           ALF(I)=FM(I,L)/SM(I,K,LP)
-         ENDIF
-C
-         ALF1(I)=1.-ALF(I)
-         ALFQ(I)=ALF(I)*ALF(I)
-         ALF1Q(I)=ALF1(I)*ALF1(I)
-         ALF2(I)=ALF(I)*ALF1(I)
-         ALF3(I)=ALF1(I)-ALF(I)
-C
-      END DO
-C
-      DO JV=1,NTRA
-      DO I=1,LON
-C
-         IF(WGRI(I,K,L)<0.) THEN
-C
-           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
-           S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
-           SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV)
-     +        +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
-           SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV)
-     +                  +3.*TEMPTM
-           SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV)
-     +              +3.*(ALF1(I)*FX (I,L,JV)-ALF  (I)*SSX (I,K,L,JV))
-           SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV)
-     +              +3.*(ALF1(I)*FY (I,L,JV)-ALF  (I)*SY (I,K,L,JV))
-           SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
-           SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
-           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
-           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
-           SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
-C
-         ELSE
-C
-           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
-           S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
-           SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV)
-     +        +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
-           SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV)
-     +                   +3.*TEMPTM
-           SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV)
-     +                   +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
-           SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV)
-     +                   +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
-           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
-           SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
-           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
-           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
-           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
-C
-         ENDIF
-C
-      END DO
-      END DO
-C
-      END DO
-C
-C  fin de la boucle principale sur les latitudes
-C
-      END DO
-C
-      DO l = 1,llm
-      DO j = 1,jjp1
-          SM(iip1,j,l) = SM(1,j,l)
-          S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
-          SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
-          SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
-          SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
-      ENDDO
-      ENDDO
-c                                                                                C-------------------------------------------------------------
-C *** Test : diag de la qqtite totale de tarceur
-C            dans l'atmosphere avant l'advection en z
-       DO l = 1,llm
-       DO j = 1,jjp1
-       DO i = 1,iim
-          sqf = sqf + S0(i,j,l,ntra)
-       ENDDO
-       ENDDO
-       ENDDO
-       PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
-       PRINT*,'sqf=', sqf
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.f90	(revision 5105)
@@ -0,0 +1,379 @@
+
+! $Header$
+
+SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ &
+        ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+
+  IMPLICIT NONE
+
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                 C
+  !  second-order moments (SOM) advection of tracer in Z direction  C
+  !                                                                 C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !                                                                 C
+  !  Source : Pascal Simon ( Meteo, CNRM )                          C
+  !  Adaptation : A.A. (LGGE)                                       C
+  !  Derniere Modif : 19/11/95 LAST                                 C
+  !                                                                 C
+  !  sont les arguments d'entree pour le s-pg                       C
+  !                                                                 C
+  !  argument de sortie du s-pg                                     C
+  !                                                                 C
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !
+  ! Rem : Probleme aux poles il faut reecrire ce cas specifique
+  !    Attention au sens de l'indexation
+  !
+
+  !
+  !  parametres principaux du modele
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !  Arguments :
+  !  ----------
+  !  dty : frequence fictive d'appel du transport
+  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+  !
+    INTEGER :: lon,lat,niv
+    INTEGER :: i,j,jv,k,kp,l,lp
+    INTEGER :: ntra
+     ! PARAMETER (ntra = 1)
+  !
+    REAL :: dtz
+    REAL :: w ( iip1,jjp1,llm )
+  !
+  !  moments: SM  total mass in each grid box
+  !       S0  mass of tracer in each grid box
+  !       Si  1rst order moment in i direction
+  !
+  REAL :: SM(iip1,jjp1,llm) &
+        ,S0(iip1,jjp1,llm,ntra)
+  REAL :: SSX(iip1,jjp1,llm,ntra) &
+        ,SY(iip1,jjp1,llm,ntra) &
+        ,SZ(iip1,jjp1,llm,ntra) &
+        ,SSXX(iip1,jjp1,llm,ntra) &
+        ,SSXY(iip1,jjp1,llm,ntra) &
+        ,SSXZ(iip1,jjp1,llm,ntra) &
+        ,SYY(iip1,jjp1,llm,ntra) &
+        ,SYZ(iip1,jjp1,llm,ntra) &
+        ,SZZ(iip1,jjp1,llm,ntra)
+  !
+  !  Local :
+  !  -------
+  !
+  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+  !  mass fluxes in kg
+  !  declaration :
+  !
+  REAL :: WGRI(iip1,jjp1,0:llm)
+
+  ! Rem : UGRI et VGRI ne sont pas utilises dans
+  !  cette SUBROUTINE ( advection en z uniquement )
+  !  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+      ! attention a celui de WGRI
+  !
+  !  the moments F are similarly defined and used as temporary
+  !  storage for portions of the grid boxes in transit
+  !
+  !  the moments Fij are used as temporary storage for
+  !  portions of the grid boxes in transit at the current level
+  !
+  !  work arrays
+  !
+  !
+  REAL :: F0(iim,llm,ntra),FM(iim,llm)
+  REAL :: FX(iim,llm,ntra),FY(iim,llm,ntra)
+  REAL :: FZ(iim,llm,ntra)
+  REAL :: FXX(iim,llm,ntra),FXY(iim,llm,ntra)
+  REAL :: FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
+  REAL :: FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
+  REAL :: S00(ntra)
+  REAL :: SM0             ! Just temporal variable
+  !
+  !  work arrays
+  !
+  REAL :: ALF(iim),ALF1(iim)
+  REAL :: ALFQ(iim),ALF1Q(iim)
+  REAL :: ALF2(iim),ALF3(iim)
+  REAL :: ALF4(iim)
+  REAL :: TEMPTM          ! Just temporal variable
+  REAL :: SLPMAX,S1MAX,S1NEW,S2NEW
+  !
+  REAL :: sqi,sqf
+  LOGICAL :: LIMIT
+
+  lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+  lat = jjp1        ! a cause des dim. differentes entre les
+  niv = llm         !       tab. S et VGRI
+
+  !-----------------------------------------------------------------
+  ! *** Test : diag de la qtite totale de traceur dans
+         ! l'atmosphere avant l'advection en Y
+  !
+  sqi = 0.
+  sqf = 0.
+  !
+  DO l = 1,llm
+     DO j = 1,jjp1
+       DO i = 1,iim
+          sqi = sqi + S0(i,j,l,ntra)
+       END DO
+     END DO
+  END DO
+  PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
+  PRINT*,'sqi=',sqi
+
+  !-----------------------------------------------------------------
+  !  Interface : adaptation nouveau modele
+  !  -------------------------------------
+  !
+  !  Conversion des flux de masses en kg
+
+  DO l = 1,llm
+     DO j = 1,jjp1
+        DO i = 1,iip1
+        wgri (i,j,llm+1-l) = w (i,j,l)
+  END DO
+  END DO
+  END DO
+  do j=1,jjp1
+     do i=1,iip1
+        wgri(i,j,0)=0.
+     enddo
+  enddo
+  !
+  !AA rem : Je ne suis pas sur du signe
+  !AA       Je ne suis pas sur pour le 0:llm
+  !
+  !-----------------------------------------------------------------
+  !---------------------- START HERE -------------------------------
+  !
+  !  boucle sur les latitudes
+  !
+  DO K=1,LAT
+  !
+  !  place limits on appropriate moments before transport
+  !  (if flux-limiting is to be applied)
+  !
+  IF(.NOT.LIMIT) GO TO 101
+  !
+  DO JV=1,NTRA
+  DO L=1,NIV
+     DO I=1,LON
+        IF(S0(I,K,L,JV)>0.) THEN
+          SLPMAX=S0(I,K,L,JV)
+          S1MAX =1.5*SLPMAX
+          S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
+          S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , &
+                AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
+          SZ (I,K,L,JV)=S1NEW
+          SZZ(I,K,L,JV)=S2NEW
+          SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
+          SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+        ELSE
+          SZ (I,K,L,JV)=0.
+          SZZ(I,K,L,JV)=0.
+          SSXZ(I,K,L,JV)=0.
+          SYZ(I,K,L,JV)=0.
+        ENDIF
+  END DO
+  END DO
+  END DO
+  !
+ 101   CONTINUE
+  !
+  !  boucle sur les niveaux intercouches de 1 a NIV-1
+  !   (flux nul au sommet L=0 et a la base L=NIV)
+  !
+  !  calculate flux and moments between adjacent boxes
+  ! (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+  !  1- create temporary moments/masses for partial boxes in transit
+  !  2- reajusts moments remaining in the box
+  !
+  DO L=1,NIV-1
+  LP=L+1
+  !
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+       FM(I,L)=-WGRI(I,K,L)*DTZ
+       ALF(I)=FM(I,L)/SM(I,K,LP)
+       SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+     ELSE
+       FM(I,L)=WGRI(I,K,L)*DTZ
+       ALF(I)=FM(I,L)/SM(I,K,L)
+       SM(I,K,L)=SM(I,K,L)-FM(I,L)
+     ENDIF
+  !
+     ALFQ (I)=ALF(I)*ALF(I)
+     ALF1 (I)=1.-ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+     ALF2 (I)=ALF1(I)-ALF(I)
+     ALF3 (I)=ALF(I)*ALFQ(I)
+     ALF4 (I)=ALF1(I)*ALF1Q(I)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+  !
+       F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* &
+             ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
+       FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
+       FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
+       FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
+       FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
+       FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
+       FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
+       FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
+       FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
+       FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
+  !
+       S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
+       SZ (I,K,LP,JV)=ALF1Q(I) &
+             *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
+       SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
+       SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
+       SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
+       SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
+       SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
+       SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
+       SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
+       SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
+  !
+     ELSE
+  !
+       F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) &
+             +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
+       FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
+       FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
+       FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
+       FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
+       FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
+       FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
+       FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
+       FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
+       FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
+  !
+       S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
+       SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
+       SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
+       SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
+       SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
+       SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
+       SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
+       SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
+       SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
+       SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  END DO
+  !
+  !  puts the temporary moments Fi into appropriate neighboring boxes
+  !
+  DO L=1,NIV-1
+  LP=L+1
+  !
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+       SM(I,K,L)=SM(I,K,L)+FM(I,L)
+       ALF(I)=FM(I,L)/SM(I,K,L)
+     ELSE
+       SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+       ALF(I)=FM(I,L)/SM(I,K,LP)
+     ENDIF
+  !
+     ALF1(I)=1.-ALF(I)
+     ALFQ(I)=ALF(I)*ALF(I)
+     ALF1Q(I)=ALF1(I)*ALF1(I)
+     ALF2(I)=ALF(I)*ALF1(I)
+     ALF3(I)=ALF1(I)-ALF(I)
+  !
+  END DO
+  !
+  DO JV=1,NTRA
+  DO I=1,LON
+  !
+     IF(WGRI(I,K,L)<0.) THEN
+  !
+       TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+       S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+       SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) &
+             +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
+       SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) &
+             +3.*TEMPTM
+       SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) &
+             +3.*(ALF1(I)*FX (I,L,JV)-ALF  (I)*SSX (I,K,L,JV))
+       SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) &
+             +3.*(ALF1(I)*FY (I,L,JV)-ALF  (I)*SY (I,K,L,JV))
+       SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
+       SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
+       SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
+       SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
+       SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
+  !
+     ELSE
+  !
+       TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+       S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+       SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) &
+             +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
+       SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) &
+             +3.*TEMPTM
+       SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) &
+             +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
+       SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) &
+             +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
+       SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
+       SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
+       SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
+       SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
+       SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
+  !
+     ENDIF
+  !
+  END DO
+  END DO
+  !
+  END DO
+  !
+  !  fin de la boucle principale sur les latitudes
+  !
+  END DO
+  !
+  DO l = 1,llm
+  DO j = 1,jjp1
+      SM(iip1,j,l) = SM(1,j,l)
+      S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+      SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+      SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+      SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+  ENDDO
+  ENDDO
+                                                                             ! C-------------------------------------------------------------
+  ! *** Test : diag de la qqtite totale de tarceur
+         ! dans l'atmosphere avant l'advection en z
+   DO l = 1,llm
+   DO j = 1,jjp1
+   DO i = 1,iim
+      sqf = sqf + S0(i,j,l,ntra)
+   ENDDO
+   ENDDO
+   ENDDO
+   PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+   PRINT*,'sqf=', sqf
+
+  RETURN
+END SUBROUTINE ADVZP
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.F	(revision 5104)
+++ 	(revision )
@@ -1,57 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:   P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c     calcul de la fonction de Bernouilli aux niveaux s  .....
-c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
-c          bern       est un  argument de sortie pour le s-pg  ......
-c
-c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
-c                              energ.cinet.)
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c   Decalrations:
-c   -------------
-c
-      include "dimensions.h"
-      include "paramet.h"
-c
-c   Arguments:
-c   ----------
-c
-      INTEGER nlay,ngrid
-      REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay)
-c
-c   Local:
-c   ------
-c
-      INTEGER   ijl
-c
-c-----------------------------------------------------------------------
-c   calcul de Bernouilli:
-c   ---------------------
-c
-      DO ijl = 1,ngrid*nlay
-         pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
-      END DO
-c
-c-----------------------------------------------------------------------
-c   filtre:
-c   -------
-c
-      CALL filtreg( pbern, jjp1, llm, 2,1, .TRUE., 1 )
-c
-c-----------------------------------------------------------------------
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.f90	(revision 5105)
@@ -0,0 +1,57 @@
+
+! $Header$
+
+SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  ! calcul de la fonction de Bernouilli aux niveaux s  .....
+  ! phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+  !      bern       est un  argument de sortie pour le s-pg  ......
+  !
+  !    fonction de Bernouilli = bern = filtre de( geopotentiel +
+  !                          energ.cinet.)
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !   Decalrations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !   Arguments:
+  !   ----------
+  !
+  INTEGER :: nlay,ngrid
+  REAL :: pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay)
+  !
+  !   Local:
+  !   ------
+  !
+  INTEGER :: ijl
+  !
+  !-----------------------------------------------------------------------
+  !   calcul de Bernouilli:
+  !   ---------------------
+  !
+  DO ijl = 1,ngrid*nlay
+     pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
+  END DO
+  !
+  !-----------------------------------------------------------------------
+  !   filtre:
+  !   -------
+  !
+  CALL filtreg( pbern, jjp1, llm, 2,1, .TRUE., 1 )
+  !
+  !-----------------------------------------------------------------------
+  RETURN
+END SUBROUTINE bernoui
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.F	(revision 5104)
+++ 	(revision )
@@ -1,62 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE convflu( xflu,yflu,nbniv,convfl )
-c
-c  P. Le Van
-c
-c
-c    *******************************************************************
-c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
-c      composantes xflu et yflu ,variables extensives .  ......
-c    *******************************************************************
-c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
-c      convfl                est  un argument de sortie pour le s-pg .
-c
-c     njxflu  est le nombre de lignes de latitude de xflu, 
-c     ( = jjm ou jjp1 )
-c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      REAL       xflu,yflu,convfl,convpn,convps
-      INTEGER    l,ij,nbniv
-      DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) ,
-     *         convfl( ip1jmp1,nbniv )
-c
-      REAL       SSUM
-c
-c
-      INCLUDE "comgeom.h"
-c
-      DO l = 1,nbniv
-c
-      DO ij = iip2, ip1jm - 1
-      convfl( ij + 1,l ) =  xflu(   ij,l ) - xflu( ij +  1,l )   +
-     *                      yflu(ij +1,l ) - yflu( ij -iim,l )
-      END DO
-c
-c
-
-c     ....  correction pour  convfl( 1,j,l)  ......
-c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
-c
-CDIR$ IVDEP
-      DO ij = iip2,ip1jm,iip1
-      convfl( ij,l ) = convfl( ij + iim,l )
-      END DO
-c
-c     ......  calcul aux poles  .......
-c
-      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
-      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
-      DO ij = 1,iip1
-      convfl(     ij   ,l ) = convpn * aire(   ij     ) / apoln
-      convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.f90	(revision 5105)
@@ -0,0 +1,62 @@
+
+! $Header$
+
+SUBROUTINE convflu( xflu,yflu,nbniv,convfl )
+  !
+  !  P. Le Van
+  !
+  !
+  !    *******************************************************************
+  !  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+  !  composantes xflu et yflu ,variables extensives .  ......
+  !    *******************************************************************
+  !  xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+  !  convfl                est  un argument de sortie pour le s-pg .
+  !
+  ! njxflu  est le nombre de lignes de latitude de xflu,
+  ! ( = jjm ou jjp1 )
+  ! nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  REAL :: xflu,yflu,convfl,convpn,convps
+  INTEGER :: l,ij,nbniv
+  DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , &
+        convfl( ip1jmp1,nbniv )
+  !
+  REAL :: SSUM
+  !
+  !
+  INCLUDE "comgeom.h"
+  !
+  DO l = 1,nbniv
+  !
+  DO ij = iip2, ip1jm - 1
+  convfl( ij + 1,l ) =  xflu(   ij,l ) - xflu( ij +  1,l )   + &
+        yflu(ij +1,l ) - yflu( ij -iim,l )
+  END DO
+  !
+  !
+
+  ! ....  correction pour  convfl( 1,j,l)  ......
+  ! ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+  !
+  !DIR$ IVDEP
+  DO ij = iip2,ip1jm,iip1
+  convfl( ij,l ) = convfl( ij + iim,l )
+  END DO
+  !
+  ! ......  calcul aux poles  .......
+  !
+  convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+  convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+  DO ij = 1,iip1
+  convfl(     ij   ,l ) = convpn * aire(   ij     ) / apoln
+  convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE convflu
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/coordij.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/coordij.F	(revision 5104)
+++ 	(revision )
@@ -1,48 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE coordij(lon,lat,ilon,jlat)
-
-c=======================================================================
-c
-c   calcul des coordonnees i et j de la maille scalaire dans
-c   laquelle se trouve le point (lon,lat) en radian
-c
-c=======================================================================
-
-      USE comconst_mod, ONLY: pi
-      
-      IMPLICIT NONE
-      REAL lon,lat
-      INTEGER ilon,jlat
-      INTEGER i,j
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-
-      real zlon,zlat
-
-      zlon=lon*pi/180.
-      zlat=lat*pi/180.
-
-      DO i=1,iim+1
-         IF (rlonu(i)>zlon) THEN
-            ilon=i
-            GOTO 10
-         ENDIF
-      ENDDO
-10    CONTINUE
-
-      j=0
-      DO j=1,jjm
-         IF(rlatv(j)<zlat) THEN
-            jlat=j
-            GOTO 20
-         ENDIF
-      ENDDO
-20    CONTINUE
-      IF(j==0) j=jjm+1
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/coordij.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/coordij.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/coordij.f90	(revision 5105)
@@ -0,0 +1,48 @@
+
+! $Header$
+
+SUBROUTINE coordij(lon,lat,ilon,jlat)
+
+  !=======================================================================
+  !
+  !   calcul des coordonnees i et j de la maille scalaire dans
+  !   laquelle se trouve le point (lon,lat) en radian
+  !
+  !=======================================================================
+
+  USE comconst_mod, ONLY: pi
+
+  IMPLICIT NONE
+  REAL :: lon,lat
+  INTEGER :: ilon,jlat
+  INTEGER :: i,j
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  real :: zlon,zlat
+
+  zlon=lon*pi/180.
+  zlat=lat*pi/180.
+
+  DO i=1,iim+1
+     IF (rlonu(i)>zlon) THEN
+        ilon=i
+        GOTO 10
+     ENDIF
+  ENDDO
+10   CONTINUE
+
+  j=0
+  DO j=1,jjm
+     IF(rlatv(j)<zlat) THEN
+        jlat=j
+        GOTO 20
+     ENDIF
+  ENDDO
+20   CONTINUE
+  IF(j==0) j=jjm+1
+
+  RETURN
+END SUBROUTINE coordij
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.F	(revision 5104)
+++ 	(revision )
@@ -1,332 +1,0 @@
-
-! $Id$
-
-C======================================================================
-      SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime
-     e  , ucov    , vcov , ps, p ,pk , teta , q, ql)
-C======================================================================
-C
-C Purpose:
-C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
-C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
-C    changements. Ces valeurs sont moyennees sur la surface de tout
-C    le globe et sont exprime en W/2 et kg/s/m2
-C    Outil pour diagnostiquer la conservation de l'energie
-C    et de la masse dans la dynamique.
-C
-C
-c======================================================================
-C Arguments: 
-C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
-C iprt----input-I-  PRINT level ( <=1 : no PRINT)
-C idiag---input-I- indice dans lequel sera range les nouveaux
-C                  bilans d' entalpie et de masse
-C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
-C                 sont compare au bilan de d'enthalpie de masse de
-C                 l'indice numero idiag2 
-C                 Cas parriculier : si idiag2=0, pas de comparaison, on
-c                 sort directement les bilans d'enthalpie et de masse 
-C dtime----input-R- time step (s)
-C uconv, vconv-input-R- vents covariants (m/s)
-C ps-------input-R- Surface pressure (Pa)
-C p--------input-R- pressure at the interfaces
-C pk-------input-R- pk= (p/Pref)**kappa
-c teta-----input-R- potential temperature (K)
-c q--------input-R- vapeur d'eau (kg/kg)
-c ql-------input-R- liquid watter (kg/kg)
-c aire-----input-R- mesh surafce (m2)
-c
-C the following total value are computed by UNIT of earth surface
-C
-C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
-c            change (J/m2) during one time step (dtime) for the whole 
-C            atmosphere (air, watter vapour, liquid and solid)
-C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
-C           total watter (kg/m2) change during one time step (dtime),
-C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
-C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
-C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
-C
-C
-C J.L. Dufresne, July 2002
-c======================================================================
- 
-      USE control_mod, ONLY: planet_type
-      
-      IMPLICIT NONE
-C
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INCLUDE "iniprint.h"
-
-! Ehouarn: for now set these parameters to what is in Earth physics...
-!          (cf ../phylmd/suphel.h)
-!          this should be generalized...
-      REAL,PARAMETER :: RCPD=
-     &               3.5*(1000.*(6.0221367E+23*1.380658E-23)/28.9644)
-      REAL,PARAMETER :: RCPV=
-     &               4.*(1000.*(6.0221367E+23*1.380658E-23)/18.0153)
-      REAL,PARAMETER :: RCS=RCPV
-      REAL,PARAMETER :: RCW=RCPV
-      REAL,PARAMETER :: RLSTT=2.8345E+6
-      REAL,PARAMETER :: RLVTT=2.5008E+6
-
-C
-      INTEGER imjmp1
-      PARAMETER( imjmp1=iim*jjp1)
-c     Input variables
-      CHARACTER*15 tit
-      INTEGER iprt,idiag, idiag2
-      REAL dtime
-      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
-      REAL ps(ip1jmp1)                       ! pression  au sol
-      REAL p (ip1jmp1,llmp1  )  ! pression aux interfac.des couches
-      REAL pk (ip1jmp1,llm  )  ! = (p/Pref)**kappa
-      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
-      REAL q(ip1jmp1,llm)               ! champs eau vapeur
-      REAL ql(ip1jmp1,llm)               ! champs eau liquide
-
-
-c     Output variables
-      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
-C
-C     Local variables
-c
-      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
-     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
-c h_vcol_tot--  total enthalpy of vertical air column 
-C            (air with watter vapour, liquid and solid) (J/m2)
-c h_dair_tot-- total enthalpy of dry air (J/m2)
-c h_qw_tot----  total enthalpy of watter vapour (J/m2)
-c h_ql_tot----  total enthalpy of liquid watter (J/m2)
-c h_qs_tot----  total enthalpy of solid watter  (J/m2)
-c qw_tot------  total mass of watter vapour (kg/m2)
-c ql_tot------  total mass of liquid watter (kg/m2)
-c qs_tot------  total mass of solid watter (kg/m2)
-c ec_tot------  total cinetic energy (kg/m2)
-C
-      REAL masse(ip1jmp1,llm)                ! masse d'air
-      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
-      REAL ecin(ip1jmp1,llm)
-
-      REAL zaire(imjmp1)
-      REAL zps(imjmp1)
-      REAL zairm(imjmp1,llm)
-      REAL zecin(imjmp1,llm)
-      REAL zpaprs(imjmp1,llm)
-      REAL zpk(imjmp1,llm)
-      REAL zt(imjmp1,llm)
-      REAL zh(imjmp1,llm)
-      REAL zqw(imjmp1,llm)
-      REAL zql(imjmp1,llm)
-      REAL zqs(imjmp1,llm)
-
-      REAL  zqw_col(imjmp1)
-      REAL  zql_col(imjmp1)
-      REAL  zqs_col(imjmp1)
-      REAL  zec_col(imjmp1)
-      REAL  zh_dair_col(imjmp1)
-      REAL  zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1)
-C
-      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
-C
-      REAL airetot, zcpvap, zcwat, zcice
-C
-      INTEGER i, k, jj, ij , l ,ip1jjm1
-C
-      INTEGER ndiag     ! max number of diagnostic in parallel
-      PARAMETER (ndiag=10)
-      integer pas(ndiag)
-      save pas
-      data pas/ndiag*0/
-C     
-      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
-     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
-     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
-      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
-     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
-
-
-      IF (planet_type=="earth") THEN
-      
-c======================================================================
-C     Compute Kinetic enrgy
-      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
-      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
-      CALL massdair( p, masse )
-c======================================================================
-C
-C
-      PRINT*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?'
-      return
-C     On ne garde les donnees que dans les colonnes i=1,iim
-      DO jj = 1,jjp1
-        ip1jjm1=iip1*(jj-1)
-        DO ij =  1,iim
-          i=iim*(jj-1)+ij
-          zaire(i)=aire(ij+ip1jjm1)
-          zps(i)=ps(ij+ip1jjm1)
-        ENDDO 
-      ENDDO 
-C 3D arrays
-      DO l  =  1, llm
-        DO jj = 1,jjp1
-          ip1jjm1=iip1*(jj-1)
-          DO ij =  1,iim
-            i=iim*(jj-1)+ij
-            zairm(i,l) = masse(ij+ip1jjm1,l)
-            zecin(i,l) = ecin(ij+ip1jjm1,l)
-            zpaprs(i,l) = p(ij+ip1jjm1,l)
-            zpk(i,l) = pk(ij+ip1jjm1,l)
-            zh(i,l) = teta(ij+ip1jjm1,l)
-            zqw(i,l) = q(ij+ip1jjm1,l)
-            zql(i,l) = ql(ij+ip1jjm1,l)
-            zqs(i,l) = 0.
-          ENDDO 
-        ENDDO 
-      ENDDO 
-C
-C     Reset variables
-      DO i = 1, imjmp1
-        zqw_col(i)=0.
-        zql_col(i)=0.
-        zqs_col(i)=0.
-        zec_col(i) = 0.
-        zh_dair_col(i) = 0.
-        zh_qw_col(i) = 0.
-        zh_ql_col(i) = 0.
-        zh_qs_col(i) = 0.
-      ENDDO
-C
-      zcpvap=RCPV
-      zcwat=RCW
-      zcice=RCS
-C
-C     Compute vertical sum for each atmospheric column
-C     ================================================
-      DO k = 1, llm
-        DO i = 1, imjmp1
-C         Watter mass
-          zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k)
-          zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k)
-          zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k)
-C         Cinetic Energy
-          zec_col(i) =  zec_col(i)
-     $        +zecin(i,k)*zairm(i,k)
-C         Air enthalpy
-          zt(i,k)= zh(i,k) * zpk(i,k) / RCPD
-          zh_dair_col(i) = zh_dair_col(i)
-     $        + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k)
-          zh_qw_col(i) = zh_qw_col(i)
-     $        + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) 
-          zh_ql_col(i) = zh_ql_col(i)
-     $        + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) 
-     $        - RLVTT*zql(i,k)*zairm(i,k)
-          zh_qs_col(i) = zh_qs_col(i)
-     $        + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) 
-     $        - RLSTT*zqs(i,k)*zairm(i,k)
-
-        END DO
-      ENDDO
-C
-C     Mean over the planete surface
-C     =============================
-      qw_tot = 0.
-      ql_tot = 0.
-      qs_tot = 0.
-      ec_tot = 0.
-      h_vcol_tot = 0.
-      h_dair_tot = 0.
-      h_qw_tot = 0.
-      h_ql_tot = 0.
-      h_qs_tot = 0.
-      airetot=0.
-C
-      do i=1,imjmp1
-        qw_tot = qw_tot + zqw_col(i)
-        ql_tot = ql_tot + zql_col(i)
-        qs_tot = qs_tot + zqs_col(i)
-        ec_tot = ec_tot + zec_col(i)
-        h_dair_tot = h_dair_tot + zh_dair_col(i)
-        h_qw_tot = h_qw_tot + zh_qw_col(i)
-        h_ql_tot = h_ql_tot + zh_ql_col(i)
-        h_qs_tot = h_qs_tot + zh_qs_col(i)
-        airetot=airetot+zaire(i)
-      END DO
-C
-      qw_tot = qw_tot/airetot
-      ql_tot = ql_tot/airetot
-      qs_tot = qs_tot/airetot
-      ec_tot = ec_tot/airetot
-      h_dair_tot = h_dair_tot/airetot
-      h_qw_tot = h_qw_tot/airetot
-      h_ql_tot = h_ql_tot/airetot
-      h_qs_tot = h_qs_tot/airetot
-C
-      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
-C
-C     Compute the change of the atmospheric state compare to the one 
-C     stored in "idiag2", and convert it in flux. THis computation
-C     is performed IF idiag2 /= 0 and IF it is not the first CALL
-c     for "idiag"
-C     ===================================
-C
-      IF ( (idiag2>0) .and. (pas(idiag2) /= 0) ) THEN
-        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
-        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
-        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
-        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
-        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
-        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
-        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
-        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
-        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
-        d_qt = d_qw + d_ql + d_qs
-      ELSE 
-        d_h_vcol = 0.
-        d_h_dair = 0.
-        d_h_qw   = 0.
-        d_h_ql   = 0.
-        d_h_qs   = 0. 
-        d_qw     = 0.
-        d_ql     = 0.
-        d_qs     = 0.
-        d_ec     = 0.
-        d_qt     = 0.
-      ENDIF 
-C
-      IF (iprt>=2) THEN
-        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
- 9000   format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15
-     $      ,1i6,10(1pE14.6))
-        WRITE(6,9001) tit,pas(idiag), d_h_vcol
- 9001   format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
-        WRITE(6,9002) tit,pas(idiag), d_ec
- 9002   format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
-C        WRITE(6,9003) tit,pas(idiag), ec_tot
- 9003   format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6))
-        WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec
- 9004   format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2))
-      END IF 
-C
-C     Store the new atmospheric state in "idiag"
-C
-      pas(idiag)=pas(idiag)+1
-      h_vcol_pre(idiag)  = h_vcol_tot
-      h_dair_pre(idiag) = h_dair_tot
-      h_qw_pre(idiag)   = h_qw_tot
-      h_ql_pre(idiag)   = h_ql_tot
-      h_qs_pre(idiag)   = h_qs_tot
-      qw_pre(idiag)     = qw_tot
-      ql_pre(idiag)     = ql_tot
-      qs_pre(idiag)     = qs_tot
-      ec_pre (idiag)    = ec_tot
-C
-!#else
-      ELSE
-        write(lunout,*)'diagedyn: set to function with Earth parameters'
-      ENDIF ! of if (planet_type=="earth")
-!#endif
-      RETURN
-      END 
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.f90	(revision 5105)
@@ -0,0 +1,330 @@
+
+! $Id$
+
+!======================================================================
+SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime &
+        , ucov    , vcov , ps, p ,pk , teta , q, ql)
+  !======================================================================
+  !
+  ! Purpose:
+  !    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+  !    et calcul le flux de chaleur et le flux d'eau necessaire a ces
+  !    changements. Ces valeurs sont moyennees sur la surface de tout
+  !    le globe et sont exprime en W/2 et kg/s/m2
+  !    Outil pour diagnostiquer la conservation de l'energie
+  !    et de la masse dans la dynamique.
+  !
+  !
+  !======================================================================
+  ! Arguments:
+  ! tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+  ! iprt----input-I-  PRINT level ( <=1 : no PRINT)
+  ! idiag---input-I- indice dans lequel sera range les nouveaux
+  !              bilans d' entalpie et de masse
+  ! idiag2--input-I-les nouveaux bilans d'entalpie et de masse
+  !             sont compare au bilan de d'enthalpie de masse de
+  !             l'indice numero idiag2
+  !             Cas parriculier : si idiag2=0, pas de comparaison, on
+  !             sort directement les bilans d'enthalpie et de masse
+  ! dtime----input-R- time step (s)
+  ! uconv, vconv-input-R- vents covariants (m/s)
+  ! ps-------input-R- Surface pressure (Pa)
+  ! p--------input-R- pressure at the interfaces
+  ! pk-------input-R- pk= (p/Pref)**kappa
+  ! teta-----input-R- potential temperature (K)
+  ! q--------input-R- vapeur d'eau (kg/kg)
+  ! ql-------input-R- liquid watter (kg/kg)
+  ! aire-----input-R- mesh surafce (m2)
+  !
+  ! the following total value are computed by UNIT of earth surface
+  !
+  ! d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy
+  !        change (J/m2) during one time step (dtime) for the whole
+  !        atmosphere (air, watter vapour, liquid and solid)
+  ! d_qt------output-R- total water mass flux (kg/m2/s) defined as the
+  !       total watter (kg/m2) change during one time step (dtime),
+  ! d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+  ! d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+  ! d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+  !
+  !
+  ! J.L. Dufresne, July 2002
+  !======================================================================
+
+  USE control_mod, ONLY: planet_type
+
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "iniprint.h"
+
+  ! Ehouarn: for now set these parameters to what is in Earth physics...
+       ! (cf ../phylmd/suphel.h)
+       ! this should be generalized...
+  REAL,PARAMETER :: RCPD= &
+        3.5*(1000.*(6.0221367E+23*1.380658E-23)/28.9644)
+  REAL,PARAMETER :: RCPV= &
+        4.*(1000.*(6.0221367E+23*1.380658E-23)/18.0153)
+  REAL,PARAMETER :: RCS=RCPV
+  REAL,PARAMETER :: RCW=RCPV
+  REAL,PARAMETER :: RLSTT=2.8345E+6
+  REAL,PARAMETER :: RLVTT=2.5008E+6
+
+  !
+  INTEGER :: imjmp1
+  PARAMETER( imjmp1=iim*jjp1)
+  ! Input variables
+  CHARACTER(len=15) :: tit
+  INTEGER :: iprt,idiag, idiag2
+  REAL :: dtime
+  REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+  REAL :: ps(ip1jmp1)                       ! pression  au sol
+  REAL :: p (ip1jmp1,llmp1  )  ! pression aux interfac.des couches
+  REAL :: pk (ip1jmp1,llm  )  ! = (p/Pref)**kappa
+  REAL :: teta(ip1jmp1,llm)                 ! temperature potentielle
+  REAL :: q(ip1jmp1,llm)               ! champs eau vapeur
+  REAL :: ql(ip1jmp1,llm)               ! champs eau liquide
+
+
+  ! Output variables
+  REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+  !
+  ! Local variables
+  !
+  REAL :: h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot &
+        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+  ! h_vcol_tot--  total enthalpy of vertical air column
+         ! (air with watter vapour, liquid and solid) (J/m2)
+  ! h_dair_tot-- total enthalpy of dry air (J/m2)
+  ! h_qw_tot----  total enthalpy of watter vapour (J/m2)
+  ! h_ql_tot----  total enthalpy of liquid watter (J/m2)
+  ! h_qs_tot----  total enthalpy of solid watter  (J/m2)
+  ! qw_tot------  total mass of watter vapour (kg/m2)
+  ! ql_tot------  total mass of liquid watter (kg/m2)
+  ! qs_tot------  total mass of solid watter (kg/m2)
+  ! ec_tot------  total cinetic energy (kg/m2)
+  !
+  REAL :: masse(ip1jmp1,llm)                ! masse d'air
+  REAL :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+  REAL :: ecin(ip1jmp1,llm)
+
+  REAL :: zaire(imjmp1)
+  REAL :: zps(imjmp1)
+  REAL :: zairm(imjmp1,llm)
+  REAL :: zecin(imjmp1,llm)
+  REAL :: zpaprs(imjmp1,llm)
+  REAL :: zpk(imjmp1,llm)
+  REAL :: zt(imjmp1,llm)
+  REAL :: zh(imjmp1,llm)
+  REAL :: zqw(imjmp1,llm)
+  REAL :: zql(imjmp1,llm)
+  REAL :: zqs(imjmp1,llm)
+
+  REAL :: zqw_col(imjmp1)
+  REAL :: zql_col(imjmp1)
+  REAL :: zqs_col(imjmp1)
+  REAL :: zec_col(imjmp1)
+  REAL :: zh_dair_col(imjmp1)
+  REAL :: zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1)
+  !
+  REAL :: d_h_dair, d_h_qw, d_h_ql, d_h_qs
+  !
+  REAL :: airetot, zcpvap, zcwat, zcice
+  !
+  INTEGER :: i, k, jj, ij , l ,ip1jjm1
+  !
+  INTEGER :: ndiag     ! max number of diagnostic in parallel
+  PARAMETER (ndiag=10)
+  integer :: pas(ndiag)
+  save pas
+  data pas/ndiag*0/
+  !
+  REAL :: h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) &
+        , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) &
+        , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+  SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre &
+        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+
+
+  IF (planet_type=="earth") THEN
+
+  !======================================================================
+  ! Compute Kinetic enrgy
+  CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+  CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+  CALL massdair( p, masse )
+  !======================================================================
+  !
+  !
+  PRINT*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?'
+  return
+  ! On ne garde les donnees que dans les colonnes i=1,iim
+  DO jj = 1,jjp1
+    ip1jjm1=iip1*(jj-1)
+    DO ij =  1,iim
+      i=iim*(jj-1)+ij
+      zaire(i)=aire(ij+ip1jjm1)
+      zps(i)=ps(ij+ip1jjm1)
+    ENDDO
+  ENDDO
+  ! 3D arrays
+  DO l  =  1, llm
+    DO jj = 1,jjp1
+      ip1jjm1=iip1*(jj-1)
+      DO ij =  1,iim
+        i=iim*(jj-1)+ij
+        zairm(i,l) = masse(ij+ip1jjm1,l)
+        zecin(i,l) = ecin(ij+ip1jjm1,l)
+        zpaprs(i,l) = p(ij+ip1jjm1,l)
+        zpk(i,l) = pk(ij+ip1jjm1,l)
+        zh(i,l) = teta(ij+ip1jjm1,l)
+        zqw(i,l) = q(ij+ip1jjm1,l)
+        zql(i,l) = ql(ij+ip1jjm1,l)
+        zqs(i,l) = 0.
+      ENDDO
+    ENDDO
+  ENDDO
+  !
+  ! Reset variables
+  DO i = 1, imjmp1
+    zqw_col(i)=0.
+    zql_col(i)=0.
+    zqs_col(i)=0.
+    zec_col(i) = 0.
+    zh_dair_col(i) = 0.
+    zh_qw_col(i) = 0.
+    zh_ql_col(i) = 0.
+    zh_qs_col(i) = 0.
+  ENDDO
+  !
+  zcpvap=RCPV
+  zcwat=RCW
+  zcice=RCS
+  !
+  ! Compute vertical sum for each atmospheric column
+  ! ================================================
+  DO k = 1, llm
+    DO i = 1, imjmp1
+      ! Watter mass
+      zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k)
+      zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k)
+      zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k)
+      ! Cinetic Energy
+      zec_col(i) =  zec_col(i) &
+            +zecin(i,k)*zairm(i,k)
+      ! Air enthalpy
+      zt(i,k)= zh(i,k) * zpk(i,k) / RCPD
+      zh_dair_col(i) = zh_dair_col(i) &
+            + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k)
+      zh_qw_col(i) = zh_qw_col(i) &
+            + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k)
+      zh_ql_col(i) = zh_ql_col(i) &
+            + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) &
+            - RLVTT*zql(i,k)*zairm(i,k)
+      zh_qs_col(i) = zh_qs_col(i) &
+            + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) &
+            - RLSTT*zqs(i,k)*zairm(i,k)
+
+    END DO
+  ENDDO
+  !
+  ! Mean over the planete surface
+  ! =============================
+  qw_tot = 0.
+  ql_tot = 0.
+  qs_tot = 0.
+  ec_tot = 0.
+  h_vcol_tot = 0.
+  h_dair_tot = 0.
+  h_qw_tot = 0.
+  h_ql_tot = 0.
+  h_qs_tot = 0.
+  airetot=0.
+  !
+  do i=1,imjmp1
+    qw_tot = qw_tot + zqw_col(i)
+    ql_tot = ql_tot + zql_col(i)
+    qs_tot = qs_tot + zqs_col(i)
+    ec_tot = ec_tot + zec_col(i)
+    h_dair_tot = h_dair_tot + zh_dair_col(i)
+    h_qw_tot = h_qw_tot + zh_qw_col(i)
+    h_ql_tot = h_ql_tot + zh_ql_col(i)
+    h_qs_tot = h_qs_tot + zh_qs_col(i)
+    airetot=airetot+zaire(i)
+  END DO
+  !
+  qw_tot = qw_tot/airetot
+  ql_tot = ql_tot/airetot
+  qs_tot = qs_tot/airetot
+  ec_tot = ec_tot/airetot
+  h_dair_tot = h_dair_tot/airetot
+  h_qw_tot = h_qw_tot/airetot
+  h_ql_tot = h_ql_tot/airetot
+  h_qs_tot = h_qs_tot/airetot
+  !
+  h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+  !
+  ! Compute the change of the atmospheric state compare to the one
+  ! stored in "idiag2", and convert it in flux. THis computation
+  ! is performed IF idiag2 /= 0 and IF it is not the first CALL
+  ! for "idiag"
+  ! ===================================
+  !
+  IF ( (idiag2>0) .and. (pas(idiag2) /= 0) ) THEN
+    d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+    d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+    d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+    d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime
+    d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime
+    d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+    d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+    d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+    d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+    d_qt = d_qw + d_ql + d_qs
+  ELSE
+    d_h_vcol = 0.
+    d_h_dair = 0.
+    d_h_qw   = 0.
+    d_h_ql   = 0.
+    d_h_qs   = 0.
+    d_qw     = 0.
+    d_ql     = 0.
+    d_qs     = 0.
+    d_ec     = 0.
+    d_qt     = 0.
+  ENDIF
+  !
+  IF (iprt>=2) THEN
+    WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 &
+              ,1i6,10(1pE14.6))
+    WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+    WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+     ! WRITE(6,9003) tit,pas(idiag), ec_tot
+ 9003   format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6))
+    WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec
+ 9004   format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+  END IF
+  !
+  ! Store the new atmospheric state in "idiag"
+  !
+  pas(idiag)=pas(idiag)+1
+  h_vcol_pre(idiag)  = h_vcol_tot
+  h_dair_pre(idiag) = h_dair_tot
+  h_qw_pre(idiag)   = h_qw_tot
+  h_ql_pre(idiag)   = h_ql_tot
+  h_qs_pre(idiag)   = h_qs_tot
+  qw_pre(idiag)     = qw_tot
+  ql_pre(idiag)     = ql_tot
+  qs_pre(idiag)     = qs_tot
+  ec_pre (idiag)    = ec_tot
+  !
+  ELSE
+    write(lunout,*)'diagedyn: set to function with Earth parameters'
+  ENDIF ! of if (planet_type=="earth")
+  RETURN
+END SUBROUTINE diagedyn
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.F	(revision 5104)
+++ 	(revision )
@@ -1,326 +1,0 @@
-! $Id: $
-      SUBROUTINE disvert_noterre
-
-c    Auteur :  F. Forget Y. Wanherdrick, P. Levan
-c    Nouvelle version 100% Mars !!
-c    On l'utilise aussi pour Venus et Titan, legerment modifiee.
-
-      use IOIPSL
-      USE comvert_mod, ONLY: ap,bp,aps,bps,presnivs,pseudoalt,
-     &                       nivsig,nivsigs,pa,preff,scaleheight
-      USE comconst_mod, ONLY: kappa
-      USE logic_mod, ONLY: hybrid
-
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "iniprint.h"
-c
-c=======================================================================
-c    Discretisation verticale en coordonnée hybride (ou sigma)
-c
-c=======================================================================
-c
-c   declarations:
-c   -------------
-c
-c
-      INTEGER l,ll
-      REAL snorm
-      REAL alpha,beta,gama,delta,deltaz
-      real quoi,quand
-      REAL zsig(llm),sig(llm+1)
-      INTEGER np,ierr
-      integer :: ierr1,ierr2,ierr3,ierr4
-      REAL x
-
-      REAL SSUM
-      EXTERNAL SSUM
-      real newsig 
-      REAL dz0,dz1,nhaut,sig1,esig,csig,zz
-      real tt,rr,gg, prevz
-      real s(llm),dsig(llm) 
-
-      integer iz 
-      real z, ps,p
-      character(len=*),parameter :: modname="disvert_noterre"
-
-c
-c-----------------------------------------------------------------------
-c
-! Initializations:
-!      pi=2.*ASIN(1.) ! already done in iniconst
-      
-      hybrid=.TRUE. ! default value for hybrid (ie: use hybrid coordinates)
-      CALL getin('hybrid',hybrid)
-      write(lunout,*) trim(modname),': hybrid=',hybrid
-
-! Ouverture possible de fichiers typiquement E.T.
-
-         open(99,file="esasig.def",status='old',form='formatted',
-     s   iostat=ierr2)
-         if(ierr2/=0) then
-              close(99)
-              open(99,file="z2sig.def",status='old',form='formatted',
-     s        iostat=ierr4)
-         endif
-
-c-----------------------------------------------------------------------
-c   cas 1 on lit les options dans esasig.def:
-c   ----------------------------------------
-
-      IF(ierr2==0) then
-
-c        Lecture de esasig.def :
-c        Systeme peu souple, mais qui respecte en theorie
-c        La conservation de l'energie (conversion Energie potentielle
-c        <-> energie cinetique, d'apres la note de Frederic Hourdin...
-
-         write(lunout,*)'*****************************'
-         write(lunout,*)'WARNING reading esasig.def'
-         write(lunout,*)'*****************************'
-         READ(99,*) scaleheight
-         READ(99,*) dz0
-         READ(99,*) dz1
-         READ(99,*) nhaut
-         CLOSE(99)
-
-         dz0=dz0/scaleheight
-         dz1=dz1/scaleheight
-
-         sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
-
-         esig=1.
-
-         do l=1,20
-            esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
-         enddo
-         csig=(1./sig1-1.)/(exp(esig)-1.)
-
-         DO L = 2, llm
-            zz=csig*(exp(esig*(l-1.))-1.)
-            sig(l) =1./(1.+zz)
-     &      * tanh(.5*(llm+1-l)/nhaut)
-         ENDDO
-         sig(1)=1.
-         sig(llm+1)=0.
-         quoi      = 1. + 2.* kappa
-         s( llm )  = 1.
-         s(llm-1) = quoi
-         IF( llm>2 )  THEN
-            DO  ll = 2, llm-1
-               l         = llm+1 - ll
-               quand     = sig(l+1)/ sig(l)
-               s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
-            ENDDO
-         END IF
-c
-         snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
-         DO l = 1, llm
-            s(l)    = s(l)/ snorm
-         ENDDO
-
-c-----------------------------------------------------------------------
-c   cas 2 on lit les options dans z2sig.def:
-c   ----------------------------------------
-
-      ELSE IF(ierr4==0) then
-         write(lunout,*)'****************************'
-         write(lunout,*)'Reading z2sig.def'
-         write(lunout,*)'****************************'
-
-         READ(99,*) scaleheight
-         do l=1,llm
-            read(99,*) zsig(l)
-         END DO
-         CLOSE(99)
-
-         sig(1) =1
-         do l=2,llm
-           sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + 
-     &                      exp(-zsig(l-1)/scaleheight) )
-         END DO
-         sig(llm+1) =0
-
-c-----------------------------------------------------------------------
-      ELSE
-         write(lunout,*) 'didn t you forget something ??? '
-         write(lunout,*) 'We need file  z2sig.def ! (OR esasig.def)'
-         stop
-      ENDIF
-c-----------------------------------------------------------------------
-
-      DO l=1,llm
-        nivsigs(l) = REAL(l)
-      ENDDO
-
-      DO l=1,llmp1
-        nivsig(l)= REAL(l)
-      ENDDO
-
- 
-c-----------------------------------------------------------------------
-c    ....  Calculs  de ap(l) et de bp(l)  ....
-c    .........................................
-c
-c   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
-c-----------------------------------------------------------------------
-c
-
-      if (hybrid) then  ! use hybrid coordinates
-         write(lunout,*) "*********************************"
-         write(lunout,*) "Using hybrid vertical coordinates"
-         write(lunout,*) 
-c        Coordonnees hybrides avec mod
-         DO l = 1, llm
-
-         CALL sig_hybrid(sig(l),pa,preff,newsig)
-            bp(l) = EXP( 1. - 1./(newsig**2)  )
-            ap(l) = pa * (newsig - bp(l) )
-         enddo
-         bp(llmp1) = 0.
-         ap(llmp1) = 0.
-      else ! use sigma coordinates
-         write(lunout,*) "********************************"
-         write(lunout,*) "Using sigma vertical coordinates"
-         write(lunout,*) 
-c        Pour ne pas passer en coordonnees hybrides
-         DO l = 1, llm
-            ap(l) = 0.
-            bp(l) = sig(l)
-         ENDDO
-         ap(llmp1) = 0.
-      endif
-
-      bp(llmp1) =   0.
-
-      write(lunout,*) trim(modname),': BP '
-      write(lunout,*)  bp
-      write(lunout,*) trim(modname),': AP '
-      write(lunout,*)  ap
-
-c     Calcul au milieu des couches :
-c     WARNING : le choix de placer le milieu des couches au niveau de
-c     pression intermédiaire est arbitraire et pourrait etre modifié.
-c     Le calcul du niveau pour la derniere couche 
-c     (on met la meme distance (en log pression)  entre P(llm)
-c     et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
-c     Specifique.  Ce choix est spécifié ici ET dans exner_milieu.F
-
-      DO l = 1, llm-1
-       aps(l) =  0.5 *( ap(l) +ap(l+1)) 
-       bps(l) =  0.5 *( bp(l) +bp(l+1)) 
-      ENDDO
-     
-      if (hybrid) then
-         aps(llm) = aps(llm-1)**2 / aps(llm-2) 
-         bps(llm) = 0.5*(bp(llm) + bp(llm+1))
-      else
-         bps(llm) = bps(llm-1)**2 / bps(llm-2) 
-         aps(llm) = 0.
-      end if
-
-      write(lunout,*) trim(modname),': BPs '
-      write(lunout,*)  bps
-      write(lunout,*) trim(modname),': APs'
-      write(lunout,*)  aps
-
-      DO l = 1, llm
-       presnivs(l) = aps(l)+bps(l)*preff
-       pseudoalt(l) = -scaleheight*log(presnivs(l)/preff)
-      ENDDO
-
-      write(lunout,*)trim(modname),' : PRESNIVS' 
-      write(lunout,*)presnivs 
-      write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ',
-     &                'height of ',scaleheight,' km)' 
-      write(lunout,*)pseudoalt
-
-c     --------------------------------------------------
-c     This can be used to plot the vertical discretization
-c     (> xmgrace -nxy testhybrid.tab )
-c     --------------------------------------------------
-c     open (53,file='testhybrid.tab')
-c     scaleheight=15.5
-c     do iz=0,34
-c       z = -5 + min(iz,34-iz)
-c     approximation of scale height for Venus
-c       scaleheight = 15.5 - z/55.*10.
-c       ps = preff*exp(-z/scaleheight)
-c       zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff)
-c       do l=2,llm
-c     approximation of scale height for Venus
-c          if (zsig(l-1).le.55.) then
-c             scaleheight = 15.5 - zsig(l-1)/55.*10.
-c          else
-c             scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2.
-c          endif
-c          zsig(l)= zsig(l-1)-scaleheight*
-c    .    log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps))
-c       END DO
-c       write(53,'(I3,50F10.5)') iz, zsig
-c      END DO
-c      close(53)
-c     --------------------------------------------------
-
-
-      RETURN
-      END
-
-c ************************************************************
-      SUBROUTINE sig_hybrid(sig,pa,preff,newsig)
-c     ----------------------------------------------
-c     Subroutine utilisee pour calculer des valeurs de sigma modifie
-c     pour conserver les coordonnees verticales decrites dans
-c     esasig.def/z2sig.def lors du passage en coordonnees hybrides
-c     F. Forget 2002
-c     Connaissant sig (niveaux "sigma" ou on veut mettre les couches)
-c     L'objectif est de calculer newsig telle que
-c       (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig
-c     Cela ne se résoud pas analytiquement:
-c     => on résoud par iterration bourrine
-c     ----------------------------------------------
-c     Information  : where exp(1-1./x**2) become << x
-c           x      exp(1-1./x**2) /x
-c           1           1
-c           0.68       0.5
-c           0.5        1.E-1
-c           0.391      1.E-2
-c           0.333      1.E-3
-c           0.295      1.E-4
-c           0.269      1.E-5
-c           0.248      1.E-6
-c        => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25
-
-
-      implicit none
-      real x1, x2, sig,pa,preff, newsig, F
-      integer j
-
-      newsig = sig
-      x1=0
-      x2=1
-      if (sig>=1) then
-            newsig= sig
-      else if (sig*preff/pa>=0.25) then
-        DO J=1,9999  ! nombre d''iteration max
-          F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig
-c         write(0,*) J, ' newsig =', newsig, ' F= ', F
-          if (F>1) then
-              X2 = newsig
-              newsig=(X1+newsig)*0.5
-          else
-              X1 = newsig
-              newsig=(X2+newsig)*0.5
-          end if
-c         Test : on arete lorsque on approxime sig à moins de 0.01 m près
-c         (en pseudo altitude) :
-          IF(abs(10.*log(F))<1.E-5) goto 999
-        END DO
-       else   !    if (sig*preff/pa.le.0.25) then
-             newsig= sig*preff/pa
-       end if
- 999   continue
-       Return
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/disvert_noterre.f90	(revision 5105)
@@ -0,0 +1,326 @@
+! $Id: $
+SUBROUTINE disvert_noterre
+
+  !    Auteur :  F. Forget Y. Wanherdrick, P. Levan
+  !    Nouvelle version 100% Mars !!
+  !    On l'utilise aussi pour Venus et Titan, legerment modifiee.
+
+  use IOIPSL
+  USE comvert_mod, ONLY: ap,bp,aps,bps,presnivs,pseudoalt, &
+        nivsig,nivsigs,pa,preff,scaleheight
+  USE comconst_mod, ONLY: kappa
+  USE logic_mod, ONLY: hybrid
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  !=======================================================================
+  !    Discretisation verticale en coordonnée hybride (ou sigma)
+  !
+  !=======================================================================
+  !
+  !   declarations:
+  !   -------------
+  !
+  !
+  INTEGER :: l,ll
+  REAL :: snorm
+  REAL :: alpha,beta,gama,delta,deltaz
+  real :: quoi,quand
+  REAL :: zsig(llm),sig(llm+1)
+  INTEGER :: np,ierr
+  integer :: ierr1,ierr2,ierr3,ierr4
+  REAL :: x
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+  real :: newsig
+  REAL :: dz0,dz1,nhaut,sig1,esig,csig,zz
+  real :: tt,rr,gg, prevz
+  real :: s(llm),dsig(llm)
+
+  integer :: iz
+  real :: z, ps,p
+  character(len=*),parameter :: modname="disvert_noterre"
+
+  !
+  !-----------------------------------------------------------------------
+  !
+  ! Initializations:
+  !  pi=2.*ASIN(1.) ! already done in iniconst
+
+  hybrid=.TRUE. ! default value for hybrid (ie: use hybrid coordinates)
+  CALL getin('hybrid',hybrid)
+  write(lunout,*) trim(modname),': hybrid=',hybrid
+
+  ! Ouverture possible de fichiers typiquement E.T.
+
+     open(99,file="esasig.def",status='old',form='formatted', &
+           iostat=ierr2)
+     if(ierr2/=0) then
+          close(99)
+          open(99,file="z2sig.def",status='old',form='formatted', &
+                iostat=ierr4)
+     endif
+
+  !-----------------------------------------------------------------------
+  !   cas 1 on lit les options dans esasig.def:
+  !   ----------------------------------------
+
+  IF(ierr2==0) then
+
+     ! Lecture de esasig.def :
+     ! Systeme peu souple, mais qui respecte en theorie
+     ! La conservation de l'energie (conversion Energie potentielle
+     ! <-> energie cinetique, d'apres la note de Frederic Hourdin...
+
+     write(lunout,*)'*****************************'
+     write(lunout,*)'WARNING reading esasig.def'
+     write(lunout,*)'*****************************'
+     READ(99,*) scaleheight
+     READ(99,*) dz0
+     READ(99,*) dz1
+     READ(99,*) nhaut
+     CLOSE(99)
+
+     dz0=dz0/scaleheight
+     dz1=dz1/scaleheight
+
+     sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
+
+     esig=1.
+
+     do l=1,20
+        esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
+     enddo
+     csig=(1./sig1-1.)/(exp(esig)-1.)
+
+     DO L = 2, llm
+        zz=csig*(exp(esig*(l-1.))-1.)
+        sig(l) =1./(1.+zz) &
+              * tanh(.5*(llm+1-l)/nhaut)
+     ENDDO
+     sig(1)=1.
+     sig(llm+1)=0.
+     quoi      = 1. + 2.* kappa
+     s( llm )  = 1.
+     s(llm-1) = quoi
+     IF( llm>2 )  THEN
+        DO  ll = 2, llm-1
+           l         = llm+1 - ll
+           quand     = sig(l+1)/ sig(l)
+           s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
+        ENDDO
+     END IF
+  !
+     snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
+     DO l = 1, llm
+        s(l)    = s(l)/ snorm
+     ENDDO
+
+  !-----------------------------------------------------------------------
+  !   cas 2 on lit les options dans z2sig.def:
+  !   ----------------------------------------
+
+  ELSE IF(ierr4==0) then
+     write(lunout,*)'****************************'
+     write(lunout,*)'Reading z2sig.def'
+     write(lunout,*)'****************************'
+
+     READ(99,*) scaleheight
+     do l=1,llm
+        read(99,*) zsig(l)
+     END DO
+     CLOSE(99)
+
+     sig(1) =1
+     do l=2,llm
+       sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + &
+             exp(-zsig(l-1)/scaleheight) )
+     END DO
+     sig(llm+1) =0
+
+  !-----------------------------------------------------------------------
+  ELSE
+     write(lunout,*) 'didn t you forget something ??? '
+     write(lunout,*) 'We need file  z2sig.def ! (OR esasig.def)'
+     stop
+  ENDIF
+  !-----------------------------------------------------------------------
+
+  DO l=1,llm
+    nivsigs(l) = REAL(l)
+  ENDDO
+
+  DO l=1,llmp1
+    nivsig(l)= REAL(l)
+  ENDDO
+
+
+  !-----------------------------------------------------------------------
+  !    ....  Calculs  de ap(l) et de bp(l)  ....
+  !    .........................................
+  !
+  !   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
+  !-----------------------------------------------------------------------
+  !
+
+  if (hybrid) then  ! use hybrid coordinates
+     write(lunout,*) "*********************************"
+     write(lunout,*) "Using hybrid vertical coordinates"
+     write(lunout,*)
+     ! Coordonnees hybrides avec mod
+     DO l = 1, llm
+
+     CALL sig_hybrid(sig(l),pa,preff,newsig)
+        bp(l) = EXP( 1. - 1./(newsig**2)  )
+        ap(l) = pa * (newsig - bp(l) )
+     enddo
+     bp(llmp1) = 0.
+     ap(llmp1) = 0.
+  else ! use sigma coordinates
+     write(lunout,*) "********************************"
+     write(lunout,*) "Using sigma vertical coordinates"
+     write(lunout,*)
+     ! Pour ne pas passer en coordonnees hybrides
+     DO l = 1, llm
+        ap(l) = 0.
+        bp(l) = sig(l)
+     ENDDO
+     ap(llmp1) = 0.
+  endif
+
+  bp(llmp1) =   0.
+
+  write(lunout,*) trim(modname),': BP '
+  write(lunout,*)  bp
+  write(lunout,*) trim(modname),': AP '
+  write(lunout,*)  ap
+
+  ! Calcul au milieu des couches :
+  ! WARNING : le choix de placer le milieu des couches au niveau de
+  ! pression intermédiaire est arbitraire et pourrait etre modifié.
+  ! Le calcul du niveau pour la derniere couche
+  ! (on met la meme distance (en log pression)  entre P(llm)
+  ! et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
+  ! Specifique.  Ce choix est spécifié ici ET dans exner_milieu.F
+
+  DO l = 1, llm-1
+   aps(l) =  0.5 *( ap(l) +ap(l+1))
+   bps(l) =  0.5 *( bp(l) +bp(l+1))
+  ENDDO
+
+  if (hybrid) then
+     aps(llm) = aps(llm-1)**2 / aps(llm-2)
+     bps(llm) = 0.5*(bp(llm) + bp(llm+1))
+  else
+     bps(llm) = bps(llm-1)**2 / bps(llm-2)
+     aps(llm) = 0.
+  end if
+
+  write(lunout,*) trim(modname),': BPs '
+  write(lunout,*)  bps
+  write(lunout,*) trim(modname),': APs'
+  write(lunout,*)  aps
+
+  DO l = 1, llm
+   presnivs(l) = aps(l)+bps(l)*preff
+   pseudoalt(l) = -scaleheight*log(presnivs(l)/preff)
+  ENDDO
+
+  write(lunout,*)trim(modname),' : PRESNIVS'
+  write(lunout,*)presnivs
+  write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ', &
+        'height of ',scaleheight,' km)'
+  write(lunout,*)pseudoalt
+
+  ! --------------------------------------------------
+  ! This can be used to plot the vertical discretization
+  ! (> xmgrace -nxy testhybrid.tab )
+  ! --------------------------------------------------
+  ! open (53,file='testhybrid.tab')
+  ! scaleheight=15.5
+  ! do iz=0,34
+  !   z = -5 + min(iz,34-iz)
+  ! approximation of scale height for Venus
+  !   scaleheight = 15.5 - z/55.*10.
+  !   ps = preff*exp(-z/scaleheight)
+  !   zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff)
+  !   do l=2,llm
+  ! approximation of scale height for Venus
+  !      if (zsig(l-1).le.55.) then
+  !         scaleheight = 15.5 - zsig(l-1)/55.*10.
+  !      else
+  !         scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2.
+  !      endif
+  !      zsig(l)= zsig(l-1)-scaleheight*
+  !    .    log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps))
+  !   END DO
+  !   write(53,'(I3,50F10.5)') iz, zsig
+  !  END DO
+  !  close(53)
+  ! --------------------------------------------------
+
+
+  RETURN
+END SUBROUTINE disvert_noterre
+
+! ************************************************************
+SUBROUTINE sig_hybrid(sig,pa,preff,newsig)
+  ! ----------------------------------------------
+  ! Subroutine utilisee pour calculer des valeurs de sigma modifie
+  ! pour conserver les coordonnees verticales decrites dans
+  ! esasig.def/z2sig.def lors du passage en coordonnees hybrides
+  ! F. Forget 2002
+  ! Connaissant sig (niveaux "sigma" ou on veut mettre les couches)
+  ! L'objectif est de calculer newsig telle que
+  !   (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig
+  ! Cela ne se résoud pas analytiquement:
+  ! => on résoud par iterration bourrine
+  ! ----------------------------------------------
+  ! Information  : where exp(1-1./x**2) become << x
+  !       x      exp(1-1./x**2) /x
+  !       1           1
+  !       0.68       0.5
+  !       0.5        1.E-1
+  !       0.391      1.E-2
+  !       0.333      1.E-3
+  !       0.295      1.E-4
+  !       0.269      1.E-5
+  !       0.248      1.E-6
+  !    => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25
+
+
+  implicit none
+  real :: x1, x2, sig,pa,preff, newsig, F
+  integer :: j
+
+  newsig = sig
+  x1=0
+  x2=1
+  if (sig>=1) then
+        newsig= sig
+  else if (sig*preff/pa>=0.25) then
+    DO J=1,9999  ! nombre d''iteration max
+      F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig
+      ! write(0,*) J, ' newsig =', newsig, ' F= ', F
+      if (F>1) then
+          X2 = newsig
+          newsig=(X1+newsig)*0.5
+      else
+          X1 = newsig
+          newsig=(X2+newsig)*0.5
+      end if
+      ! Test : on arete lorsque on approxime sig à moins de 0.01 m près
+      ! (en pseudo altitude) :
+      IF(abs(10.*log(F))<1.E-5) goto 999
+    END DO
+   else   !    if (sig*preff/pa.le.0.25) then
+         newsig= sig*preff/pa
+   end if
+ 999   continue
+   Return
+END SUBROUTINE sig_hybrid
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.F	(revision 5104)
+++ 	(revision )
@@ -1,85 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE diverg(klevel,x,y,div)
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
-      INTEGER   l,ij
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-c    ...................................................................
-c
-      REAL      SSUM
-c
-c
-      DO l = 1,klevel
-c
-        DO  ij = iip2, ip1jm - 1
-         div( ij + 1, l )     =  
-     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
-     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
-        ENDDO
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-        DO  ij = iip2,ip1jm,iip1
-         div( ij,l ) = div( ij + iim,l )
-        ENDDO
-c
-c     ....  calcul  aux poles  .....
-c
-        DO  ij  = 1,iim
-         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
-         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
-        ENDDO
-        sumypn = SSUM ( iim,aiy1,1 ) / apoln
-        sumyps = SSUM ( iim,aiy2,1 ) / apols
-c
-        DO  ij = 1,iip1
-         div(     ij    , l ) = - sumypn
-         div( ij + ip1jm, l ) =   sumyps
-        ENDDO
-      END DO
-c
-
-ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
-      
-c
-        DO l = 1, klevel
-           DO ij = iip2,ip1jm
-            div(ij,l) = div(ij,l) * unsaire(ij) 
-          ENDDO
-        ENDDO
-c
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.f90	(revision 5105)
@@ -0,0 +1,85 @@
+
+! $Header$
+
+SUBROUTINE diverg(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  !    ...................................................................
+  !
+  REAL :: SSUM
+  !
+  !
+  DO l = 1,klevel
+  !
+    DO  ij = iip2, ip1jm - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = iip2,ip1jm,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    DO  ij  = 1,iim
+     aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+     aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+    ENDDO
+    sumypn = SSUM ( iim,aiy1,1 ) / apoln
+    sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+    DO  ij = 1,iip1
+     div(     ij    , l ) = - sumypn
+     div( ij + ip1jm, l ) =   sumyps
+    ENDDO
+  END DO
+  !
+
+  !cc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+
+  !
+    DO l = 1, klevel
+       DO ij = iip2,ip1jm
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+  !
+   RETURN
+END SUBROUTINE diverg
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.F	(revision 5104)
+++ 	(revision )
@@ -1,80 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam ,
-     *                       unsapolnga,unsapolsga,  x, y,  div )
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
-      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
-      REAL unsapolnga,unsapolsga
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-      INTEGER   l,ij
-c    ...................................................................
-c
-      REAL      SSUM
-c
-c
-      DO l = 1,klevel
-c
-        DO  ij = iip2, ip1jm - 1
-         div( ij + 1, l )     = (  
-     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
-     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
-     *         unsairegam( ij+1 )
-        ENDDO
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-        DO  ij = iip2,ip1jm,iip1
-         div( ij,l ) = div( ij + iim,l )
-        ENDDO
-c
-c     ....  calcul  aux poles  .....
-c
-        DO  ij  = 1,iim
-         aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
-         aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
-        ENDDO
-        sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
-        sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
-c
-        DO  ij = 1,iip1
-         div(     ij    , l ) = - sumypn 
-         div( ij + ip1jm, l ) =   sumyps 
-        ENDDO
-      END DO
-c
-
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.f90	(revision 5105)
@@ -0,0 +1,80 @@
+
+! $Header$
+
+SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , &
+        unsapolnga,unsapolsga,  x, y,  div )
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  REAL :: cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+  REAL :: unsapolnga,unsapolsga
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: l,ij
+  !    ...................................................................
+  !
+  REAL :: SSUM
+  !
+  !
+  DO l = 1,klevel
+  !
+    DO  ij = iip2, ip1jm - 1
+     div( ij + 1, l )     = ( &
+           cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + &
+           cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* &
+           unsairegam( ij+1 )
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = iip2,ip1jm,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    DO  ij  = 1,iim
+     aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+     aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+    ENDDO
+    sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+    sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+  !
+    DO  ij = 1,iip1
+     div(     ij    , l ) = - sumypn
+     div( ij + ip1jm, l ) =   sumyps
+    ENDDO
+  END DO
+  !
+
+   RETURN
+END SUBROUTINE diverg_gam
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.F	(revision 5104)
+++ 	(revision )
@@ -1,85 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE divergf(klevel,x,y,div)
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
-      INTEGER   l,ij
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-c    ...................................................................
-c
-      REAL      SSUM
-c
-c
-      DO l = 1,klevel
-c
-        DO  ij = iip2, ip1jm - 1
-         div( ij + 1, l )     =  
-     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
-     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
-        ENDDO
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-        DO  ij = iip2,ip1jm,iip1
-         div( ij,l ) = div( ij + iim,l )
-        ENDDO
-c
-c     ....  calcul  aux poles  .....
-c
-        DO  ij  = 1,iim
-         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
-         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
-        ENDDO
-        sumypn = SSUM ( iim,aiy1,1 ) / apoln
-        sumyps = SSUM ( iim,aiy2,1 ) / apols
-c
-        DO  ij = 1,iip1
-         div(     ij    , l ) = - sumypn
-         div( ij + ip1jm, l ) =   sumyps
-        ENDDO
-      END DO
-c
-
-        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
-      
-c
-        DO l = 1, klevel
-           DO ij = iip2,ip1jm
-            div(ij,l) = div(ij,l) * unsaire(ij) 
-          ENDDO
-        ENDDO
-c
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.f90	(revision 5105)
@@ -0,0 +1,85 @@
+
+! $Header$
+
+SUBROUTINE divergf(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  !    ...................................................................
+  !
+  REAL :: SSUM
+  !
+  !
+  DO l = 1,klevel
+  !
+    DO  ij = iip2, ip1jm - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = iip2,ip1jm,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    DO  ij  = 1,iim
+     aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+     aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+    ENDDO
+    sumypn = SSUM ( iim,aiy1,1 ) / apoln
+    sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+    DO  ij = 1,iip1
+     div(     ij    , l ) = - sumypn
+     div( ij + ip1jm, l ) =   sumyps
+    ENDDO
+  END DO
+  !
+
+    CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+
+  !
+    DO l = 1, klevel
+       DO ij = iip2,ip1jm
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+  !
+   RETURN
+END SUBROUTINE divergf
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.F	(revision 5104)
+++ 	(revision )
@@ -1,62 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE divergst(klevel,x,y,div)
-      IMPLICIT NONE
-c
-c     P. Le Van
-c
-c  ******************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y...
-c           x et y  etant des composantes contravariantes   ...
-c  ****************************************************************
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   -------------------------------------------------------------------
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      INTEGER klevel
-      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
-      INTEGER ij,l,i
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-
-      REAL SSUM
-c
-c
-      DO l = 1,klevel
-c
-      DO ij = iip2, ip1jm - 1
-      div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
-      END DO
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-      DO ij = iip2,ip1jm,iip1
-      div( ij,l ) = div( ij + iim,l )
-      END DO
-c
-c     ....  calcul  aux poles  .....
-c
-c
-      DO i  = 1,iim
-      aiy1(i)= y(i,l)
-      aiy2(i)= y(i+ip1jmi1,l)
-      END DO
-      sumypn = SSUM ( iim,aiy1,1 )
-      sumyps = SSUM ( iim,aiy2,1 )
-      DO i = 1,iip1
-      div(     i    , l ) = - sumypn/iim
-      div( i + ip1jm, l ) =   sumyps/iim
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.f90	(revision 5105)
@@ -0,0 +1,62 @@
+
+! $Header$
+
+SUBROUTINE divergst(klevel,x,y,div)
+  IMPLICIT NONE
+  !
+  ! P. Le Van
+  !
+  !  ******************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y...
+  !       x et y  etant des composantes contravariantes   ...
+  !  ****************************************************************
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   -------------------------------------------------------------------
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  INTEGER :: ij,l,i
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+
+  REAL :: SSUM
+  !
+  !
+  DO l = 1,klevel
+  !
+  DO ij = iip2, ip1jm - 1
+  div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
+  END DO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+  DO ij = iip2,ip1jm,iip1
+  div( ij,l ) = div( ij + iim,l )
+  END DO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+  !
+  DO i  = 1,iim
+  aiy1(i)= y(i,l)
+  aiy2(i)= y(i+ip1jmi1,l)
+  END DO
+  sumypn = SSUM ( iim,aiy1,1 )
+  sumyps = SSUM ( iim,aiy2,1 )
+  DO i = 1,iip1
+  div(     i    , l ) = - sumypn/iim
+  div( i + ip1jm, l ) =   sumyps/iim
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE divergst
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.F	(revision 5104)
+++ 	(revision )
@@ -1,55 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE divgrad (klevel,h, lh, divgra )
-      IMPLICIT NONE
-c
-c=======================================================================
-c
-c  Auteur :   P. Le Van
-c  ----------
-c
-c                              lh
-c      calcul de  (div( grad ))   de h  .....
-c      h  et lh  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-c=======================================================================
-c
-c   declarations:
-c   -------------
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "comdissipn.h"
-c
-      INTEGER klevel
-      REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
-c
-      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
-
-      INTEGER  l,ij,iter,lh
-c
-c
-c
-      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
-c
-      DO iter = 1,lh
-
-      CALL filtreg ( divgra,jjp1,klevel,2,1,.TRUE.,1  )
-
-      CALL    grad (klevel,divgra, ghx  , ghy          )
-      CALL  diverg (klevel,  ghx , ghy  , divgra       )
-
-      CALL filtreg ( divgra,jjp1,klevel,2,1,.TRUE.,1)
-
-      DO l = 1,klevel
-      DO ij = 1, ip1jmp1
-      divgra( ij,l ) = - cdivh * divgra( ij,l )
-      END DO
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.f90	(revision 5105)
@@ -0,0 +1,55 @@
+
+! $Header$
+
+SUBROUTINE divgrad (klevel,h, lh, divgra )
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !  Auteur :   P. Le Van
+  !  ----------
+  !
+  !                          lh
+  !  calcul de  (div( grad ))   de h  .....
+  !  h  et lh  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  !=======================================================================
+  !
+  !   declarations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "comdissipn.h"
+  !
+  INTEGER :: klevel
+  REAL :: h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+  !
+  REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+  INTEGER :: l,ij,iter,lh
+  !
+  !
+  !
+  CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+  !
+  DO iter = 1,lh
+
+  CALL filtreg ( divgra,jjp1,klevel,2,1,.TRUE.,1  )
+
+  CALL    grad (klevel,divgra, ghx  , ghy          )
+  CALL  diverg (klevel,  ghx , ghy  , divgra       )
+
+  CALL filtreg ( divgra,jjp1,klevel,2,1,.TRUE.,1)
+
+  DO l = 1,klevel
+  DO ij = 1, ip1jmp1
+  divgra( ij,l ) = - cdivh * divgra( ij,l )
+  END DO
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE divgrad
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.F	(revision 5104)
+++ 	(revision )
@@ -1,79 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
-c
-c     P. Le Van
-c
-c   ***************************************************************
-c
-c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
-c   ****************************************************************
-c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
-c         divgra     est  un argument  de sortie pour le s-prg
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom2.h"
-      INCLUDE "comdissipn.h"
-
-c    .......    variables en arguments   .......
-c
-      INTEGER klevel
-      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
-      REAL divgra( ip1jmp1,klevel)
-c
-c    .......    variables  locales    ..........
-c
-      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
-      INTEGER  l,ij,iter,lh
-c    ...................................................................
-
-c
-      signe    = (-1.)**lh
-      nudivgrs = signe * cdivh
-
-      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
-
-c
-      CALL laplacien( klevel, divgra, divgra )
-     
-      DO l = 1, klevel
-       DO ij = 1, ip1jmp1
-        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
-       ENDDO
-      ENDDO
-c
-      DO l = 1, klevel
-        DO ij = 1, ip1jmp1
-         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
-        ENDDO
-      ENDDO
-   
-c    ........    Iteration de l'operateur  laplacien_gam    ........
-c
-      DO  iter = 1, lh - 2
-       CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
-     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
-      ENDDO
-c
-c    ...............................................................
- 
-      DO l = 1, klevel
-        DO ij = 1, ip1jmp1
-          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
-        ENDDO
-      ENDDO
-c
-      CALL laplacien ( klevel, divgra, divgra )
-c
-      DO l  = 1,klevel
-      DO ij = 1,ip1jmp1
-      divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
-      ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.f90	(revision 5105)
@@ -0,0 +1,79 @@
+
+! $Header$
+
+SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
+  !
+  ! P. Le Van
+  !
+  !   ***************************************************************
+  !
+  ! .....   calcul de  (div( grad ))   de (  pext * h ) .....
+  !   ****************************************************************
+  !   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+  !     divgra     est  un argument  de sortie pour le s-prg
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom2.h"
+  INCLUDE "comdissipn.h"
+
+  !    .......    variables en arguments   .......
+  !
+  INTEGER :: klevel
+  REAL :: h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+  REAL :: divgra( ip1jmp1,klevel)
+  !
+  !    .......    variables  locales    ..........
+  !
+  REAL :: signe, nudivgrs, sqrtps( ip1jmp1,llm )
+  INTEGER :: l,ij,iter,lh
+  !    ...................................................................
+
+  !
+  signe    = (-1.)**lh
+  nudivgrs = signe * cdivh
+
+  CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+
+  !
+  CALL laplacien( klevel, divgra, divgra )
+
+  DO l = 1, klevel
+   DO ij = 1, ip1jmp1
+    sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+   ENDDO
+  ENDDO
+  !
+  DO l = 1, klevel
+    DO ij = 1, ip1jmp1
+     divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+
+  !    ........    Iteration de l'operateur  laplacien_gam    ........
+  !
+  DO  iter = 1, lh - 2
+   CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, &
+         unsapolnga2, unsapolsga2,  divgra, divgra )
+  ENDDO
+  !
+  !    ...............................................................
+
+  DO l = 1, klevel
+    DO ij = 1, ip1jmp1
+      divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+  !
+  CALL laplacien ( klevel, divgra, divgra )
+  !
+  DO l  = 1,klevel
+  DO ij = 1,ip1jmp1
+  divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+  ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE divgrad2
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/dump2d.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/dump2d.F	(revision 5104)
+++ 	(revision )
@@ -1,46 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE dump2d(im,jm,z,nom_z)
-      IMPLICIT NONE
-      INTEGER im,jm
-      REAL z(im,jm)
-      CHARACTER (len=*) :: nom_z
-
-      INTEGER i,j,imin,illm,jmin,jllm
-      REAL zmin,zllm
-
-      WRITE(*,*) "dump2d: ",trim(nom_z)
-
-      zmin=z(1,1)
-      zllm=z(1,1)
-      imin=1
-      illm=1
-      jmin=1
-      jllm=1
-
-      DO j=1,jm
-         DO i=1,im
-            IF(z(i,j)>zllm) THEN
-               illm=i
-               jllm=j
-               zllm=z(i,j)
-            ENDIF
-            IF(z(i,j)<zmin) THEN
-               imin=i
-               jmin=j
-               zmin=z(i,j)
-            ENDIF
-         ENDDO
-      ENDDO
-
-      PRINT*,'MIN: ',zmin
-      PRINT*,'MAX: ',zllm
-
-      IF(zllm>zmin) THEN
-       DO j=1,jm
-        WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
-       ENDDO
-      ENDIF
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/dump2d.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/dump2d.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/dump2d.f90	(revision 5105)
@@ -0,0 +1,46 @@
+
+! $Id$
+
+SUBROUTINE dump2d(im,jm,z,nom_z)
+  IMPLICIT NONE
+  INTEGER :: im,jm
+  REAL :: z(im,jm)
+  CHARACTER (len=*) :: nom_z
+
+  INTEGER :: i,j,imin,illm,jmin,jllm
+  REAL :: zmin,zllm
+
+  WRITE(*,*) "dump2d: ",trim(nom_z)
+
+  zmin=z(1,1)
+  zllm=z(1,1)
+  imin=1
+  illm=1
+  jmin=1
+  jllm=1
+
+  DO j=1,jm
+     DO i=1,im
+        IF(z(i,j)>zllm) THEN
+           illm=i
+           jllm=j
+           zllm=z(i,j)
+        ENDIF
+        IF(z(i,j)<zmin) THEN
+           imin=i
+           jmin=j
+           zmin=z(i,j)
+        ENDIF
+     ENDDO
+  ENDDO
+
+  PRINT*,'MIN: ',zmin
+  PRINT*,'MAX: ',zllm
+
+  IF(zllm>zmin) THEN
+   DO j=1,jm
+    WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
+   ENDDO
+  ENDIF
+  RETURN
+END SUBROUTINE dump2d
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/extrapol.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/extrapol.F	(revision 5104)
+++ 	(revision )
@@ -1,201 +1,0 @@
-
-! $Id$
-
-C
-C
-      SUBROUTINE extrapol (pfild, kxlon, kylat, pmask,
-     .                   norsud, ldper, knbor, pwork)
-      IMPLICIT none
-c
-c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
-c Fill up missed values by using the neighbor points
-c
-      INTEGER kxlon, kylat ! longitude and latitude dimensions (Input)
-      INTEGER knbor ! minimum neighbor number (Input)
-      LOGICAL norsud ! True if field is from North to South (Input)
-      LOGICAL ldper ! True if take into account the periodicity (Input)
-      REAL pmask ! mask value (Input)
-      REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
-      REAL pwork(kxlon,kylat) ! working space
-c
-      REAL zwmsk
-      INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
-      INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates
-      REAL zmask(9)
-C
-C  We search over the eight closest neighbors
-C
-C            j+1  7  8  9
-C              j  4  5  6    Current point 5 --> (i,j)
-C            j-1  1  2  3
-C                i-1 i i+1
-c
-c
-      IF (norsud) THEN
-         DO j = 1, kylat
-         DO i = 1, kxlon
-            pwork(i,j) = pfild(i,kylat-j+1)
-         ENDDO
-         ENDDO
-         DO j = 1, kylat
-         DO i = 1, kxlon
-            pfild(i,j) = pwork(i,j)
-         ENDDO
-         ENDDO
-      ENDIF
-c
-      incre = 0
-c
-      DO j = 1, kylat
-      DO i = 1, kxlon
-         pwork(i,j) = pfild(i,j)
-      ENDDO
-      ENDDO
-c
-C* To avoid problems in floating point tests
-      zwmsk = pmask - 1.0
-c
-200   CONTINUE
-      incre = incre + 1
-      DO j = 1, kylat
-      DO i = 1, kxlon
-      IF (pfild(i,j)> zwmsk) THEN
-         pwork(i,j) = pfild(i,j)
-         inbor = 0
-         ideb = 1
-         ifin = 9
-C
-C* Fill up ix array
-         ix(1) = MAX (1,i-1)
-         ix(2) = i
-         ix(3) = MIN (kxlon,i+1)
-         ix(4) = MAX (1,i-1)
-         ix(5) = i
-         ix(6) = MIN (kxlon,i+1)
-         ix(7) = MAX (1,i-1)
-         ix(8) = i
-         ix(9) = MIN (kxlon,i+1)
-C
-C* Fill up iy array
-         jy(1) = MAX (1,j-1)
-         jy(2) = MAX (1,j-1)
-         jy(3) = MAX (1,j-1)
-         jy(4) = j
-         jy(5) = j
-         jy(6) = j
-         jy(7) = MIN (kylat,j+1)
-         jy(8) = MIN (kylat,j+1)
-         jy(9) = MIN (kylat,j+1)
-C
-C* Correct latitude bounds if southernmost or northernmost points
-         IF (j == 1) ideb = 4
-         IF (j == kylat) ifin = 6
-C
-C* Account for periodicity in longitude
-C
-         IF (ldper) THEN 
-            IF (i == kxlon) THEN
-               ix(3) = 1
-               ix(6) = 1
-               ix(9) = 1
-            ELSE IF (i == 1) THEN
-               ix(1) = kxlon
-               ix(4) = kxlon
-               ix(7) = kxlon
-            ENDIF
-         ELSE
-            IF (i == 1) THEN
-               ix(1) = i
-               ix(2) = i + 1
-               ix(3) = i
-               ix(4) = i + 1
-               ix(5) = i
-               ix(6) = i + 1
-            ENDIF 
-            IF (i == kxlon) THEN
-               ix(1) = i -1
-               ix(2) = i
-               ix(3) = i - 1
-               ix(4) = i
-               ix(5) = i - 1
-               ix(6) = i
-            ENDIF
-C
-            IF (i == 1 .OR. i == kxlon) THEN 
-               jy(1) = MAX (1,j-1)
-               jy(2) = MAX (1,j-1)
-               jy(3) = j
-               jy(4) = j
-               jy(5) = MIN (kylat,j+1)
-               jy(6) = MIN (kylat,j+1)
-C
-               ideb = 1
-               ifin = 6
-               IF (j == 1) ideb = 3
-               IF (j == kylat) ifin = 4
-            ENDIF
-         ENDIF ! end for ldper test
-C
-C* Find unmasked neighbors
-C
-         DO k = ideb, ifin
-            zmask(k) = 0.
-            ilon = ix(k)
-            jlat = jy(k)
-            IF (pfild(ilon,jlat) < zwmsk) THEN
-               zmask(k) = 1.
-               inbor = inbor + 1
-            ENDIF
-      END DO
-C
-C* Not enough points around point P are unmasked; interpolation on P 
-C  will be done in a future CALL to extrap.
-C
-         IF (inbor >= knbor) THEN
-            pwork(i,j) = 0.
-            DO k = ideb, ifin
-               ilon = ix(k)
-               jlat = jy(k)
-               pwork(i,j) = pwork(i,j)
-     $                      + pfild(ilon,jlat) * zmask(k)/ REAL(inbor)
-            ENDDO
-         ENDIF
-C
-      ENDIF
-      END DO
-      END DO
-C
-C*    3. Writing back unmasked field in pfild
-C        ------------------------------------
-C
-C* pfild then contains:
-C     - Values which were not masked
-C     - Interpolated values from the inbor neighbors
-C     - Values which are not yet interpolated
-C
-      idoit = 0
-      DO j = 1, kylat
-      DO i = 1, kxlon
-         IF (pwork(i,j) > zwmsk) idoit = idoit + 1
-         pfild(i,j) = pwork(i,j)
-      ENDDO
-      ENDDO
-c
-      IF (idoit /= 0) GOTO 200
-ccc      PRINT*, "Number of extrapolation steps incre =", incre
-c
-      IF (norsud) THEN
-         DO j = 1, kylat
-         DO i = 1, kxlon
-            pwork(i,j) = pfild(i,kylat-j+1)
-         ENDDO
-         ENDDO
-         DO j = 1, kylat
-         DO i = 1, kxlon
-            pfild(i,j) = pwork(i,j)
-         ENDDO
-         ENDDO
-      ENDIF
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/extrapol.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/extrapol.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/extrapol.f90	(revision 5105)
@@ -0,0 +1,201 @@
+
+! $Id$
+
+!
+!
+SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, &
+        norsud, ldper, knbor, pwork)
+  IMPLICIT none
+  !
+  ! OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
+  ! Fill up missed values by using the neighbor points
+  !
+  INTEGER :: kxlon, kylat ! longitude and latitude dimensions (Input)
+  INTEGER :: knbor ! minimum neighbor number (Input)
+  LOGICAL :: norsud ! True if field is from North to South (Input)
+  LOGICAL :: ldper ! True if take into account the periodicity (Input)
+  REAL :: pmask ! mask value (Input)
+  REAL :: pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
+  REAL :: pwork(kxlon,kylat) ! working space
+  !
+  REAL :: zwmsk
+  INTEGER :: incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
+  INTEGER :: ix(9), jy(9) ! index arrays for the neighbors coordinates
+  REAL :: zmask(9)
+  !
+  !  We search over the eight closest neighbors
+  !
+  !        j+1  7  8  9
+  !          j  4  5  6    Current point 5 --> (i,j)
+  !        j-1  1  2  3
+  !            i-1 i i+1
+  !
+  !
+  IF (norsud) THEN
+     DO j = 1, kylat
+     DO i = 1, kxlon
+        pwork(i,j) = pfild(i,kylat-j+1)
+     ENDDO
+     ENDDO
+     DO j = 1, kylat
+     DO i = 1, kxlon
+        pfild(i,j) = pwork(i,j)
+     ENDDO
+     ENDDO
+  ENDIF
+  !
+  incre = 0
+  !
+  DO j = 1, kylat
+  DO i = 1, kxlon
+     pwork(i,j) = pfild(i,j)
+  ENDDO
+  ENDDO
+  !
+  !* To avoid problems in floating point tests
+  zwmsk = pmask - 1.0
+  !
+200   CONTINUE
+  incre = incre + 1
+  DO j = 1, kylat
+  DO i = 1, kxlon
+  IF (pfild(i,j)> zwmsk) THEN
+     pwork(i,j) = pfild(i,j)
+     inbor = 0
+     ideb = 1
+     ifin = 9
+  !
+  !* Fill up ix array
+     ix(1) = MAX (1,i-1)
+     ix(2) = i
+     ix(3) = MIN (kxlon,i+1)
+     ix(4) = MAX (1,i-1)
+     ix(5) = i
+     ix(6) = MIN (kxlon,i+1)
+     ix(7) = MAX (1,i-1)
+     ix(8) = i
+     ix(9) = MIN (kxlon,i+1)
+  !
+  !* Fill up iy array
+     jy(1) = MAX (1,j-1)
+     jy(2) = MAX (1,j-1)
+     jy(3) = MAX (1,j-1)
+     jy(4) = j
+     jy(5) = j
+     jy(6) = j
+     jy(7) = MIN (kylat,j+1)
+     jy(8) = MIN (kylat,j+1)
+     jy(9) = MIN (kylat,j+1)
+  !
+  !* Correct latitude bounds if southernmost or northernmost points
+     IF (j == 1) ideb = 4
+     IF (j == kylat) ifin = 6
+  !
+  !* Account for periodicity in longitude
+  !
+     IF (ldper) THEN
+        IF (i == kxlon) THEN
+           ix(3) = 1
+           ix(6) = 1
+           ix(9) = 1
+        ELSE IF (i == 1) THEN
+           ix(1) = kxlon
+           ix(4) = kxlon
+           ix(7) = kxlon
+        ENDIF
+     ELSE
+        IF (i == 1) THEN
+           ix(1) = i
+           ix(2) = i + 1
+           ix(3) = i
+           ix(4) = i + 1
+           ix(5) = i
+           ix(6) = i + 1
+        ENDIF
+        IF (i == kxlon) THEN
+           ix(1) = i -1
+           ix(2) = i
+           ix(3) = i - 1
+           ix(4) = i
+           ix(5) = i - 1
+           ix(6) = i
+        ENDIF
+  !
+        IF (i == 1 .OR. i == kxlon) THEN
+           jy(1) = MAX (1,j-1)
+           jy(2) = MAX (1,j-1)
+           jy(3) = j
+           jy(4) = j
+           jy(5) = MIN (kylat,j+1)
+           jy(6) = MIN (kylat,j+1)
+  !
+           ideb = 1
+           ifin = 6
+           IF (j == 1) ideb = 3
+           IF (j == kylat) ifin = 4
+        ENDIF
+     ENDIF ! end for ldper test
+  !
+  !* Find unmasked neighbors
+  !
+     DO k = ideb, ifin
+        zmask(k) = 0.
+        ilon = ix(k)
+        jlat = jy(k)
+        IF (pfild(ilon,jlat) < zwmsk) THEN
+           zmask(k) = 1.
+           inbor = inbor + 1
+        ENDIF
+  END DO
+  !
+  !* Not enough points around point P are unmasked; interpolation on P
+  !  will be done in a future CALL to extrap.
+  !
+     IF (inbor >= knbor) THEN
+        pwork(i,j) = 0.
+        DO k = ideb, ifin
+           ilon = ix(k)
+           jlat = jy(k)
+           pwork(i,j) = pwork(i,j) &
+                 + pfild(ilon,jlat) * zmask(k)/ REAL(inbor)
+        ENDDO
+     ENDIF
+  !
+  ENDIF
+  END DO
+  END DO
+  !
+  !*    3. Writing back unmasked field in pfild
+  !    ------------------------------------
+  !
+  !* pfild then contains:
+  ! - Values which were not masked
+  ! - Interpolated values from the inbor neighbors
+  ! - Values which are not yet interpolated
+  !
+  idoit = 0
+  DO j = 1, kylat
+  DO i = 1, kxlon
+     IF (pwork(i,j) > zwmsk) idoit = idoit + 1
+     pfild(i,j) = pwork(i,j)
+  ENDDO
+  ENDDO
+  !
+  IF (idoit /= 0) GOTO 200
+  !cc      PRINT*, "Number of extrapolation steps incre =", incre
+  !
+  IF (norsud) THEN
+     DO j = 1, kylat
+     DO i = 1, kxlon
+        pwork(i,j) = pfild(i,kylat-j+1)
+     ENDDO
+     ENDDO
+     DO j = 1, kylat
+     DO i = 1, kxlon
+        pfild(i,j) = pwork(i,j)
+     ENDDO
+     ENDDO
+  ENDIF
+  !
+  RETURN
+END SUBROUTINE extrapol
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/fxy.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxy.F	(revision 5104)
+++ 	(revision )
@@ -1,70 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
-     ,                    rlatu2,yprimu2,
-     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
-
-      USE comconst_mod, ONLY: pi
-      USE serre_mod, ONLY: pxo,pyo,alphax,alphay,transx,transy
-
-      IMPLICIT NONE
-
-c     Auteur  :  P. Le Van
-c
-c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
-c           a tangente sinusoidale et eventuellement avec zoom  .
-c
-c
-      include "dimensions.h"
-      include "paramet.h"
-
-       INTEGER i,j
-
-       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
-     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
-       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
-     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
-
-      INCLUDE "fxy_new.h"
-
-
-c    ......  calcul  des  latitudes  et de y'   .....
-c
-       DO j = 1, jjm + 1 
-          rlatu(j) = fy    ( REAL( j )        )
-         yprimu(j) = fyprim( REAL( j )        )
-       ENDDO
-
-
-       DO j = 1, jjm
-
-         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
-         rlatu1(j) = fy    ( REAL( j ) + 0.25 ) 
-         rlatu2(j) = fy    ( REAL( j ) + 0.75 ) 
-
-        yprimv(j)  = fyprim( REAL( j ) + 0.5  ) 
-        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
-        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
-
-       ENDDO
-
-c
-c     .....  calcul   des  longitudes et de  x'   .....
-c
-       DO i = 1, iim + 1
-           rlonv(i)     = fx    (   REAL( i )          )
-           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
-        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
-        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
-
-         xprimv  (i)    = fxprim (  REAL( i )          )
-         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
-        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
-        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
-       ENDDO
-
-c
-       RETURN
-       END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxy.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxy.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxy.f90	(revision 5105)
@@ -0,0 +1,69 @@
+
+! $Id$
+
+SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
+        rlatu2,yprimu2, &
+        rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+  USE comconst_mod, ONLY: pi
+  USE serre_mod, ONLY: pxo,pyo,alphax,alphay,transx,transy
+
+  IMPLICIT NONE
+
+  ! Auteur  :  P. Le Van
+  !
+  ! Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+  !       a tangente sinusoidale et eventuellement avec zoom  .
+  !
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+   INTEGER :: i,j
+
+   REAL :: rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), &
+         rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+   REAL :: rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), &
+         rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+  INCLUDE "fxy_new.h"
+
+
+  !    ......  calcul  des  latitudes  et de y'   .....
+  !
+   DO j = 1, jjm + 1
+      rlatu(j) = fy    ( REAL( j )        )
+     yprimu(j) = fyprim( REAL( j )        )
+   ENDDO
+
+
+   DO j = 1, jjm
+
+     rlatv(j)  = fy    ( REAL( j ) + 0.5  )
+     rlatu1(j) = fy    ( REAL( j ) + 0.25 )
+     rlatu2(j) = fy    ( REAL( j ) + 0.75 )
+
+    yprimv(j)  = fyprim( REAL( j ) + 0.5  )
+    yprimu1(j) = fyprim( REAL( j ) + 0.25 )
+    yprimu2(j) = fyprim( REAL( j ) + 0.75 )
+
+   ENDDO
+
+  !
+  ! .....  calcul   des  longitudes et de  x'   .....
+  !
+   DO i = 1, iim + 1
+       rlonv(i)     = fx    (   REAL( i )          )
+       rlonu(i)     = fx    (   REAL( i ) + 0.5    )
+    rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
+    rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
+
+     xprimv  (i)    = fxprim (  REAL( i )          )
+     xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
+    xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
+    xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
+   ENDDO
+
+  !
+END SUBROUTINE fxy
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/fxysinus.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxysinus.F	(revision 5104)
+++ 	(revision )
@@ -1,69 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
-     ,                    rlatu2,yprimu2,
-     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
-
-
-      USE comconst_mod, ONLY: pi
-      IMPLICIT NONE
-c
-c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
-c            avec y = Asin( j )  .
-c
-c     Auteur  :  P. Le Van
-c
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-
-       INTEGER i,j
-
-       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
-     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
-       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
-     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
-
-      INCLUDE "fxy_sin.h"
-
-
-c    ......  calcul  des  latitudes  et de y'   .....
-c
-       DO j = 1, jjm + 1 
-          rlatu(j) = fy    ( REAL( j )        )
-         yprimu(j) = fyprim( REAL( j )        )
-       ENDDO
-
-
-       DO j = 1, jjm
-
-         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
-         rlatu1(j) = fy    ( REAL( j ) + 0.25 ) 
-         rlatu2(j) = fy    ( REAL( j ) + 0.75 ) 
-
-        yprimv(j)  = fyprim( REAL( j ) + 0.5  ) 
-        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
-        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
-
-       ENDDO
-
-c
-c     .....  calcul   des  longitudes et de  x'   .....
-c
-       DO i = 1, iim + 1
-           rlonv(i)     = fx    (   REAL( i )          )
-           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
-        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
-        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
-
-         xprimv  (i)    = fxprim (  REAL( i )          )
-         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
-        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
-        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
-       ENDDO
-
-c
-       RETURN
-       END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxysinus.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxysinus.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxysinus.f90	(revision 5105)
@@ -0,0 +1,69 @@
+
+! $Id$
+
+SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
+        rlatu2,yprimu2, &
+        rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !
+  ! Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+  !        avec y = Asin( j )  .
+  !
+  ! Auteur  :  P. Le Van
+  !
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+
+   INTEGER :: i,j
+
+   REAL :: rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), &
+         rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+   REAL :: rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), &
+         rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+  INCLUDE "fxy_sin.h"
+
+
+  !    ......  calcul  des  latitudes  et de y'   .....
+  !
+   DO j = 1, jjm + 1
+      rlatu(j) = fy    ( REAL( j )        )
+     yprimu(j) = fyprim( REAL( j )        )
+   ENDDO
+
+
+   DO j = 1, jjm
+
+     rlatv(j)  = fy    ( REAL( j ) + 0.5  )
+     rlatu1(j) = fy    ( REAL( j ) + 0.25 )
+     rlatu2(j) = fy    ( REAL( j ) + 0.75 )
+
+    yprimv(j)  = fyprim( REAL( j ) + 0.5  )
+    yprimu1(j) = fyprim( REAL( j ) + 0.25 )
+    yprimu2(j) = fyprim( REAL( j ) + 0.75 )
+
+   ENDDO
+
+  !
+  ! .....  calcul   des  longitudes et de  x'   .....
+  !
+   DO i = 1, iim + 1
+       rlonv(i)     = fx    (   REAL( i )          )
+       rlonu(i)     = fx    (   REAL( i ) + 0.5    )
+    rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
+    rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
+
+     xprimv  (i)    = fxprim (  REAL( i )          )
+     xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
+    xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
+    xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
+   ENDDO
+
+  !
+   RETURN
+END SUBROUTINE fxysinus
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.F	(revision 5104)
+++ 	(revision )
@@ -1,63 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c    *******************************************************************
-c    ....   calcul du geopotentiel aux milieux des couches    .....
-c    *******************************************************************
-c
-c     ....   l'integration se fait de bas en haut  ....
-c
-c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
-c              phi               est un  argum. de sortie pour le s-pg .
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      include "dimensions.h"
-      include "paramet.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER ngrid
-      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
-     *       phi(ngrid,llm)
-
-
-c   Local:
-c   ------
-
-      INTEGER  l, ij
-
-
-c-----------------------------------------------------------------------
-c     calcul de phi au niveau 1 pres du sol  .....
-
-      DO   ij  = 1, ngrid
-      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
-      END DO
-
-c     calcul de phi aux niveaux superieurs  .......
-
-      DO  l = 2,llm
-        DO  ij    = 1,ngrid
-        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
-     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
-        ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.f90	(revision 5105)
@@ -0,0 +1,63 @@
+
+! $Header$
+
+SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !    *******************************************************************
+  !    ....   calcul du geopotentiel aux milieux des couches    .....
+  !    *******************************************************************
+  !
+  ! ....   l'integration se fait de bas en haut  ....
+  !
+  ! .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+  !          phi               est un  argum. de sortie pour le s-pg .
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: ngrid
+  REAL :: teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , &
+        phi(ngrid,llm)
+
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l, ij
+
+
+  !-----------------------------------------------------------------------
+  ! calcul de phi au niveau 1 pres du sol  .....
+
+  DO   ij  = 1, ngrid
+  phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+  END DO
+
+  ! calcul de phi aux niveaux superieurs  .......
+
+  DO  l = 2,llm
+    DO  ij    = 1,ngrid
+    phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) &
+          *   (  pk(ij,l-1) -  pk(ij,l)    )
+    ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE geopot
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/gr_ecrit_fi.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_ecrit_fi.F	(revision 5104)
+++ 	(revision )
@@ -1,32 +1,0 @@
-
-! $Header$
-
-	SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi)
-
-	IMPLICIT none
-
-c Transformer une variable de la grille d'ecriture a la grille physique
-	
-	INTEGER nfield,nlon,iim,jjmp1, jjm
-      REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield)
-c
-      INTEGER i, j, n, ig
-c
-c	PRINT*,'iim jjm ',iim,jjm
-
-c modif par abd 21 02 01
-
-        jjm = jjmp1 - 1
-	do n = 1, nfield
-	    fi(1,n) = ecrit(1,1,n)
-            fi(nlon,n) = ecrit(1,jjm+1,n)
-         DO j = 2, jjm
-            ig = 2+(j-2)*iim
-            DO i = 1, iim
-	     fi(ig-1+i,n) = ecrit(i,j,n)
-            ENDDO
-         ENDDO
-      ENDDO
-      RETURN
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_ecrit_fi.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_ecrit_fi.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_ecrit_fi.f90	(revision 5105)
@@ -0,0 +1,32 @@
+
+! $Header$
+
+  SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi)
+
+    IMPLICIT none
+
+  ! Transformer une variable de la grille d'ecriture a la grille physique
+
+    INTEGER :: nfield,nlon,iim,jjmp1, jjm
+  REAL :: fi(nlon,nfield), ecrit(iim,jjmp1,nfield)
+  !
+  INTEGER :: i, j, n, ig
+  !
+  ! PRINT*,'iim jjm ',iim,jjm
+
+  ! modif par abd 21 02 01
+
+    jjm = jjmp1 - 1
+    do n = 1, nfield
+        fi(1,n) = ecrit(1,1,n)
+        fi(nlon,n) = ecrit(1,jjm+1,n)
+     DO j = 2, jjm
+        ig = 2+(j-2)*iim
+        DO i = 1, iim
+         fi(ig-1+i,n) = ecrit(i,j,n)
+        ENDDO
+     ENDDO
+  ENDDO
+  RETURN
+END SUBROUTINE gr_ecrit_fi
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/gr_int_dyn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_int_dyn.F	(revision 5104)
+++ 	(revision )
@@ -1,49 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_int_dyn(champin,champdyn,iim,jp1)
-      implicit none
-c=======================================================================
-c   passage d'un champ interpole a un champ sur grille scalaire
-c=======================================================================
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER iim
-      integer ip1, jp1
-      REAL champin(iim, jp1)
-      REAL champdyn(iim+1, jp1)
-
-      INTEGER i, j
-      real polenord, polesud
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-      ip1 = iim + 1
-      polenord = 0.
-      polesud = 0.
-      do i = 1, iim
-        polenord = polenord + champin (i, 1)
-        polesud = polesud + champin (i, jp1)
-      enddo
-      polenord = polenord / iim
-      polesud = polesud / iim
-      do j = 1, jp1
-        do i = 1, iim
-          if (j == 1) then
-            champdyn(i, j) = polenord
-          else if (j == jp1) then
-            champdyn(i, j) = polesud
-          else
-            champdyn(i, j) = champin (i, j)
-          endif
-        enddo
-        champdyn(ip1, j) = champdyn(1, j)
-      enddo
-
-      RETURN
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_int_dyn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_int_dyn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_int_dyn.f90	(revision 5105)
@@ -0,0 +1,49 @@
+
+! $Header$
+
+SUBROUTINE gr_int_dyn(champin,champdyn,iim,jp1)
+  implicit none
+  !=======================================================================
+  !   passage d'un champ interpole a un champ sur grille scalaire
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   declarations:
+  !   -------------
+
+  INTEGER :: iim
+  integer :: ip1, jp1
+  REAL :: champin(iim, jp1)
+  REAL :: champdyn(iim+1, jp1)
+
+  INTEGER :: i, j
+  real :: polenord, polesud
+
+  !-----------------------------------------------------------------------
+  !   calcul:
+  !   -------
+
+  ip1 = iim + 1
+  polenord = 0.
+  polesud = 0.
+  do i = 1, iim
+    polenord = polenord + champin (i, 1)
+    polesud = polesud + champin (i, jp1)
+  enddo
+  polenord = polenord / iim
+  polesud = polesud / iim
+  do j = 1, jp1
+    do i = 1, iim
+      if (j == 1) then
+        champdyn(i, j) = polenord
+      else if (j == jp1) then
+        champdyn(i, j) = polesud
+      else
+        champdyn(i, j) = champin (i, j)
+      endif
+    enddo
+    champdyn(ip1, j) = champdyn(1, j)
+  enddo
+
+  RETURN
+END SUBROUTINE gr_int_dyn
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.F	(revision 5104)
+++ 	(revision )
@@ -1,60 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_u_scal(nx,x_u,x_scal)
-c%W%    %G%
-c=======================================================================
-c
-c   Author:    Frederic Hourdin      original: 11/11/92
-c   -------
-c
-c   Subject:
-c   ------
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER nx
-      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
-
-c   Local:
-c   ------
-
-      INTEGER l,ij
-
-c-----------------------------------------------------------------------
-
-      DO l=1,nx
-         DO ij=ip1jmp1,2,-1
-            x_scal(ij,l)=
-     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
-     s      /(aireu(ij)+aireu(ij-1))
-         ENDDO
-      ENDDO
-
-      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.f90	(revision 5105)
@@ -0,0 +1,60 @@
+
+! $Header$
+
+SUBROUTINE gr_u_scal(nx,x_u,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: nx
+  REAL :: x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l,ij
+
+  !-----------------------------------------------------------------------
+
+  DO l=1,nx
+     DO ij=ip1jmp1,2,-1
+        x_scal(ij,l)= &
+              (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) &
+              /(aireu(ij)+aireu(ij-1))
+     ENDDO
+  ENDDO
+
+  CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+
+  RETURN
+END SUBROUTINE gr_u_scal
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/gr_v_scal.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_v_scal.F	(revision 5104)
+++ 	(revision )
@@ -1,64 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_v_scal(nx,x_v,x_scal)
-c%W%    %G%
-c=======================================================================
-c
-c   Author:    Frederic Hourdin      original: 11/11/92
-c   -------
-c
-c   Subject:
-c   ------
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER nx
-      REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
-
-c   Local:
-c   ------
-
-      INTEGER l,ij
-
-c-----------------------------------------------------------------------
-
-      DO l=1,nx
-         DO ij=iip2,ip1jm
-            x_scal(ij,l)=
-     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
-     s      /(airev(ij-iip1)+airev(ij))
-         ENDDO
-         DO ij=1,iip1
-            x_scal(ij,l)=0.
-         ENDDO
-         DO ij=ip1jm+1,ip1jmp1
-            x_scal(ij,l)=0.
-         ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_v_scal.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_v_scal.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_v_scal.f90	(revision 5105)
@@ -0,0 +1,64 @@
+
+! $Header$
+
+SUBROUTINE gr_v_scal(nx,x_v,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: nx
+  REAL :: x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l,ij
+
+  !-----------------------------------------------------------------------
+
+  DO l=1,nx
+     DO ij=iip2,ip1jm
+        x_scal(ij,l)= &
+              (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
+              /(airev(ij-iip1)+airev(ij))
+     ENDDO
+     DO ij=1,iip1
+        x_scal(ij,l)=0.
+     ENDDO
+     DO ij=ip1jm+1,ip1jmp1
+        x_scal(ij,l)=0.
+     ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE gr_v_scal
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/grad.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grad.F	(revision 5104)
+++ 	(revision )
@@ -1,44 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE  grad(klevel, pg,pgx,pgy )
-c
-c      P. Le Van
-c
-c    ******************************************************************
-c     .. calcul des composantes covariantes en x et y du gradient de g
-c
-c    ******************************************************************
-c             pg        est un   argument  d'entree pour le s-prog
-c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INTEGER klevel
-      REAL  pg( ip1jmp1,klevel )
-      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
-      INTEGER  l,ij
-c
-c
-      DO l = 1,klevel
-c
-      DO ij = 1, ip1jmp1 - 1
-      pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
-      END DO
-c
-c    .... correction pour  pgx(ip1,j,l)  ....
-c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
-CDIR$ IVDEP
-      DO ij = iip1, ip1jmp1, iip1
-      pgx( ij,l ) = pgx( ij -iim,l )
-      END DO
-c
-      DO ij = 1,ip1jm
-      pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grad.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grad.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grad.f90	(revision 5105)
@@ -0,0 +1,44 @@
+
+! $Header$
+
+SUBROUTINE  grad(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ip1jmp1,klevel )
+  REAL :: pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+  INTEGER :: l,ij
+  !
+  !
+  DO l = 1,klevel
+  !
+  DO ij = 1, ip1jmp1 - 1
+  pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO ij = iip1, ip1jmp1, iip1
+  pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  DO ij = 1,ip1jm
+  pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE grad
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.F	(revision 5104)
+++ 	(revision )
@@ -1,56 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
-c
-c    Auteur :   P. Le Van
-c
-c   ***************************************************************
-c
-c                                ld
-c       calcul  de  (grad (div) )   du vect. v ....
-c
-c     xcov et ycov etant les composant.covariantes de v
-c   ****************************************************************
-c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
-c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
-c
-c
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comdissipn.h"
-
-      INTEGER klevel
-c
-      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
-      REAL gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
-
-      REAL div(ip1jmp1,llm)
-
-      INTEGER l,ij,iter,ld
-c
-c
-c
-      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
-      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
-c
-      DO iter = 1,ld
-c
-      CALL  diverg( klevel,  gdx , gdy, div          )
-      CALL filtreg( div, jjp1, klevel, 2,1, .TRUE.,2 )
-      CALL    grad( klevel,  div, gdx, gdy           )
-c
-      DO l = 1, klevel
-      DO ij = 1, ip1jmp1
-      gdx( ij,l ) = - gdx( ij,l ) * cdivu
-      END DO
-      DO ij = 1, ip1jm
-      gdy( ij,l ) = - gdy( ij,l ) * cdivu
-      END DO
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.f90	(revision 5105)
@@ -0,0 +1,56 @@
+
+! $Header$
+
+SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
+  !
+  !    Auteur :   P. Le Van
+  !
+  !   ***************************************************************
+  !
+  !                            ld
+  !   calcul  de  (grad (div) )   du vect. v ....
+  !
+  ! xcov et ycov etant les composant.covariantes de v
+  !   ****************************************************************
+  !    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+  !     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+  !
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissipn.h"
+
+  INTEGER :: klevel
+  !
+  REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+  REAL :: gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
+
+  REAL :: div(ip1jmp1,llm)
+
+  INTEGER :: l,ij,iter,ld
+  !
+  !
+  !
+  CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+  CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+  !
+  DO iter = 1,ld
+  !
+  CALL  diverg( klevel,  gdx , gdy, div          )
+  CALL filtreg( div, jjp1, klevel, 2,1, .TRUE.,2 )
+  CALL    grad( klevel,  div, gdx, gdy           )
+  !
+  DO l = 1, klevel
+  DO ij = 1, ip1jmp1
+  gdx( ij,l ) = - gdx( ij,l ) * cdivu
+  END DO
+  DO ij = 1, ip1jm
+  gdy( ij,l ) = - gdy( ij,l ) * cdivu
+  END DO
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE gradiv
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.F	(revision 5104)
+++ 	(revision )
@@ -1,79 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
-c
-c     P. Le Van
-c
-c   **********************************************************
-c                                ld
-c       calcul  de  (grad (div) )   du vect. v ....
-c
-c     xcov et ycov etant les composant.covariantes de v
-c   **********************************************************
-c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
-c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
-c
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INCLUDE "comdissipn.h"
-c
-c     ........    variables en arguments      ........
-
-      INTEGER klevel
-      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
-      REAL   gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
-c
-c     ........       variables locales       .........
-c
-      REAL div(ip1jmp1,llm)
-      REAL signe, nugrads
-      INTEGER l,ij,iter,ld
-      
-c    ........................................................
-c
-c
-      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
-      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
-c
-c
-      signe   = (-1.)**ld
-      nugrads = signe * cdivu
-c
-
-
-      CALL    divergf( klevel, gdx,   gdy , div )
-
-      IF( ld>1 )   THEN
-
-        CALL laplacien ( klevel, div,  div     )
-
-c    ......  Iteration de l'operateur laplacien_gam   .......
-
-        DO iter = 1, ld -2
-         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
-     *                       unsapolnga1, unsapolsga1,  div, div       )
-        ENDDO
-
-      ENDIF
-
-
-       CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
-       CALL  grad  ( klevel,  div,   gdx,  gdy             )
-
-c
-       DO   l = 1, klevel
-         DO  ij = 1, ip1jmp1
-          gdx( ij,l ) = gdx( ij,l ) * nugrads
-         ENDDO
-         DO  ij = 1, ip1jm
-          gdy( ij,l ) = gdy( ij,l ) * nugrads
-         ENDDO
-       ENDDO
-c
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.f90	(revision 5105)
@@ -0,0 +1,79 @@
+
+! $Header$
+
+SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
+  !
+  ! P. Le Van
+  !
+  !   **********************************************************
+  !                            ld
+  !   calcul  de  (grad (div) )   du vect. v ....
+  !
+  ! xcov et ycov etant les composant.covariantes de v
+  !   **********************************************************
+  ! xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+  !  gdx   et  gdy       sont des arguments de sortie pour le s-prog
+  !
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "comdissipn.h"
+  !
+  ! ........    variables en arguments      ........
+
+  INTEGER :: klevel
+  REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+  REAL :: gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
+  !
+  ! ........       variables locales       .........
+  !
+  REAL :: div(ip1jmp1,llm)
+  REAL :: signe, nugrads
+  INTEGER :: l,ij,iter,ld
+
+  !    ........................................................
+  !
+  !
+  CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+  CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+  !
+  !
+  signe   = (-1.)**ld
+  nugrads = signe * cdivu
+  !
+
+
+  CALL    divergf( klevel, gdx,   gdy , div )
+
+  IF( ld>1 )   THEN
+
+    CALL laplacien ( klevel, div,  div     )
+
+  !    ......  Iteration de l'operateur laplacien_gam   .......
+
+    DO iter = 1, ld -2
+     CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, &
+           unsapolnga1, unsapolsga1,  div, div       )
+    ENDDO
+
+  ENDIF
+
+
+   CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
+   CALL  grad  ( klevel,  div,   gdx,  gdy             )
+
+  !
+   DO   l = 1, klevel
+     DO  ij = 1, ip1jmp1
+      gdx( ij,l ) = gdx( ij,l ) * nugrads
+     ENDDO
+     DO  ij = 1, ip1jm
+      gdy( ij,l ) = gdy( ij,l ) * nugrads
+     ENDDO
+   ENDDO
+  !
+   RETURN
+END SUBROUTINE gradiv2
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradsdef.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradsdef.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradsdef.h	(revision 5105)
@@ -18,6 +18,6 @@
 character*40 title(nfmx),tvar(nvarmx,nfmx)
 
-common/gradsdef/xd,yd,zd,dtime,
-imd,jmd,lmd,iid,jid,ifd,jfd,
-unit,irec,nvar,ivar,itime,nld,firsttime,
+common/gradsdef/xd,yd,zd,dtime, &
+imd,jmd,lmd,iid,jid,ifd,jfd, &
+unit,irec,nvar,ivar,itime,nld,firsttime, &
 var,fichier,title,tvar
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/heavyside.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/heavyside.F	(revision 5104)
+++ 	(revision )
@@ -1,23 +1,0 @@
-
-! $Header$
-
-c
-c
-       FUNCTION heavyside(a)
-
-c      ...   P. Le Van  ....
-c
-       IMPLICIT NONE
-
-       REAL(KIND=8) heavyside , a
-
-       IF ( a<=0. )  THEN
-         heavyside = 0.
-       ELSE
-         heavyside = 1.
-       ENDIF
-
-       RETURN
-       END
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/heavyside.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/heavyside.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/heavyside.f90	(revision 5105)
@@ -0,0 +1,23 @@
+
+! $Header$
+
+!
+!
+ FUNCTION heavyside(a)
+
+   ! ...   P. Le Van  ....
+  !
+   IMPLICIT NONE
+
+   REAL(KIND=8) heavyside , a
+
+   IF ( a<=0. )  THEN
+     heavyside = 0.
+   ELSE
+     heavyside = 1.
+   ENDIF
+
+   RETURN
+END FUNCTION heavyside
+
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.F	(revision 5104)
+++ 	(revision )
@@ -1,699 +1,0 @@
-
-! $Id$
-
-c
-c
-      SUBROUTINE inigeom
-c
-c     Auteur :  P. Le Van
-c
-c   ............      Version  du 01/04/2001     ........................
-c
-c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
-c     endroits que les aires aireij1,..aireij4 .
-
-c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
-c
-c
-      use fxhyp_m, only: fxhyp
-      use fyhyp_m, only: fyhyp
-      USE comconst_mod, ONLY: pi, g, omeg, rad
-      USE logic_mod, ONLY: fxyhypb, ysinus
-      USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy,
-     &		alphax,alphay,taux,tauy,transx,transy,pxo,pyo
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-      include "comdissnew.h"
-
-c-----------------------------------------------------------------------
-c   ....  Variables  locales   ....
-c
-      INTEGER  i,j,itmax,itmay,iter
-      REAL cvu(iip1,jjp1),cuv(iip1,jjm)
-      REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
-      REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm
-      REAL coslatm,coslatp,radclatm,radclatp
-      REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1),
-     *     cuij4(iip1,jjp1)
-      REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1),
-     *     cvij4(iip1,jjp1)
-      REAL rlonvv(iip1),rlatuu(jjp1)
-      REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) ,
-     *     yprimv(jjm),yprimu(jjp1)
-      REAL gamdi_gdiv, gamdi_grot, gamdi_h
- 
-      REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),
-     ,  xprimp025(iip1)
-      SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
-      SAVE rlonm025,xprimm025,rlonp025,xprimp025
-
-      REAL      SSUM
-c
-c
-c   ------------------------------------------------------------------
-c   -                                                                -
-c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
-c   -                                                                -
-c   ------------------------------------------------------------------
-c
-c      les coef. ( cu, cv ) permettent de passer des vitesses naturelles
-c      aux vitesses covariantes et contravariantes , ou vice-versa ...
-c
-c
-c     on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
-c             v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
-c
-c       on en tire :  u(covariant) = cu * cu * u(contravariant)
-c                     v(covariant) = cv * cv * v(contravariant)
-c
-c
-c     on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
-c                                                          =     =
-c                                           et   - jm/2    <  Y  < jm/2
-c                                                          =     =
-c
-c      ...................................................
-c      ...................................................
-c      .  x  est la longitude du point  en radians       .
-c      .  y  est la  latitude du point  en radians       .
-c      .                                                 .
-c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
-c      .          cv( j ) = rad          * dy/dY         .
-c      .        aire(i,j) =  cu(i,j) * cv(j)             .
-c      .                                                 .
-c      . y, dx/dX, dy/dY calcules aux points concernes   .
-c      .                                                 .
-c      ...................................................
-c      ...................................................
-c
-c
-c
-c                                                           ,
-c    cv , bien que dependant de j uniquement,sera ici indice aussi en i
-c          pour un adressage plus facile en  ij  .
-c
-c
-c
-c  **************  aux points  u  et  v ,           *****************
-c      xprimu et xprimv sont respectivement les valeurs de  dx/dX
-c      yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
-c      rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
-c      cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
-c
-c  **************  aux points u, v, scalaires, et z  ****************
-c      cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
-c
-c
-c
-c         Exemple de distribution de variables sur la grille dans le
-c             domaine de travail ( X,Y ) .
-c     ................................................................
-c                  DX=DY= 1
-c
-c   
-c        +     represente  un  point scalaire ( p.exp  la pression )
-c        >     represente  la composante zonale du  vent
-c        V     represente  la composante meridienne du vent
-c        o     represente  la  vorticite
-c
-c       ----  , car aux poles , les comp.zonales covariantes sont nulles
-c
-c
-c
-c         i ->
-c
-c         1      2      3      4      5      6      7      8
-c  j
-c  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
-c
-c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
-c
-c     2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
-c
-c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
-c
-c     3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
-c
-c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
-c
-c     4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
-c
-c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
-c
-c     5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
-c
-c
-c      Ci-dessus,  on voit que le nombre de pts.en longitude est egal
-c                 a   IM = 8
-c      De meme ,   le nombre d'intervalles entre les 2 poles est egal
-c                 a   JM = 4
-c
-c      Les points scalaires ( + ) correspondent donc a des valeurs
-c       entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
-c
-c      Les vents    U       ( > ) correspondent a des valeurs  semi-
-c       entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
-c
-c      Les vents    V       ( V ) correspondent a des valeurs entieres
-c       de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
-c
-c
-c
-      WRITE(6,3) 
- 3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
-     * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
-     *  5x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux 
-     * '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
-c
-c
-      IF( nitergdiv/=2 ) THEN
-        gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. )
-      ELSE
-        gamdi_gdiv = 0.
-      ENDIF
-      IF( nitergrot/=2 ) THEN
-        gamdi_grot = coefdis/ ( REAL(nitergrot) -2. )
-      ELSE
-        gamdi_grot = 0.
-      ENDIF
-      IF( niterh/=2 ) THEN
-        gamdi_h = coefdis/ ( REAL(niterh) -2. )
-      ELSE
-        gamdi_h = 0.
-      ENDIF
-
-      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
-     *  nitergdiv,nitergrot,niterh
-c
-      pi    = 2.* ASIN(1.)
-c
-      WRITE(6,990) 
-
-c     ----------------------------------------------------------------
-c
-      IF( .NOT.fxyhypb )   THEN
-c
-c
-       IF( ysinus )  THEN
-c
-        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
-c
-c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
-
-        CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
-     ,                    rlatu2,yprimu2,
-     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
-
-       ELSE
-c
-        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
-
-c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
-c
- 
-        pxo   = clon *pi /180.
-        pyo   = 2.* clat* pi /180.
-c
-c  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
-c
-        itmax = 10
-        eps   = .1e-7
-c
-        xo1 = 0.
-        DO iter = 1, itmax
-        x1  = xo1
-        f   = x1+ alphax *SIN(x1-pxo)
-        df  = 1.+ alphax *COS(x1-pxo)
-        x1  = x1 - f/df
-        xdm = ABS( x1- xo1 )
-        IF( xdm<=eps )GO TO 11
-        xo1 = x1
-      END DO
- 11     CONTINUE
-c
-        transx = xo1
-
-        itmay = 10
-        eps   = .1e-7
-C
-        yo1  = 0.
-        DO iter = 1,itmay
-        y1   = yo1
-        f    = y1 + alphay* SIN(y1-pyo)
-        df   = 1. + alphay* COS(y1-pyo)
-        y1   = y1 -f/df
-        ydm  = ABS(y1-yo1)
-        IF(ydm<=eps) GO TO 17
-        yo1  = y1
-      END DO
-c
- 17     CONTINUE
-        transy = yo1
-
-        CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
-     ,              rlatu2,yprimu2,
-     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
-
-       ENDIF
-c
-      ELSE
-c
-c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
-c   .....................................................................
-
-      WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
- 
-      CALL fyhyp(rlatu, yprimu, rlatv, rlatu2, yprimu2, rlatu1, yprimu1)
-      CALL fxhyp(xprimm025, rlonv, xprimv, rlonu, xprimu, xprimp025)
-  
-      ENDIF
-c
-c  -------------------------------------------------------------------
-
-c
-      rlatu(1)    =     ASIN(1.)
-      rlatu(jjp1) =  - rlatu(1)
-c
-c
-c   ....  calcul  aux  poles  ....
-c
-      yprimu(1)      = 0.
-      yprimu(jjp1)   = 0.
-c
-c
-      un4rad2 = 0.25 * rad * rad
-c
-c   --------------------------------------------------------------------
-c   --------------------------------------------------------------------
-c   -                                                                  -
-c   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
-c   -      et de   fext ,  force de coriolis  extensive  .             -
-c   -                                                                  -
-c   --------------------------------------------------------------------
-c   --------------------------------------------------------------------
-c
-c
-c
-c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
-c   affectees 4 aires entourant P , calculees respectivement aux points
-c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
-c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
-c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
-c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
-c
-c           ,
-c   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
-c   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
-c   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
-c   point (i,j) .
-c   On definit en outre les coefficients  alpha comme etant egaux a
-c    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
-c
-c   De meme, toute aire centree en 1 point U est egale a la somme des
-c   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
-c    Idem pour  airev, airez .
-c
-c       On a ,pour chaque maille :    dX = dY = 1
-c
-c
-c                             . V
-c
-c                 aireij4 .        . aireij1
-c
-c                   U .       . P      . U
-c
-c                 aireij3 .        . aireij2
-c
-c                             . V
-c
-c
-c
-c
-c
-c   ....................................................................
-c
-c    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
-c   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
-c   taires cuij et les 4 elongat. cvij qui sont calculees aux memes 
-c     endroits  que les aireij   .    
-c
-c   ....................................................................
-c
-c     .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
-c
-c
-      DO j = 1, jjp1
-c
-      IF ( j == 1 )  THEN
-c
-      yprm           = yprimu1(j)
-      rlatm          = rlatu1(j)
-c
-      coslatm        = COS( rlatm )
-      radclatm       = 0.5* rad * coslatm
-c
-      DO i = 1, iim
-      xprp           = xprimp025( i )
-      xprm           = xprimm025( i )
-      aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
-      aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
-      cuij2  ( i,1 ) = radclatm * xprp
-      cuij3  ( i,1 ) = radclatm * xprm
-      cvij2  ( i,1 ) = 0.5* rad * yprm
-      cvij3  ( i,1 ) = cvij2(i,1)
-      END DO
-c
-      DO  i = 1, iim
-      aireij1( i,1 ) = 0.
-      aireij4( i,1 ) = 0.
-      cuij1  ( i,1 ) = 0.
-      cuij4  ( i,1 ) = 0.
-      cvij1  ( i,1 ) = 0.
-      cvij4  ( i,1 ) = 0.
-      ENDDO
-c
-      END IF
-c
-      IF ( j == jjp1 )  THEN
-       yprp               = yprimu2(j-1)
-       rlatp              = rlatu2 (j-1)
-ccc       yprp             = fyprim( REAL(j) - 0.25 )
-ccc       rlatp            = fy    ( REAL(j) - 0.25 )
-c
-      coslatp             = COS( rlatp )
-      radclatp            = 0.5* rad * coslatp
-c
-      DO i = 1,iim
-        xprp              = xprimp025( i )
-        xprm              = xprimm025( i )
-        aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
-        aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
-        cuij1(i,jjp1)     = radclatp * xprp
-        cuij4(i,jjp1)     = radclatp * xprm
-        cvij1(i,jjp1)     = 0.5 * rad* yprp
-        cvij4(i,jjp1)     = cvij1(i,jjp1)
-      END DO
-c
-       DO   i    = 1, iim
-        aireij2( i,jjp1 ) = 0.
-        aireij3( i,jjp1 ) = 0.
-        cvij2  ( i,jjp1 ) = 0.
-        cvij3  ( i,jjp1 ) = 0.
-        cuij2  ( i,jjp1 ) = 0.
-        cuij3  ( i,jjp1 ) = 0.
-       ENDDO
-c
-      END IF
-c
-
-      IF ( j > 1 .AND. j < jjp1 )  THEN
-c
-        rlatp    = rlatu2 ( j-1 )
-        yprp     = yprimu2( j-1 )
-        rlatm    = rlatu1 (  j  )
-        yprm     = yprimu1(  j  )
-cc         rlatp    = fy    ( REAL(j) - 0.25 )
-cc         yprp     = fyprim( REAL(j) - 0.25 )
-cc         rlatm    = fy    ( REAL(j) + 0.25 )
-cc         yprm     = fyprim( REAL(j) + 0.25 )
-
-         coslatm  = COS( rlatm )
-         coslatp  = COS( rlatp )
-         radclatp = 0.5* rad * coslatp
-         radclatm = 0.5* rad * coslatm
-c
-         ai14            = un4rad2 * coslatp * yprp
-         ai23            = un4rad2 * coslatm * yprm
-         DO i = 1,iim
-         xprp            = xprimp025( i )
-         xprm            = xprimm025( i )
-      
-         aireij1 ( i,j ) = ai14 * xprp
-         aireij2 ( i,j ) = ai23 * xprp
-         aireij3 ( i,j ) = ai23 * xprm
-         aireij4 ( i,j ) = ai14 * xprm
-         cuij1   ( i,j ) = radclatp * xprp
-         cuij2   ( i,j ) = radclatm * xprp
-         cuij3   ( i,j ) = radclatm * xprm
-         cuij4   ( i,j ) = radclatp * xprm
-         cvij1   ( i,j ) = 0.5* rad * yprp
-         cvij2   ( i,j ) = 0.5* rad * yprm
-         cvij3   ( i,j ) = cvij2(i,j)
-         cvij4   ( i,j ) = cvij1(i,j)
-      END DO
-c
-      END IF
-c
-c    ........       periodicite   ............
-c
-         cvij1   (iip1,j) = cvij1   (1,j)
-         cvij2   (iip1,j) = cvij2   (1,j)
-         cvij3   (iip1,j) = cvij3   (1,j)
-         cvij4   (iip1,j) = cvij4   (1,j)
-         cuij1   (iip1,j) = cuij1   (1,j)
-         cuij2   (iip1,j) = cuij2   (1,j)
-         cuij3   (iip1,j) = cuij3   (1,j)
-         cuij4   (iip1,j) = cuij4   (1,j)
-         aireij1 (iip1,j) = aireij1 (1,j )
-         aireij2 (iip1,j) = aireij2 (1,j )
-         aireij3 (iip1,j) = aireij3 (1,j )
-         aireij4 (iip1,j) = aireij4 (1,j )
-        
-      END DO
-c
-c    ..............................................................
-c
-      DO j = 1, jjp1
-      DO i = 1, iim
-      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
-     *                          aireij4(i,j)
-      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
-      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
-      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
-      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
-      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
-      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
-      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
-      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
-      END DO
-c
-c
-      aire    (iip1,j) = aire    (1,j)
-      alpha1  (iip1,j) = alpha1  (1,j)
-      alpha2  (iip1,j) = alpha2  (1,j)
-      alpha3  (iip1,j) = alpha3  (1,j)
-      alpha4  (iip1,j) = alpha4  (1,j)
-      alpha1p2(iip1,j) = alpha1p2(1,j)
-      alpha1p4(iip1,j) = alpha1p4(1,j)
-      alpha2p3(iip1,j) = alpha2p3(1,j)
-      alpha3p4(iip1,j) = alpha3p4(1,j)
-      END DO
-c
-
-      DO j = 1,jjp1
-      DO i = 1,iim
-      aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
-     *                                aireij3(i+1,j)
-      unsaire    ( i,j)= 1./ aire(i,j)
-      unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
-      unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
-      airesurg   ( i,j)= aire(i,j)/ g
-      END DO
-      aireu     (iip1,j)  = aireu  (1,j)
-      unsaire   (iip1,j)  = unsaire(1,j)
-      unsair_gam1(iip1,j) = unsair_gam1(1,j)
-      unsair_gam2(iip1,j) = unsair_gam2(1,j)
-      airesurg   (iip1,j) = airesurg(1,j)
-      END DO
-c
-c
-      DO j = 1,jjm
-c
-        DO i=1,iim
-         airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
-     *                           aireij4(i,j+1)
-        ENDDO
-         DO i=1,iim
-          airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) +
-     *                           aireij4(i+1,j+1)
-          unsairez(i,j) = 1./ airez
-          unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
-          fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
-         ENDDO
-        airev     (iip1,j)  = airev(1,j)
-        unsairez  (iip1,j)  = unsairez(1,j)
-        fext      (iip1,j)  = fext(1,j)
-        unsairz_gam(iip1,j) = unsairz_gam(1,j)
-c
-      END DO
-c
-c
-c    .....      Calcul  des elongations cu,cv, cvu     .........
-c
-      DO    j   = 1, jjm
-       DO   i  = 1, iim
-       cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
-       cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
-       cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
-       unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
-       ENDDO
-       DO   i  = 1, iim
-       cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
-       cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
-       cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
-       cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
-       cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
-       ENDDO
-       cv       (iip1,j)  = cv       (1,j)
-       cvu      (iip1,j)  = cvu      (1,j)
-       unscv2   (iip1,j)  = unscv2   (1,j)
-       cuv      (iip1,j)  = cuv      (1,j)
-       cuvsurcv (iip1,j)  = cuvsurcv (1,j)
-       cvsurcuv (iip1,j)  = cvsurcuv (1,j)
-       cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
-       cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
-       cvscuvgam(iip1,j)  = cvscuvgam(1,j)
-      ENDDO
-
-      DO  j     = 2, jjm
-        DO   i  = 1, iim
-        cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
-        unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
-        cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
-        cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
-        cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) 
-        cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    ) 
-        cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
-        ENDDO
-        cu       (iip1,j)  = cu(1,j)
-        unscu2   (iip1,j)  = unscu2(1,j)
-        cvusurcu (iip1,j)  = cvusurcu(1,j)
-        cusurcvu (iip1,j)  = cusurcvu(1,j)
-        cvuscugam1(iip1,j) = cvuscugam1(1,j)
-        cvuscugam2(iip1,j) = cvuscugam2(1,j)
-        cuscvugam (iip1,j) = cuscvugam(1,j)
-      ENDDO
-
-c
-c   ....  calcul aux  poles  ....
-c
-      DO    i      =  1, iip1
-        cu    ( i, 1 )  =   0.
-        unscu2( i, 1 )  =   0.
-        cvu   ( i, 1 )  =   0.
-c
-        cu    (i, jjp1) =   0.
-        unscu2(i, jjp1) =   0.
-        cvu   (i, jjp1) =   0.
-      ENDDO
-c
-c    ..............................................................
-c
-      DO j = 1, jjm
-        DO i= 1, iim
-         airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
-         aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
-        ENDDO
-         airvscu2  (iip1,j)  = airvscu2(1,j)
-         aivscu2gam(iip1,j)  = aivscu2gam(1,j)
-      ENDDO
-
-      DO j=2,jjm
-        DO i=1,iim
-         airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
-         aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot ) 
-        ENDDO
-         airuscv2  (iip1,j)  = airuscv2  (1,j)
-         aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
-      ENDDO
-
-c
-c   calcul des aires aux  poles :
-c   -----------------------------
-c
-      apoln       = SSUM(iim,aire(1,1),1)
-      apols       = SSUM(iim,aire(1,jjp1),1)
-      unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
-      unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
-      unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
-      unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
-c
-c-----------------------------------------------------------------------
-c     gtitre='Coriolis version ancienne'
-c     gfichier='fext1'
-c     CALL writestd(fext,iip1*jjm)
-c
-c   changement F. Hourdin calcul conservatif pour fext
-c   constang contient le produit a * cos ( latitude ) * omega
-c
-      DO i=1,iim
-         constang(i,1) = 0.
-      ENDDO
-      DO j=1,jjm-1
-        DO i=1,iim
-         constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
-        ENDDO
-      ENDDO
-      DO i=1,iim
-         constang(i,jjp1) = 0.
-      ENDDO
-c
-c   periodicite en longitude
-c
-      DO j=1,jjm
-        fext(iip1,j)     = fext(1,j)
-      ENDDO
-      DO j=1,jjp1
-        constang(iip1,j) = constang(1,j)
-      ENDDO
-
-c fin du changement
-
-c
-c-----------------------------------------------------------------------
-c
-       WRITE(6,*) '   ***  Coordonnees de la grille  *** '
-       WRITE(6,995)
-c
-       WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
-       WRITE(6,995)
-        DO i=1,iip1
-         rlonvv(i) = rlonv(i)*180./pi
-        ENDDO
-       WRITE(6,400) rlonvv
-c
-       WRITE(6,995)
-       WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
-       WRITE(6,995)
-        DO i=1,jjm
-         rlatuu(i)=rlatv(i)*180./pi
-        ENDDO
-       WRITE(6,400) (rlatuu(i),i=1,jjm)
-c
-        DO i=1,iip1
-          rlonvv(i)=rlonu(i)*180./pi
-        ENDDO
-       WRITE(6,995)
-       WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
-       WRITE(6,995)
-       WRITE(6,400) rlonvv
-       WRITE(6,995)
-
-       WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
-       WRITE(6,995)
-        DO i=1,jjp1
-         rlatuu(i)=rlatu(i)*180./pi
-        ENDDO
-       WRITE(6,400) (rlatuu(i),i=1,jjp1)
-       WRITE(6,995)
-c
-444    format(f10.3,f6.0)
-400    FORMAT(1x,8f8.2)
-990    FORMAT(//)
-995    FORMAT(/)
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.f90	(revision 5105)
@@ -0,0 +1,699 @@
+
+! $Id$
+
+!
+!
+SUBROUTINE inigeom
+  !
+  ! Auteur :  P. Le Van
+  !
+  !   ............      Version  du 01/04/2001     ........................
+  !
+  !  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+  ! endroits que les aires aireij1,..aireij4 .
+
+  !  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+  !
+  !
+  use fxhyp_m, only: fxhyp
+  use fyhyp_m, only: fyhyp
+  USE comconst_mod, ONLY: pi, g, omeg, rad
+  USE logic_mod, ONLY: fxyhypb, ysinus
+  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
+        alphax,alphay,taux,tauy,transx,transy,pxo,pyo
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "comdissnew.h"
+
+  !-----------------------------------------------------------------------
+  !   ....  Variables  locales   ....
+  !
+  INTEGER :: i,j,itmax,itmay,iter
+  REAL :: cvu(iip1,jjp1),cuv(iip1,jjm)
+  REAL :: ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
+  REAL :: eps,x1,xo1,f,df,xdm,y1,yo1,ydm
+  REAL :: coslatm,coslatp,radclatm,radclatp
+  REAL :: cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1), &
+        cuij4(iip1,jjp1)
+  REAL :: cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1), &
+        cvij4(iip1,jjp1)
+  REAL :: rlonvv(iip1),rlatuu(jjp1)
+  REAL :: rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) , &
+        yprimv(jjm),yprimu(jjp1)
+  REAL :: gamdi_gdiv, gamdi_grot, gamdi_h
+
+  REAL :: rlonm025(iip1),xprimm025(iip1), rlonp025(iip1), &
+        xprimp025(iip1)
+  SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
+  SAVE rlonm025,xprimm025,rlonp025,xprimp025
+
+  REAL :: SSUM
+  !
+  !
+  !   ------------------------------------------------------------------
+  !   -                                                                -
+  !   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+  !   -                                                                -
+  !   ------------------------------------------------------------------
+  !
+  !  les coef. ( cu, cv ) permettent de passer des vitesses naturelles
+  !  aux vitesses covariantes et contravariantes , ou vice-versa ...
+  !
+  !
+  ! on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
+  !         v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
+  !
+  !   on en tire :  u(covariant) = cu * cu * u(contravariant)
+  !                 v(covariant) = cv * cv * v(contravariant)
+  !
+  !
+  ! on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
+  !                                                      =     =
+  !                                       et   - jm/2    <  Y  < jm/2
+  !                                                      =     =
+  !
+  !  ...................................................
+  !  ...................................................
+  !  .  x  est la longitude du point  en radians       .
+  !  .  y  est la  latitude du point  en radians       .
+  !  .                                                 .
+  !  .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+  !  .          cv( j ) = rad          * dy/dY         .
+  !  .        aire(i,j) =  cu(i,j) * cv(j)             .
+  !  .                                                 .
+  !  . y, dx/dX, dy/dY calcules aux points concernes   .
+  !  .                                                 .
+  !  ...................................................
+  !  ...................................................
+  !
+  !
+  !
+  !                                                       ,
+  !    cv , bien que dependant de j uniquement,sera ici indice aussi en i
+  !      pour un adressage plus facile en  ij  .
+  !
+  !
+  !
+  !  **************  aux points  u  et  v ,           *****************
+  !  xprimu et xprimv sont respectivement les valeurs de  dx/dX
+  !  yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
+  !  rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
+  !  cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
+  !
+  !  **************  aux points u, v, scalaires, et z  ****************
+  !  cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
+  !
+  !
+  !
+  !     Exemple de distribution de variables sur la grille dans le
+  !         domaine de travail ( X,Y ) .
+  ! ................................................................
+  !              DX=DY= 1
+  !
+  !
+  !    +     represente  un  point scalaire ( p.exp  la pression )
+  !    >     represente  la composante zonale du  vent
+  !    V     represente  la composante meridienne du vent
+  !    o     represente  la  vorticite
+  !
+  !   ----  , car aux poles , les comp.zonales covariantes sont nulles
+  !
+  !
+  !
+  !     i ->
+  !
+  !     1      2      3      4      5      6      7      8
+  !  j
+  !  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+  !
+  !     V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+  !
+  ! 2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+  !
+  !     V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+  !
+  ! 3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+  !
+  !     V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+  !
+  ! 4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+  !
+  !     V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+  !
+  ! 5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+  !
+  !
+  !  Ci-dessus,  on voit que le nombre de pts.en longitude est egal
+  !             a   IM = 8
+  !  De meme ,   le nombre d'intervalles entre les 2 poles est egal
+  !             a   JM = 4
+  !
+  !  Les points scalaires ( + ) correspondent donc a des valeurs
+  !   entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
+  !
+  !  Les vents    U       ( > ) correspondent a des valeurs  semi-
+  !   entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
+  !
+  !  Les vents    V       ( V ) correspondent a des valeurs entieres
+  !   de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
+  !
+  !
+  !
+  WRITE(6,3)
+ 3   FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ', &
+           //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' / &
+         5  x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux&
+           & '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
+  !
+  !
+  IF( nitergdiv/=2 ) THEN
+    gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. )
+  ELSE
+    gamdi_gdiv = 0.
+  ENDIF
+  IF( nitergrot/=2 ) THEN
+    gamdi_grot = coefdis/ ( REAL(nitergrot) -2. )
+  ELSE
+    gamdi_grot = 0.
+  ENDIF
+  IF( niterh/=2 ) THEN
+    gamdi_h = coefdis/ ( REAL(niterh) -2. )
+  ELSE
+    gamdi_h = 0.
+  ENDIF
+
+  WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis, &
+        nitergdiv,nitergrot,niterh
+  !
+  pi    = 2.* ASIN(1.)
+  !
+  WRITE(6,990)
+
+  ! ----------------------------------------------------------------
+  !
+  IF( .NOT.fxyhypb )   THEN
+  !
+  !
+   IF( ysinus )  THEN
+  !
+    WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+  !
+  !   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
+
+    CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
+          rlatu2,yprimu2, &
+          rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+   ELSE
+  !
+    WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+
+  !  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
+  !
+
+    pxo   = clon *pi /180.
+    pyo   = 2.* clat* pi /180.
+  !
+  !  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
+  !
+    itmax = 10
+    eps   = .1e-7
+  !
+    xo1 = 0.
+    DO iter = 1, itmax
+    x1  = xo1
+    f   = x1+ alphax *SIN(x1-pxo)
+    df  = 1.+ alphax *COS(x1-pxo)
+    x1  = x1 - f/df
+    xdm = ABS( x1- xo1 )
+    IF( xdm<=eps )GO TO 11
+    xo1 = x1
+  END DO
+ 11   CONTINUE
+  !
+    transx = xo1
+
+    itmay = 10
+    eps   = .1e-7
+  !
+    yo1  = 0.
+    DO iter = 1,itmay
+    y1   = yo1
+    f    = y1 + alphay* SIN(y1-pyo)
+    df   = 1. + alphay* COS(y1-pyo)
+    y1   = y1 -f/df
+    ydm  = ABS(y1-yo1)
+    IF(ydm<=eps) GO TO 17
+    yo1  = y1
+  END DO
+  !
+ 17   CONTINUE
+    transy = yo1
+
+    CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
+          rlatu2,yprimu2, &
+          rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+   ENDIF
+  !
+  ELSE
+  !
+  !   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+  !   .....................................................................
+
+  WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+
+  CALL fyhyp(rlatu, yprimu, rlatv, rlatu2, yprimu2, rlatu1, yprimu1)
+  CALL fxhyp(xprimm025, rlonv, xprimv, rlonu, xprimu, xprimp025)
+
+  ENDIF
+  !
+  !  -------------------------------------------------------------------
+
+  !
+  rlatu(1)    =     ASIN(1.)
+  rlatu(jjp1) =  - rlatu(1)
+  !
+  !
+  !   ....  calcul  aux  poles  ....
+  !
+  yprimu(1)      = 0.
+  yprimu(jjp1)   = 0.
+  !
+  !
+  un4rad2 = 0.25 * rad * rad
+  !
+  !   --------------------------------------------------------------------
+  !   --------------------------------------------------------------------
+  !   -                                                                  -
+  !   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
+  !   -      et de   fext ,  force de coriolis  extensive  .             -
+  !   -                                                                  -
+  !   --------------------------------------------------------------------
+  !   --------------------------------------------------------------------
+  !
+  !
+  !
+  !   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+  !   affectees 4 aires entourant P , calculees respectivement aux points
+  !        ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+  !        ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+  !        ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+  !        ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+  !
+  !       ,
+  !   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
+  !   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
+  !   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
+  !   point (i,j) .
+  !   On definit en outre les coefficients  alpha comme etant egaux a
+  !    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
+  !
+  !   De meme, toute aire centree en 1 point U est egale a la somme des
+  !   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
+  !    Idem pour  airev, airez .
+  !
+  !   On a ,pour chaque maille :    dX = dY = 1
+  !
+  !
+  !                         . V
+  !
+  !             aireij4 .        . aireij1
+  !
+  !               U .       . P      . U
+  !
+  !             aireij3 .        . aireij2
+  !
+  !                         . V
+  !
+  !
+  !
+  !
+  !
+  !   ....................................................................
+  !
+  !    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
+  !   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
+  !   taires cuij et les 4 elongat. cvij qui sont calculees aux memes
+  ! endroits  que les aireij   .
+  !
+  !   ....................................................................
+  !
+  ! .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
+  !
+  !
+  DO j = 1, jjp1
+  !
+  IF ( j == 1 )  THEN
+  !
+  yprm           = yprimu1(j)
+  rlatm          = rlatu1(j)
+  !
+  coslatm        = COS( rlatm )
+  radclatm       = 0.5* rad * coslatm
+  !
+  DO i = 1, iim
+  xprp           = xprimp025( i )
+  xprm           = xprimm025( i )
+  aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
+  aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
+  cuij2  ( i,1 ) = radclatm * xprp
+  cuij3  ( i,1 ) = radclatm * xprm
+  cvij2  ( i,1 ) = 0.5* rad * yprm
+  cvij3  ( i,1 ) = cvij2(i,1)
+  END DO
+  !
+  DO  i = 1, iim
+  aireij1( i,1 ) = 0.
+  aireij4( i,1 ) = 0.
+  cuij1  ( i,1 ) = 0.
+  cuij4  ( i,1 ) = 0.
+  cvij1  ( i,1 ) = 0.
+  cvij4  ( i,1 ) = 0.
+  ENDDO
+  !
+  END IF
+  !
+  IF ( j == jjp1 )  THEN
+   yprp               = yprimu2(j-1)
+   rlatp              = rlatu2 (j-1)
+  !cc       yprp             = fyprim( REAL(j) - 0.25 )
+  !cc       rlatp            = fy    ( REAL(j) - 0.25 )
+  !
+  coslatp             = COS( rlatp )
+  radclatp            = 0.5* rad * coslatp
+  !
+  DO i = 1,iim
+    xprp              = xprimp025( i )
+    xprm              = xprimm025( i )
+    aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
+    aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
+    cuij1(i,jjp1)     = radclatp * xprp
+    cuij4(i,jjp1)     = radclatp * xprm
+    cvij1(i,jjp1)     = 0.5 * rad* yprp
+    cvij4(i,jjp1)     = cvij1(i,jjp1)
+  END DO
+  !
+   DO   i    = 1, iim
+    aireij2( i,jjp1 ) = 0.
+    aireij3( i,jjp1 ) = 0.
+    cvij2  ( i,jjp1 ) = 0.
+    cvij3  ( i,jjp1 ) = 0.
+    cuij2  ( i,jjp1 ) = 0.
+    cuij3  ( i,jjp1 ) = 0.
+   ENDDO
+  !
+  END IF
+  !
+
+  IF ( j > 1 .AND. j < jjp1 )  THEN
+  !
+    rlatp    = rlatu2 ( j-1 )
+    yprp     = yprimu2( j-1 )
+    rlatm    = rlatu1 (  j  )
+    yprm     = yprimu1(  j  )
+  !c         rlatp    = fy    ( REAL(j) - 0.25 )
+  !c         yprp     = fyprim( REAL(j) - 0.25 )
+  !c         rlatm    = fy    ( REAL(j) + 0.25 )
+  !c         yprm     = fyprim( REAL(j) + 0.25 )
+
+     coslatm  = COS( rlatm )
+     coslatp  = COS( rlatp )
+     radclatp = 0.5* rad * coslatp
+     radclatm = 0.5* rad * coslatm
+  !
+     ai14            = un4rad2 * coslatp * yprp
+     ai23            = un4rad2 * coslatm * yprm
+     DO i = 1,iim
+     xprp            = xprimp025( i )
+     xprm            = xprimm025( i )
+
+     aireij1 ( i,j ) = ai14 * xprp
+     aireij2 ( i,j ) = ai23 * xprp
+     aireij3 ( i,j ) = ai23 * xprm
+     aireij4 ( i,j ) = ai14 * xprm
+     cuij1   ( i,j ) = radclatp * xprp
+     cuij2   ( i,j ) = radclatm * xprp
+     cuij3   ( i,j ) = radclatm * xprm
+     cuij4   ( i,j ) = radclatp * xprm
+     cvij1   ( i,j ) = 0.5* rad * yprp
+     cvij2   ( i,j ) = 0.5* rad * yprm
+     cvij3   ( i,j ) = cvij2(i,j)
+     cvij4   ( i,j ) = cvij1(i,j)
+  END DO
+  !
+  END IF
+  !
+  !    ........       periodicite   ............
+  !
+     cvij1   (iip1,j) = cvij1   (1,j)
+     cvij2   (iip1,j) = cvij2   (1,j)
+     cvij3   (iip1,j) = cvij3   (1,j)
+     cvij4   (iip1,j) = cvij4   (1,j)
+     cuij1   (iip1,j) = cuij1   (1,j)
+     cuij2   (iip1,j) = cuij2   (1,j)
+     cuij3   (iip1,j) = cuij3   (1,j)
+     cuij4   (iip1,j) = cuij4   (1,j)
+     aireij1 (iip1,j) = aireij1 (1,j )
+     aireij2 (iip1,j) = aireij2 (1,j )
+     aireij3 (iip1,j) = aireij3 (1,j )
+     aireij4 (iip1,j) = aireij4 (1,j )
+
+  END DO
+  !
+  !    ..............................................................
+  !
+  DO j = 1, jjp1
+  DO i = 1, iim
+  aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + &
+        aireij4(i,j)
+  alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+  alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+  alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+  alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+  alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+  alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+  alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+  alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+  END DO
+  !
+  !
+  aire    (iip1,j) = aire    (1,j)
+  alpha1  (iip1,j) = alpha1  (1,j)
+  alpha2  (iip1,j) = alpha2  (1,j)
+  alpha3  (iip1,j) = alpha3  (1,j)
+  alpha4  (iip1,j) = alpha4  (1,j)
+  alpha1p2(iip1,j) = alpha1p2(1,j)
+  alpha1p4(iip1,j) = alpha1p4(1,j)
+  alpha2p3(iip1,j) = alpha2p3(1,j)
+  alpha3p4(iip1,j) = alpha3p4(1,j)
+  END DO
+  !
+
+  DO j = 1,jjp1
+  DO i = 1,iim
+  aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + &
+        aireij3(i+1,j)
+  unsaire    ( i,j)= 1./ aire(i,j)
+  unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
+  unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
+  airesurg   ( i,j)= aire(i,j)/ g
+  END DO
+  aireu     (iip1,j)  = aireu  (1,j)
+  unsaire   (iip1,j)  = unsaire(1,j)
+  unsair_gam1(iip1,j) = unsair_gam1(1,j)
+  unsair_gam2(iip1,j) = unsair_gam2(1,j)
+  airesurg   (iip1,j) = airesurg(1,j)
+  END DO
+  !
+  !
+  DO j = 1,jjm
+  !
+    DO i=1,iim
+     airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) + &
+           aireij4(i,j+1)
+    ENDDO
+     DO i=1,iim
+      airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) + &
+            aireij4(i+1,j+1)
+      unsairez(i,j) = 1./ airez
+      unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
+      fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
+     ENDDO
+    airev     (iip1,j)  = airev(1,j)
+    unsairez  (iip1,j)  = unsairez(1,j)
+    fext      (iip1,j)  = fext(1,j)
+    unsairz_gam(iip1,j) = unsairz_gam(1,j)
+  !
+  END DO
+  !
+  !
+  !    .....      Calcul  des elongations cu,cv, cvu     .........
+  !
+  DO    j   = 1, jjm
+   DO   i  = 1, iim
+   cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
+   cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
+   cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
+   unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
+   ENDDO
+   DO   i  = 1, iim
+   cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
+   cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
+   cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
+   cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
+   cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
+   ENDDO
+   cv       (iip1,j)  = cv       (1,j)
+   cvu      (iip1,j)  = cvu      (1,j)
+   unscv2   (iip1,j)  = unscv2   (1,j)
+   cuv      (iip1,j)  = cuv      (1,j)
+   cuvsurcv (iip1,j)  = cuvsurcv (1,j)
+   cvsurcuv (iip1,j)  = cvsurcuv (1,j)
+   cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
+   cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
+   cvscuvgam(iip1,j)  = cvscuvgam(1,j)
+  ENDDO
+
+  DO  j     = 2, jjm
+    DO   i  = 1, iim
+    cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
+    unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
+    cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
+    cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
+    cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv )
+    cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    )
+    cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
+    ENDDO
+    cu       (iip1,j)  = cu(1,j)
+    unscu2   (iip1,j)  = unscu2(1,j)
+    cvusurcu (iip1,j)  = cvusurcu(1,j)
+    cusurcvu (iip1,j)  = cusurcvu(1,j)
+    cvuscugam1(iip1,j) = cvuscugam1(1,j)
+    cvuscugam2(iip1,j) = cvuscugam2(1,j)
+    cuscvugam (iip1,j) = cuscvugam(1,j)
+  ENDDO
+
+  !
+  !   ....  calcul aux  poles  ....
+  !
+  DO    i      =  1, iip1
+    cu    ( i, 1 )  =   0.
+    unscu2( i, 1 )  =   0.
+    cvu   ( i, 1 )  =   0.
+  !
+    cu    (i, jjp1) =   0.
+    unscu2(i, jjp1) =   0.
+    cvu   (i, jjp1) =   0.
+  ENDDO
+  !
+  !    ..............................................................
+  !
+  DO j = 1, jjm
+    DO i= 1, iim
+     airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
+     aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
+    ENDDO
+     airvscu2  (iip1,j)  = airvscu2(1,j)
+     aivscu2gam(iip1,j)  = aivscu2gam(1,j)
+  ENDDO
+
+  DO j=2,jjm
+    DO i=1,iim
+     airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
+     aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot )
+    ENDDO
+     airuscv2  (iip1,j)  = airuscv2  (1,j)
+     aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
+  ENDDO
+
+  !
+  !   calcul des aires aux  poles :
+  !   -----------------------------
+  !
+  apoln       = SSUM(iim,aire(1,1),1)
+  apols       = SSUM(iim,aire(1,jjp1),1)
+  unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
+  unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
+  unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
+  unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
+  !
+  !-----------------------------------------------------------------------
+  ! gtitre='Coriolis version ancienne'
+  ! gfichier='fext1'
+  ! CALL writestd(fext,iip1*jjm)
+  !
+  !   changement F. Hourdin calcul conservatif pour fext
+  !   constang contient le produit a * cos ( latitude ) * omega
+  !
+  DO i=1,iim
+     constang(i,1) = 0.
+  ENDDO
+  DO j=1,jjm-1
+    DO i=1,iim
+     constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
+    ENDDO
+  ENDDO
+  DO i=1,iim
+     constang(i,jjp1) = 0.
+  ENDDO
+  !
+  !   periodicite en longitude
+  !
+  DO j=1,jjm
+    fext(iip1,j)     = fext(1,j)
+  ENDDO
+  DO j=1,jjp1
+    constang(iip1,j) = constang(1,j)
+  ENDDO
+
+  ! fin du changement
+
+  !
+  !-----------------------------------------------------------------------
+  !
+   WRITE(6,*) '   ***  Coordonnees de la grille  *** '
+   WRITE(6,995)
+  !
+   WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
+   WRITE(6,995)
+    DO i=1,iip1
+     rlonvv(i) = rlonv(i)*180./pi
+    ENDDO
+   WRITE(6,400) rlonvv
+  !
+   WRITE(6,995)
+   WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
+   WRITE(6,995)
+    DO i=1,jjm
+     rlatuu(i)=rlatv(i)*180./pi
+    ENDDO
+   WRITE(6,400) (rlatuu(i),i=1,jjm)
+  !
+    DO i=1,iip1
+      rlonvv(i)=rlonu(i)*180./pi
+    ENDDO
+   WRITE(6,995)
+   WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
+   WRITE(6,995)
+   WRITE(6,400) rlonvv
+   WRITE(6,995)
+
+   WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
+   WRITE(6,995)
+    DO i=1,jjp1
+     rlatuu(i)=rlatu(i)*180./pi
+    ENDDO
+   WRITE(6,400) (rlatuu(i),i=1,jjp1)
+   WRITE(6,995)
+  !
+444   format(f10.3,f6.0)
+400   FORMAT(1x,8f8.2)
+990   FORMAT(//)
+995   FORMAT(/)
+  !
+  RETURN
+END SUBROUTINE inigeom
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigrads.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigrads.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigrads.f90	(revision 5105)
@@ -31,5 +31,5 @@
   unit(9) = 46
 
-  if (if<=nf) stop'verifier les appels a inigrads'
+  if (if<=nf) stop 'verifier les appels a inigrads'
 
   PRINT*, 'Entree dans inigrads'
@@ -88,4 +88,4 @@
   PRINT*, 'if,imd(if),jmd(if),lmd(if)'
 
-  return
+
 end subroutine inigrads
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.F	(revision 5104)
+++ 	(revision )
@@ -1,222 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE initfluxsto
-     .  (infile,tstep,t_ops,t_wrt,
-     .                    fileid,filevid,filedid)
-
-       USE IOIPSL
-      USE comconst_mod, ONLY: pi
-      USE comvert_mod, ONLY: nivsigs
-      USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-      
-      implicit none
-
-C
-C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-C   au format IOIPSL
-C
-C   Appels succesifs des routines: histbeg
-C                                  histhori
-C                                  histver
-C                                  histdef
-C                                  histend
-C
-C   Entree:
-C
-C      infile: nom du fichier histoire a creer
-C      day0,anne0: date de reference
-C      tstep: duree du pas de temps en seconde
-C      t_ops: frequence de l'operation pour IOIPSL
-C      t_wrt: frequence d'ecriture sur le fichier
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C      filevid:ID du fichier netcdf pour la grille v
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C   Arguments
-C
-      character*(*) infile
-      real tstep, t_ops, t_wrt
-      integer fileid, filevid,filedid
-
-! This routine needs IOIPSL to work
-C   Variables locales
-C
-      real nivd(1)
-      integer tau0
-      real zjulian
-      character*3 str
-      character*10 ctrac
-      integer iq
-      real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
-      integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
-      integer ii,jj
-      integer zan, idayref
-      logical ok_sync
-C
-C  Initialisations
-C
-      pi = 4. * atan (1.)
-      str='q  '
-      ctrac = 'traceur   '
-      ok_sync = .TRUE.
-C
-C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-C
-
-      zan = annee_ref
-      idayref = day_ref
-      CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
-      tau0 = itau_dyn
-
-        do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonu(ii) * 180. / pi
-          rlat(ii,jj) = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-      CALL histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
-     .             1, iip1, 1, jjp1,
-     .             tau0, zjulian, tstep, uhoriid, fileid)
-C
-C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
-C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-C  un meme fichier)
-
-
-      do jj = 1, jjm
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonv(ii) * 180. / pi
-          rlat(ii,jj) = rlatv(jj) * 180. / pi
-        enddo
-      enddo
-
-      CALL histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:),
-     .             1, iip1, 1, jjm,
-     .             tau0, zjulian, tstep, vhoriid, filevid)
-
-        rl(1,1) = 1.
-      CALL histbeg('defstoke.nc', 1, rl, 1, rl,
-     .             1, 1, 1, 1,
-     .             tau0, zjulian, tstep, dhoriid, filedid)
-
-C
-C  Appel a histhori pour rajouter les autres grilles horizontales
-C
-      do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonv(ii) * 180. / pi
-          rlat(ii,jj) = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-      CALL histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar',
-     .              'Grille points scalaires', thoriid)
-
-C
-C  Appel a histvert pour la grille verticale
-C
-      CALL histvert(fileid, 'sig_s', 'Niveaux sigma',
-     . 'sigma_level',
-     .              llm, nivsigs, zvertiid)
-C Pour le fichier V
-      CALL histvert(filevid, 'sig_s', 'Niveaux sigma',
-     .  'sigma_level',
-     .              llm, nivsigs, zvertiid)
-c pour le fichier def
-      nivd(1) = 1
-      CALL histvert(filedid, 'sig_s', 'Niveaux sigma',
-     .  'sigma_level',
-     .              1, nivd, dvertiid)
-
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-
-        CALL histdef(fileid, "phis", "Surface geop. height", "-",
-     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(fileid, "aire", "Grid area", "-",
-     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-        CALL histdef(filedid, "dtvr", "tps dyn", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(filedid, "istdyn", "tps stock", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(filedid, "istphy", "tps stock phy", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-
-C
-C Masse
-C
-      CALL histdef(fileid, 'masse', 'Masse', 'kg',
-     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Pbaru
-C
-      CALL histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
-     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Pbarv
-C
-      CALL histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
-     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  w
-C
-      CALL histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
-     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Temperature potentielle
-C
-      CALL histdef(fileid, 'teta', 'temperature potentielle', '-',
-     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-
-C
-C Geopotentiel
-C
-      CALL histdef(fileid, 'phi', 'geopotentiel instantane', '-',
-     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Fin
-C
-      CALL histend(fileid)
-      CALL histend(filevid)
-      CALL histend(filedid)
-      if (ok_sync) then
-        CALL histsync(fileid)
-        CALL histsync(filevid)
-        CALL histsync(filedid)
-      endif
-
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.f90	(revision 5105)
@@ -0,0 +1,222 @@
+
+! $Id$
+
+SUBROUTINE initfluxsto &
+        (infile,tstep,t_ops,t_wrt, &
+        fileid,filevid,filedid)
+
+   USE IOIPSL
+  USE comconst_mod, ONLY: pi
+  USE comvert_mod, ONLY: nivsigs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !  filevid:ID du fichier netcdf pour la grille v
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  character(len=*) :: infile
+  real :: tstep, t_ops, t_wrt
+  integer :: fileid, filevid,filedid
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+  !
+  real :: nivd(1)
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+  integer :: ii,jj
+  integer :: zan, idayref
+  logical :: ok_sync
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  str='q  '
+  ctrac = 'traceur   '
+  ok_sync = .TRUE.
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+    do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  CALL histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), &
+        1, iip1, 1, jjp1, &
+        tau0, zjulian, tstep, uhoriid, fileid)
+  !
+  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+
+
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  CALL histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:), &
+        1, iip1, 1, jjm, &
+        tau0, zjulian, tstep, vhoriid, filevid)
+
+    rl(1,1) = 1.
+  CALL histbeg('defstoke.nc', 1, rl, 1, rl, &
+        1, 1, 1, 1, &
+        tau0, zjulian, tstep, dhoriid, filedid)
+
+  !
+  !  Appel a histhori pour rajouter les autres grilles horizontales
+  !
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  CALL histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar', &
+        'Grille points scalaires', thoriid)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  CALL histvert(fileid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! Pour le fichier V
+  CALL histvert(filevid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! pour le fichier def
+  nivd(1) = 1
+  CALL histvert(filedid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        1, nivd, dvertiid)
+
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+          iip1,jjp1,thoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(fileid, "aire", "Grid area", "-", &
+           iip1,jjp1,thoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
+          1,1,dhoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istdyn", "tps stock", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+
+  !
+  ! Masse
+  !
+  CALL histdef(fileid, 'masse', 'Masse', 'kg', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbaru
+  !
+  CALL histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
+        iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Pbarv
+  !
+  CALL histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
+        iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  w
+  !
+  CALL histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature potentielle
+  !
+  CALL histdef(fileid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+
+  !
+  ! Geopotentiel
+  !
+  CALL histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  CALL histend(fileid)
+  CALL histend(filevid)
+  CALL histend(filedid)
+  if (ok_sync) then
+    CALL histsync(fileid)
+    CALL histsync(filevid)
+    CALL histsync(filedid)
+  endif
+
+  return
+end subroutine initfluxsto
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.F	(revision 5104)
+++ 	(revision )
@@ -1,43 +1,0 @@
-
-! $Header$
-
-        SUBROUTINE interpost(q,qppm)
-
-       implicit none
-
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-c Arguments   
-      real   q(iip1,jjp1,llm)
-      real   qppm(iim,jjp1,llm)
-c Local
-      integer l,i,j
-  
-c RE-INVERSION DES NIVEAUX
-c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
-c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
-c On passe donc des niveaux de Lin à ceux du LMDZ
-           
-        do l=1,llm
-          do j=1,jjp1
-             do i=1,iim
-                 q(i,j,l)=qppm(i,j,llm-l+1)
-             enddo
-          enddo
-         enddo
-            
-c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
-
-         do l=1,llm
-           do j=1,jjp1
-            q(iip1,j,l)=q(1,j,l)
-           enddo
-         enddo
-  
-      
-       return
-
-       end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.f90	(revision 5105)
@@ -0,0 +1,43 @@
+
+! $Header$
+
+  SUBROUTINE interpost(q,qppm)
+
+   implicit none
+
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  ! Arguments
+  real :: q(iip1,jjp1,llm)
+  real :: qppm(iim,jjp1,llm)
+  ! Local
+  integer :: l,i,j
+
+  ! RE-INVERSION DES NIVEAUX
+  ! le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+  ! de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+  ! On passe donc des niveaux de Lin à ceux du LMDZ
+
+    do l=1,llm
+      do j=1,jjp1
+         do i=1,iim
+             q(i,j,l)=qppm(i,j,llm-l+1)
+         enddo
+      enddo
+     enddo
+
+  ! BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
+
+     do l=1,llm
+       do j=1,jjp1
+        q(iip1,j,l)=q(1,j,l)
+       enddo
+     enddo
+
+
+   return
+
+end subroutine interpost
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.F	(revision 5104)
+++ 	(revision )
@@ -1,128 +1,0 @@
-
-! $Id$
-
-       SUBROUTINE interpre(q,qppm,w,fluxwppm,masse,
-     s            apppm,bpppm,massebx,masseby,pbaru,pbarv,
-     s            unatppm,vnatppm,psppm)
-
-      USE comconst_mod, ONLY: g
-      USE comvert_mod, ONLY: ap, bp
-
-       implicit none
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comdissip.h"
-      include "comgeom2.h"
-      include "description.h"
-
-c---------------------------------------------------
-c Arguments     
-      real   apppm(llm+1),bpppm(llm+1)
-      real   q(iip1,jjp1,llm),qppm(iim,jjp1,llm)
-c---------------------------------------------------
-      real   masse(iip1,jjp1,llm) 
-      real   massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)      
-      real   w(iip1,jjp1,llm)
-      real   fluxwppm(iim,jjp1,llm)
-      real   pbaru(iip1,jjp1,llm )
-      real   pbarv(iip1,jjm,llm)
-      real   unatppm(iim,jjp1,llm)
-      real   vnatppm(iim,jjp1,llm)
-      real   psppm(iim,jjp1)
-c---------------------------------------------------
-c Local
-      real   vnat(iip1,jjp1,llm)
-      real   unat(iip1,jjp1,llm)
-      real   fluxw(iip1,jjp1,llm)
-      real   smass(iip1,jjp1)
-c----------------------------------------------------
-      integer l,ij,i,j
-
-c       CALCUL DE LA PRESSION DE SURFACE
-c       Les coefficients ap et bp sont passés en common
-c       Calcul de la pression au sol en mb optimisée pour
-c       la vectorialisation
-                   
-         do j=1,jjp1
-             do i=1,iip1
-                smass(i,j)=0.
-             enddo
-         enddo
-
-         do l=1,llm
-             do j=1,jjp1
-                 do i=1,iip1
-                    smass(i,j)=smass(i,j)+masse(i,j,l)
-                 enddo
-             enddo
-         enddo
-      
-         do j=1,jjp1
-             do i=1,iim
-                 psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01
-             END DO
-         END DO
-       
-c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS
-c Le programme ppm3d travaille avec les composantes
-c de vitesse et pas les flux, on doit donc passer de l'un à l'autre
-c Dans le même temps, on fait le changement d'orientation du vent en v
-      do l=1,llm
-          do j=1,jjm
-              do i=1,iip1
-                  vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)
-              enddo
-          enddo
-          do  i=1,iim
-          vnat(i,jjp1,l)=0.
-          enddo
-          do j=1,jjp1
-              do i=1,iip1
-                  unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)
-              enddo
-          enddo
-      enddo
-              
-c CALCUL DU FLUX MASSIQUE VERTICAL
-c Flux en l=1 (sol) nul
-      fluxw=0.        
-      do l=1,llm
-           do j=1,jjp1
-              do i=1,iip1              
-               fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j)
-C               PRINT*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l),
-C     c                      'w(i,j,l)=',w(i,j,l)
-              enddo
-           enddo
-      enddo
-      
-c INVERSION DES NIVEAUX
-c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
-c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
-c On passe donc des niveaux du LMDZ à ceux de Lin
-     
-      do l=1,llm+1
-          apppm(l)=ap(llm+2-l)
-          bpppm(l)=bp(llm+2-l)         
-      enddo 
-     
-      do l=1,llm
-          do j=1,jjp1
-             do i=1,iim     
-                 unatppm(i,j,l)=unat(i,j,llm-l+1)
-                 vnatppm(i,j,l)=vnat(i,j,llm-l+1)
-                 fluxwppm(i,j,l)=fluxw(i,j,llm-l+1)
-                 qppm(i,j,l)=q(i,j,llm-l+1)
-             enddo
-          enddo                                
-      enddo
-   
-      return
-      end
-
-
-
-
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.f90	(revision 5105)
@@ -0,0 +1,128 @@
+
+! $Id$
+
+ SUBROUTINE interpre(q,qppm,w,fluxwppm,masse, &
+         apppm,bpppm,massebx,masseby,pbaru,pbarv, &
+         unatppm,vnatppm,psppm)
+
+  USE comconst_mod, ONLY: g
+  USE comvert_mod, ONLY: ap, bp
+
+   implicit none
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissip.h"
+  include "comgeom2.h"
+  include "description.h"
+
+  !---------------------------------------------------
+  ! Arguments
+  real :: apppm(llm+1),bpppm(llm+1)
+  real :: q(iip1,jjp1,llm),qppm(iim,jjp1,llm)
+  !---------------------------------------------------
+  real :: masse(iip1,jjp1,llm)
+  real :: massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+  real :: w(iip1,jjp1,llm)
+  real :: fluxwppm(iim,jjp1,llm)
+  real :: pbaru(iip1,jjp1,llm )
+  real :: pbarv(iip1,jjm,llm)
+  real :: unatppm(iim,jjp1,llm)
+  real :: vnatppm(iim,jjp1,llm)
+  real :: psppm(iim,jjp1)
+  !---------------------------------------------------
+  ! Local
+  real :: vnat(iip1,jjp1,llm)
+  real :: unat(iip1,jjp1,llm)
+  real :: fluxw(iip1,jjp1,llm)
+  real :: smass(iip1,jjp1)
+  !----------------------------------------------------
+  integer :: l,ij,i,j
+
+    ! CALCUL DE LA PRESSION DE SURFACE
+    ! Les coefficients ap et bp sont passés en common
+    ! Calcul de la pression au sol en mb optimisée pour
+    ! la vectorialisation
+
+     do j=1,jjp1
+         do i=1,iip1
+            smass(i,j)=0.
+         enddo
+     enddo
+
+     do l=1,llm
+         do j=1,jjp1
+             do i=1,iip1
+                smass(i,j)=smass(i,j)+masse(i,j,l)
+             enddo
+         enddo
+     enddo
+
+     do j=1,jjp1
+         do i=1,iim
+             psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01
+         END DO
+     END DO
+
+  ! RECONSTRUCTION DES CHAMPS CONTRAVARIANTS
+  ! Le programme ppm3d travaille avec les composantes
+  ! de vitesse et pas les flux, on doit donc passer de l'un à l'autre
+  ! Dans le même temps, on fait le changement d'orientation du vent en v
+  do l=1,llm
+      do j=1,jjm
+          do i=1,iip1
+              vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)
+          enddo
+      enddo
+      do  i=1,iim
+      vnat(i,jjp1,l)=0.
+      enddo
+      do j=1,jjp1
+          do i=1,iip1
+              unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)
+          enddo
+      enddo
+  enddo
+
+  ! CALCUL DU FLUX MASSIQUE VERTICAL
+  ! Flux en l=1 (sol) nul
+  fluxw=0.
+  do l=1,llm
+       do j=1,jjp1
+          do i=1,iip1
+           fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j)
+            ! PRINT*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l),
+  ! c                      'w(i,j,l)=',w(i,j,l)
+          enddo
+       enddo
+  enddo
+
+  ! INVERSION DES NIVEAUX
+  ! le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+  ! de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+  ! On passe donc des niveaux du LMDZ à ceux de Lin
+
+  do l=1,llm+1
+      apppm(l)=ap(llm+2-l)
+      bpppm(l)=bp(llm+2-l)
+  enddo
+
+  do l=1,llm
+      do j=1,jjp1
+         do i=1,iim
+             unatppm(i,j,l)=unat(i,j,llm-l+1)
+             vnatppm(i,j,l)=vnat(i,j,llm-l+1)
+             fluxwppm(i,j,l)=fluxw(i,j,llm-l+1)
+             qppm(i,j,l)=q(i,j,llm-l+1)
+         enddo
+      enddo
+  enddo
+
+  return
+end subroutine interpre
+
+
+
+
+
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.F	(revision 5104)
+++ 	(revision )
@@ -1,106 +1,0 @@
-        function iso_verif_noNaN_nostop(x,err_msg)
-        implicit none
-        ! si x est NaN, on affiche message
-        ! d'erreur et return 1 si erreur
-
-        ! input:
-        real x
-        character*(*) err_msg ! message d''erreur à afficher
-
-        ! output 
-        real borne
-        parameter (borne=1e19)
-        integer iso_verif_noNaN_nostop
-
-        if ((x>-borne).and.(x<borne)) then
-                iso_verif_noNAN_nostop=0
-        else
-            write(*,*) 'erreur detectee par iso_verif_nonNaN:'
-            write(*,*) err_msg
-            write(*,*) 'x=',x
-            iso_verif_noNaN_nostop=1
-        endif      
-
-        return
-        end
-
-        function iso_verif_egalite_nostop
-     :           (a,b,err_msg)
-        implicit none
-        ! compare a et b. Si pas egal, on affiche message
-        ! d'erreur et stoppe
-        ! pour egalite, on verifie erreur absolue et arreur relative
-
-        ! input:
-        real a, b
-        character*(*) err_msg ! message d''erreur à afficher
-
-        ! locals
-        real errmax ! erreur maximale en absolu.
-        real errmaxrel ! erreur maximale en relatif autorisée
-        parameter (errmax=1e-8)
-        parameter (errmaxrel=1e-3)
-
-        ! output
-        integer iso_verif_egalite_nostop
-
-        iso_verif_egalite_nostop=0
-
-        if (abs(a-b)>errmax) then
-          if (abs((a-b)/max(max(abs(b),abs(a)),1e-18))
-     :            >errmaxrel) then
-            write(*,*) 'erreur detectee par iso_verif_egalite:'
-            write(*,*) err_msg
-            write(*,*) 'a=',a
-            write(*,*) 'b=',b
-            iso_verif_egalite_nostop=1
-          endif
-        endif     
-        
-        return
-        end        
-
-
-        function iso_verif_aberrant_nostop
-     :           (x,iso,q,err_msg)
-        USE infotrac, ONLY: isoName, getKey
-        implicit none
-        
-        ! input:
-        real x,q
-        integer iso ! 2=HDO, 1=O18
-        character*(*) err_msg ! message d''erreur à afficher
-
-        ! locals
-        real qmin,deltaD
-        real deltaDmax,deltaDmin,tnat
-        parameter (qmin=1e-11)
-        parameter (deltaDmax=200.0,deltaDmin=-999.9)
-
-        ! output
-        integer iso_verif_aberrant_nostop
-
-        iso_verif_aberrant_nostop=0
-
-        ! verifier que HDO est raisonable
-         if (q>qmin) then
-             IF(getKey('tnat', tnat, isoName(iso))) THEN
-                  err_msg = 'Missing isotopic parameter "tnat"'
-                  iso_verif_aberrant_nostop=1
-                  RETURN
-             END IF
-             deltaD=(x/q/tnat-1)*1000
-             if ((deltaD>deltaDmax).or.(deltaD<deltaDmin)) then
-                  write(*,*) 'erreur detectee par iso_verif_aberrant:'
-                  write(*,*) err_msg
-                  write(*,*) 'q=',q
-                  write(*,*) 'deltaD=',deltaD
-                  write(*,*) 'iso=',iso
-                  iso_verif_aberrant_nostop=1
-             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
-          endif !if (q(i,k,iq).gt.qmin) then
-
-       
-        return
-        end        
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.f90	(revision 5105)
@@ -0,0 +1,106 @@
+  function iso_verif_noNaN_nostop(x,err_msg)
+    implicit none
+    ! ! si x est NaN, on affiche message
+    ! ! d'erreur et return 1 si erreur
+
+    ! ! input:
+    real :: x
+    character(len=*) :: err_msg ! message d''erreur à afficher
+
+    ! ! output
+    real :: borne
+    parameter (borne=1e19)
+    integer :: iso_verif_noNaN_nostop
+
+    if ((x>-borne).and.(x<borne)) then
+            iso_verif_noNAN_nostop=0
+    else
+        write(*,*) 'erreur detectee par iso_verif_nonNaN:'
+        write(*,*) err_msg
+        write(*,*) 'x=',x
+        iso_verif_noNaN_nostop=1
+    endif
+
+    return
+end function iso_verif_nonan_nostop
+
+  function iso_verif_egalite_nostop &
+          (a,b,err_msg)
+    implicit none
+    ! ! compare a et b. Si pas egal, on affiche message
+    ! ! d'erreur et stoppe
+    ! ! pour egalite, on verifie erreur absolue et arreur relative
+
+    ! ! input:
+    real :: a, b
+    character(len=*) :: err_msg ! message d''erreur à afficher
+
+    ! ! locals
+    real :: errmax ! erreur maximale en absolu.
+    real :: errmaxrel ! erreur maximale en relatif autorisée
+    parameter (errmax=1e-8)
+    parameter (errmaxrel=1e-3)
+
+    ! ! output
+    integer :: iso_verif_egalite_nostop
+
+    iso_verif_egalite_nostop=0
+
+    if (abs(a-b)>errmax) then
+      if (abs((a-b)/max(max(abs(b),abs(a)),1e-18)) &
+            >errmaxrel) then
+        write(*,*) 'erreur detectee par iso_verif_egalite:'
+        write(*,*) err_msg
+        write(*,*) 'a=',a
+        write(*,*) 'b=',b
+        iso_verif_egalite_nostop=1
+      endif
+    endif
+
+    return
+end function iso_verif_egalite_nostop
+
+
+  function iso_verif_aberrant_nostop &
+          (x,iso,q,err_msg)
+    USE infotrac, ONLY: isoName, getKey
+    implicit none
+
+    ! ! input:
+    real :: x,q
+    integer :: iso ! 2=HDO, 1=O18
+    character(len=*) :: err_msg ! message d''erreur à afficher
+
+    ! ! locals
+    real :: qmin,deltaD
+    real :: deltaDmax,deltaDmin,tnat
+    parameter (qmin=1e-11)
+    parameter (deltaDmax=200.0,deltaDmin=-999.9)
+
+    ! ! output
+    integer :: iso_verif_aberrant_nostop
+
+    iso_verif_aberrant_nostop=0
+
+    ! ! verifier que HDO est raisonable
+     if (q>qmin) then
+         IF(getKey('tnat', tnat, isoName(iso))) THEN
+              err_msg = 'Missing isotopic parameter "tnat"'
+              iso_verif_aberrant_nostop=1
+              RETURN
+         END IF
+         deltaD=(x/q/tnat-1)*1000
+         if ((deltaD>deltaDmax).or.(deltaD<deltaDmin)) then
+              write(*,*) 'erreur detectee par iso_verif_aberrant:'
+              write(*,*) err_msg
+              write(*,*) 'q=',q
+              write(*,*) 'deltaD=',deltaD
+              write(*,*) 'iso=',iso
+              iso_verif_aberrant_nostop=1
+         endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
+      endif !if (q(i,k,iq).gt.qmin) then
+
+
+    return
+end function iso_verif_aberrant_nostop
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.F	(revision 5104)
+++ 	(revision )
@@ -1,40 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE laplacien ( klevel, teta, divgra )
-c
-c     P. Le Van
-c
-c   ************************************************************
-c    ....     calcul de  (div( grad ))   de   teta  .....
-c   ************************************************************
-c     klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    .........      variables  en arguments   ..............
-c
-      INTEGER klevel
-      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
-c
-c    ............     variables  locales      ..............
-c
-      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
-c    .......................................................
-
-
-c
-      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
-
-      CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
-      CALL   grad ( klevel,divgra,   ghx , ghy              )
-      CALL  divergf ( klevel, ghx , ghy  , divgra           )
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.f90	(revision 5105)
@@ -0,0 +1,40 @@
+
+! $Header$
+
+SUBROUTINE laplacien ( klevel, teta, divgra )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !    ....     calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    .........      variables  en arguments   ..............
+  !
+  INTEGER :: klevel
+  REAL :: teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+  !
+  !    ............     variables  locales      ..............
+  !
+  REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+  !    .......................................................
+
+
+  !
+  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+  CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
+  CALL   grad ( klevel,divgra,   ghx , ghy              )
+  CALL  divergf ( klevel, ghx , ghy  , divgra           )
+
+  RETURN
+END SUBROUTINE laplacien
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.F	(revision 5104)
+++ 	(revision )
@@ -1,53 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam ,
-     *                        unsapolnga, unsapolsga, teta, divgra )
-
-c  P. Le Van
-c
-c   ************************************************************
-c
-c      ....   calcul de  (div( grad ))   de   teta  .....
-c   ************************************************************
-c    klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    ............     variables  en arguments    ..........
-c
-      INTEGER klevel
-      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
-      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
-     *     unsapolnga, unsapolsga
-c
-c    ...........    variables  locales    .................
-c
-      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
-c    ......................................................
-
-c
-c
-c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
-c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
-c   ...  unsairegam =  1. /  aire ** (- gamdissip )
-c
-
-      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
-c
-      CALL   grad ( klevel, divgra, ghx, ghy )
-c
-      CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  ,
-     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
-
-c
-
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.f90	(revision 5105)
@@ -0,0 +1,53 @@
+
+! $Header$
+
+SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , &
+        unsapolnga, unsapolsga, teta, divgra )
+
+  !  P. Le Van
+  !
+  !   ************************************************************
+  !
+  !  ....   calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  !    klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    ............     variables  en arguments    ..........
+  !
+  INTEGER :: klevel
+  REAL :: teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+  REAL :: cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), &
+        unsapolnga, unsapolsga
+  !
+  !    ...........    variables  locales    .................
+  !
+  REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+  !    ......................................................
+
+  !
+  !
+  !   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+  !   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+  !   ...  unsairegam =  1. /  aire ** (- gamdissip )
+  !
+
+  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+  !
+  CALL   grad ( klevel, divgra, ghx, ghy )
+  !
+  CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  , &
+        unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+  !
+
+
+  RETURN
+END SUBROUTINE laplacien_gam
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.F	(revision 5104)
+++ 	(revision )
@@ -1,39 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
-c
-c    P. Le Van
-c
-c   ************************************************************
-c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
-c   ************************************************************
-c
-c     klevel et rotin  sont des arguments  d'entree pour le s-prog
-c      rotout           est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c 
-c   ..........    variables  en  arguments     .............
-c
-      INTEGER klevel
-      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
-c
-c   ..........    variables   locales       ................
-c
-      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
-c   ........................................................
-c
-c
-      CALL  filtreg ( rotin ,   jjm, klevel,   2, 1, .FALSE., 1 )
-
-      CALL   nxgrad ( klevel, rotin,   ghx ,  ghy               )
-      CALL   rotatf  ( klevel, ghx  ,   ghy , rotout             )
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.f90	(revision 5105)
@@ -0,0 +1,39 @@
+
+! $Header$
+
+SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
+  !
+  !    P. Le Van
+  !
+  !   ************************************************************
+  !    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+  !   ************************************************************
+  !
+  ! klevel et rotin  sont des arguments  d'entree pour le s-prog
+  !  rotout           est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !   ..........    variables  en  arguments     .............
+  !
+  INTEGER :: klevel
+  REAL :: rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+  !
+  !   ..........    variables   locales       ................
+  !
+  REAL :: ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+  !   ........................................................
+  !
+  !
+  CALL  filtreg ( rotin ,   jjm, klevel,   2, 1, .FALSE., 1 )
+
+  CALL   nxgrad ( klevel, rotin,   ghx ,  ghy               )
+  CALL   rotatf  ( klevel, ghx  ,   ghy , rotout             )
+  !
+  RETURN
+END SUBROUTINE laplacien_rot
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.F	(revision 5104)
+++ 	(revision )
@@ -1,44 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
-c
-c     P. Le Van
-c
-c   ************************************************************
-c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
-c   ************************************************************
-c     klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    .............   variables  en  arguments    ...........
-c
-      INTEGER klevel
-      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
-c
-c   ............     variables   locales     ...............
-c
-      INTEGER l, ij
-      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
-c   ........................................................
-c
-c
-
-      CALL   nxgrad_gam ( klevel, rotin,   ghx ,   ghy  )
-      CALL   rotat_nfil ( klevel, ghx  ,   ghy , rotout )
-c
-      DO l = 1, klevel
-        DO ij = 1, ip1jm
-         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
-        ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.f90	(revision 5105)
@@ -0,0 +1,44 @@
+
+! $Header$
+
+SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    .............   variables  en  arguments    ...........
+  !
+  INTEGER :: klevel
+  REAL :: rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+  !
+  !   ............     variables   locales     ...............
+  !
+  INTEGER :: l, ij
+  REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+  !   ........................................................
+  !
+  !
+
+  CALL   nxgrad_gam ( klevel, rotin,   ghx ,   ghy  )
+  CALL   rotat_nfil ( klevel, ghx  ,   ghy , rotout )
+  !
+  DO l = 1, klevel
+    DO ij = 1, ip1jm
+     rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+    ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE laplacien_rotgam
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/limx.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.F	(revision 5104)
+++ 	(revision )
@@ -1,106 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE limx(s0,sx,sm,pente_max)
-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 "comgeom.h"
-c
-c
-c   Arguments:
-c   ----------
-      real pente_max
-      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
-      real sx(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 q(ip1jmp1,llm)
-      real dxq(ip1jmp1,llm)
-
-
-      REAL new_m,zm
-      real dxqu(ip1jmp1)
-      real adxqu(ip1jmp1),dxqmax(ip1jmp1)
-
-      Logical extremum,first
-      save first
-
-      REAL      SSUM
-      integer ismax,ismin
-      EXTERNAL  SSUM, ismin,ismax
-
-      data first/.TRUE./
-
-
-       DO  l = 1,llm
-         DO  ij=1,ip1jmp1
-               q(ij,l) = s0(ij,l) / sm ( ij,l )
-               dxq(ij,l) = sx(ij,l) /sm(ij,l)
-         ENDDO
-       ENDDO
-
-c   calcul de la pente a droite et a gauche de la maille
-
-      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,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)=pente_max*min(adxqu(ij-1),adxqu(ij))
-         enddo
-
-         do ij=iip1+iip1,ip1jm,iip1
-            dxqmax(ij-iim)=dxqmax(ij)
-         enddo
-
-c   calcul de la pente avec limitation
-
-         do ij=iip2+1,ip1jm
-            if(     dxqu(ij-1)*dxqu(ij)>0.
-     &         .and. dxq(ij,l)*dxqu(ij)>0.) then
-              dxq(ij,l)=
-     &         sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
-            else
-c   extremum local
-               dxq(ij,l)=0.
-            endif
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            dxq(ij-iim,l)=dxq(ij,l)
-         enddo
-
-         DO  ij=1,ip1jmp1
-               sx(ij,l) = dxq(ij,l)*sm(ij,l)
-         ENDDO
-
-       ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90	(revision 5105)
@@ -0,0 +1,106 @@
+
+! $Header$
+
+SUBROUTINE limx(s0,sx,sm,pente_max)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: pente_max
+  REAL :: s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+  real :: sx(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+  integer :: n0,iadvplus(ip1jmp1,llm),nl(llm)
+  !
+  REAL :: q(ip1jmp1,llm)
+  real :: dxq(ip1jmp1,llm)
+
+
+  REAL :: new_m,zm
+  real :: dxqu(ip1jmp1)
+  real :: adxqu(ip1jmp1),dxqmax(ip1jmp1)
+
+  Logical :: extremum,first
+  save first
+
+  REAL :: SSUM
+  integer :: ismax,ismin
+  EXTERNAL  SSUM, ismin,ismax
+
+  data first/.TRUE./
+
+
+   DO  l = 1,llm
+     DO  ij=1,ip1jmp1
+           q(ij,l) = s0(ij,l) / sm ( ij,l )
+           dxq(ij,l) = sx(ij,l) /sm(ij,l)
+     ENDDO
+   ENDDO
+
+  !   calcul de la pente a droite et a gauche de la maille
+
+  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,ip1jm
+        adxqu(ij)=abs(dxqu(ij))
+     enddo
+
+  !   calcul de la pente maximum dans la maille en valeur absolue
+
+     do ij=iip2+1,ip1jm
+        dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
+     enddo
+
+     do ij=iip1+iip1,ip1jm,iip1
+        dxqmax(ij-iim)=dxqmax(ij)
+     enddo
+
+  !   calcul de la pente avec limitation
+
+     do ij=iip2+1,ip1jm
+        if(     dxqu(ij-1)*dxqu(ij)>0. &
+              .and. dxq(ij,l)*dxqu(ij)>0.) then
+          dxq(ij,l)= &
+                sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
+        else
+  !   extremum local
+           dxq(ij,l)=0.
+        endif
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        dxq(ij-iim,l)=dxq(ij,l)
+     enddo
+
+     DO  ij=1,ip1jmp1
+           sx(ij,l) = dxq(ij,l)*sm(ij,l)
+     ENDDO
+
+   ENDDO
+
+  RETURN
+END SUBROUTINE limx
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/limy.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limy.F	(revision 5104)
+++ 	(revision )
@@ -1,192 +1,0 @@
-c
-c $Id$
-c
-      SUBROUTINE limy(s0,sy,sm,pente_max)
-c
-c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
-c
-c    ********************************************************************
-c     Shema  d'advection " pseudo amont " .
-c    ********************************************************************
-c     q,w sont des arguments d'entree  pour le s-pg ....
-c     dq 	       sont des arguments de sortie pour le s-pg ....
-c
-c
-c   --------------------------------------------------------------------
-      USE comconst_mod, ONLY: pi
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c
-c   Arguments:
-c   ----------
-      real pente_max
-      real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm)
-c
-c      Local 
-c   ---------
-c
-      INTEGER i,ij,l
-c
-      REAL q(ip1jmp1,llm)
-      REAL airej2,airejjm,airescb(iim),airesch(iim)
-      real sigv,dyq(ip1jmp1),dyqv(ip1jm)
-      real adyqv(ip1jm),dyqmax(ip1jmp1)
-      REAL qbyv(ip1jm,llm)
-
-      REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2
-      Logical extremum,first
-      save first
-
-      real convpn,convps,convmpn,convmps
-      real sinlon(iip1),sinlondlon(iip1)
-      real coslon(iip1),coslondlon(iip1)
-      save sinlon,coslon,sinlondlon,coslondlon
-c
-c
-      REAL      SSUM
-      integer ismax,ismin
-      EXTERNAL  SSUM, convflu,ismin,ismax
-      EXTERNAL filtreg
-
-      data first/.TRUE./
-
-      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)
-      endif
-
-c
-
-      do l = 1, llm
-c
-         DO ij=1,ip1jmp1
-               q(ij,l) = s0(ij,l) / sm ( ij,l )
-               dyq(ij) = sy(ij,l) / sm ( ij,l )
-         ENDDO
-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.
-
-      airej2 = SSUM( iim, aire(iip2), 1 )
-      airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
-      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
-         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
-         dyqmax(ij)=pente_max*dyqmax(ij)
-      enddo
-
-c   calcul des pentes aux poles
-
-c   calcul des pentes limites aux poles
-
-c     PRINT*,dyqv(iip1+1)
-c     appn=abs(dyq(1)/dyqv(iip1+1))
-c     PRINT*,dyq(ip1jm+1)
-c     PRINT*,dyqv(ip1jm-iip1+1)
-c     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
-c     do ij=2,iim
-c        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
-c        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
-c     enddo
-c     appn=min(pente_max/appn,1.)
-c     apps=min(pente_max/apps,1.)
-
-
-c   cas ou on a un extremum au pole
-
-c     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
-c    &   appn=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    &   apps=0.
-
-c   limitation des pentes aux poles
-c     do ij=1,iip1
-c        dyq(ij)=appn*dyq(ij)
-c        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
-c     enddo
-
-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
-
-      if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1))<=0.)
-     &   then
-         do ij=1,iip1
-            dyqmax(ij)=0.
-         enddo
-      else
-         do ij=1,iip1
-            dyqmax(ij)=pente_max*abs(dyqv(ij))
-         enddo
-      endif
-
-      if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
-     & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)<=0.)
-     &then
-         do ij=ip1jm+1,ip1jmp1
-            dyqmax(ij)=0.
-         enddo
-      else
-         do ij=ip1jm+1,ip1jmp1
-            dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
-         enddo
-      endif
-
-c   calcul des pentes limitees
-
-      do ij=1,ip1jmp1 ! cf below: should it be ip1jm instead ?
-         if(dyqv(ij)*dyqv(ij-iip1)>0.) then  ! /!\ causes Warning: iteration 1056 invokes undefined behavior [-Waggressive-loop-optimizations] in 32x32x39
-            dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))
-         else
-            dyq(ij)=0.
-         endif
-      enddo
-
-         DO ij=1,ip1jmp1
-               sy(ij,l) = dyq(ij) * sm ( ij,l )
-        ENDDO
-
-      enddo ! fin de la boucle sur les couches verticales
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limy.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limy.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limy.f90	(revision 5105)
@@ -0,0 +1,192 @@
+!
+! $Id$
+!
+SUBROUTINE limy(s0,sy,sm,pente_max)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! q,w sont des arguments d'entree  pour le s-pg ....
+  ! dq 	       sont des arguments de sortie pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: pente_max
+  real :: s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i,ij,l
+  !
+  REAL :: q(ip1jmp1,llm)
+  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
+  real :: sigv,dyq(ip1jmp1),dyqv(ip1jm)
+  real :: adyqv(ip1jm),dyqmax(ip1jmp1)
+  REAL :: qbyv(ip1jm,llm)
+
+  REAL :: qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2
+  Logical :: extremum,first
+  save first
+
+  real :: convpn,convps,convmpn,convmps
+  real :: sinlon(iip1),sinlondlon(iip1)
+  real :: coslon(iip1),coslondlon(iip1)
+  save sinlon,coslon,sinlondlon,coslondlon
+  !
+  !
+  REAL :: SSUM
+  integer :: ismax,ismin
+  EXTERNAL  SSUM, convflu,ismin,ismax
+  EXTERNAL filtreg
+
+  data first/.TRUE./
+
+  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)
+  endif
+
+  !
+
+  do l = 1, llm
+  !
+     DO ij=1,ip1jmp1
+           q(ij,l) = s0(ij,l) / sm ( ij,l )
+           dyq(ij) = sy(ij,l) / sm ( ij,l )
+     ENDDO
+  !
+  !   --------------------------------
+  !  CALCUL EN LATITUDE
+  !   --------------------------------
+
+  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+  airej2 = SSUM( iim, aire(iip2), 1 )
+  airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
+  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
+
+  !   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
+
+  !   calcul des pentes aux points scalaires
+
+  do ij=iip2,ip1jm
+     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+     dyqmax(ij)=pente_max*dyqmax(ij)
+  enddo
+
+  !   calcul des pentes aux poles
+
+  !   calcul des pentes limites aux poles
+
+  ! PRINT*,dyqv(iip1+1)
+  ! appn=abs(dyq(1)/dyqv(iip1+1))
+  ! PRINT*,dyq(ip1jm+1)
+  ! PRINT*,dyqv(ip1jm-iip1+1)
+  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+  ! do ij=2,iim
+  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+  ! enddo
+  ! appn=min(pente_max/appn,1.)
+  ! apps=min(pente_max/apps,1.)
+
+
+  !   cas ou on a un extremum au pole
+
+  ! if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   appn=0.
+  ! if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &   apps=0.
+
+  !   limitation des pentes aux poles
+  ! do ij=1,iip1
+  !    dyq(ij)=appn*dyq(ij)
+  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+  ! enddo
+
+  !   test
+  !  do ij=1,iip1
+  !     dyq(iip1+ij)=0.
+  !     dyq(ip1jm+ij-iip1)=0.
+  !  enddo
+  !  do ij=1,ip1jmp1
+  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+  !  enddo
+
+  if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1))<=0.) &
+        then
+     do ij=1,iip1
+        dyqmax(ij)=0.
+     enddo
+  else
+     do ij=1,iip1
+        dyqmax(ij)=pente_max*abs(dyqv(ij))
+     enddo
+  endif
+
+  if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* &
+        dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)<=0.) &
+        then
+     do ij=ip1jm+1,ip1jmp1
+        dyqmax(ij)=0.
+     enddo
+  else
+     do ij=ip1jm+1,ip1jmp1
+        dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+     enddo
+  endif
+
+  !   calcul des pentes limitees
+
+  do ij=1,ip1jmp1 ! cf below: should it be ip1jm instead ?
+     if(dyqv(ij)*dyqv(ij-iip1)>0.) then  ! /!\ causes Warning: iteration 1056 invokes undefined behavior [-Waggressive-loop-optimizations] in 32x32x39
+        dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))
+     else
+        dyq(ij)=0.
+     endif
+  enddo
+
+     DO ij=1,ip1jmp1
+           sy(ij,l) = dyq(ij) * sm ( ij,l )
+    ENDDO
+
+  enddo ! fin de la boucle sur les couches verticales
+
+  RETURN
+END SUBROUTINE limy
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/limz.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limz.F	(revision 5104)
+++ 	(revision )
@@ -1,96 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE limz(s0,sz,sm,pente_max)
-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 "comgeom.h"
-c
-c
-c   Arguments:
-c   ----------
-      real pente_max
-      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
-      real sz(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 q(ip1jmp1,llm)
-      real dzq(ip1jmp1,llm)
-
-
-      REAL new_m,zm
-      real dzqw(ip1jmp1)
-      real adzqw(ip1jmp1),dzqmax(ip1jmp1)
-
-      Logical extremum,first
-      save first
-
-      REAL      SSUM
-      integer ismax,ismin
-      EXTERNAL  SSUM, ismin,ismax
-
-      data first/.TRUE./
-
-
-       DO  l = 1,llm
-         DO  ij=1,ip1jmp1
-               q(ij,l) = s0(ij,l) / sm ( ij,l )
-               dzq(ij,l) = sz(ij,l) /sm(ij,l)
-         ENDDO
-       ENDDO
-
-c   calcul de la pente en haut et en bas de la maille
-       do ij=1,ip1jmp1
-       do l = 1, llm-1
-            dzqw(l)=q(ij,l+1)-q(ij,l)
-         enddo
-            dzqw(llm)=0.
-
-         do  l=1,llm
-            adzqw(l)=abs(dzqw(l))
-         enddo
-
-c   calcul de la pente maximum dans la maille en valeur absolue
-
-         do l=2,llm-1
-            dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l))
-         enddo
-
-c   calcul de la pente avec limitation
-
-         do l=2,llm-1
-            if(     dzqw(l-1)*dzqw(l)>0.
-     &         .and. dzq(ij,l)*dzqw(l)>0.) then
-              dzq(ij,l)=
-     &         sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l))
-            else
-c   extremum local
-               dzq(ij,l)=0.
-            endif
-         enddo
-
-         DO  l=1,llm
-               sz(ij,l) = dzq(ij,l)*sm(ij,l)
-         ENDDO
-
-       ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limz.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limz.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limz.f90	(revision 5105)
@@ -0,0 +1,96 @@
+
+! $Header$
+
+SUBROUTINE limz(s0,sz,sm,pente_max)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: pente_max
+  REAL :: s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+  real :: sz(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+  integer :: n0,iadvplus(ip1jmp1,llm),nl(llm)
+  !
+  REAL :: q(ip1jmp1,llm)
+  real :: dzq(ip1jmp1,llm)
+
+
+  REAL :: new_m,zm
+  real :: dzqw(ip1jmp1)
+  real :: adzqw(ip1jmp1),dzqmax(ip1jmp1)
+
+  Logical :: extremum,first
+  save first
+
+  REAL :: SSUM
+  integer :: ismax,ismin
+  EXTERNAL  SSUM, ismin,ismax
+
+  data first/.TRUE./
+
+
+   DO  l = 1,llm
+     DO  ij=1,ip1jmp1
+           q(ij,l) = s0(ij,l) / sm ( ij,l )
+           dzq(ij,l) = sz(ij,l) /sm(ij,l)
+     ENDDO
+   ENDDO
+
+  !   calcul de la pente en haut et en bas de la maille
+   do ij=1,ip1jmp1
+   do l = 1, llm-1
+        dzqw(l)=q(ij,l+1)-q(ij,l)
+     enddo
+        dzqw(llm)=0.
+
+     do  l=1,llm
+        adzqw(l)=abs(dzqw(l))
+     enddo
+
+  !   calcul de la pente maximum dans la maille en valeur absolue
+
+     do l=2,llm-1
+        dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l))
+     enddo
+
+  !   calcul de la pente avec limitation
+
+     do l=2,llm-1
+        if(     dzqw(l-1)*dzqw(l)>0. &
+              .and. dzq(ij,l)*dzqw(l)>0.) then
+          dzq(ij,l)= &
+                sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l))
+        else
+  !   extremum local
+           dzq(ij,l)=0.
+        endif
+     enddo
+
+     DO  l=1,llm
+           sz(ij,l) = dzq(ij,l)*sm(ij,l)
+     ENDDO
+
+   ENDDO
+
+  RETURN
+END SUBROUTINE limz
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.F	(revision 5104)
+++ 	(revision )
@@ -1,108 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE massdair( p, masse )
-c
-c *********************************************************************
-c       ....  Calcule la masse d'air  dans chaque maille   ....
-c *********************************************************************
-c
-c    Auteurs : P. Le Van , Fr. Hourdin  .
-c   ..........
-c
-c  ..    p                      est  un argum. d'entree pour le s-pg ...
-c  ..  masse                    est un  argum.de sortie pour le s-pg ...
-c     
-c  ....  p est defini aux interfaces des llm couches   .....
-c
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c  .....   arguments  ....
-c
-      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
-
-c   ....  Variables locales  .....
-
-      INTEGER l,ij
-      REAL massemoyn, massemoys
-
-      REAL SSUM
-c
-c
-c   Methode pour calculer massebx et masseby .
-c   ----------------------------------------
-c
-c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
-c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
-c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
-c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
-c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
-c
-c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
-c
-c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
-c
-c
-c
-c   alpha4 .         . alpha1    . alpha4
-c    (i,j)             (i,j)       (i+1,j)
-c
-c             P .        U .          . P
-c           (i,j)       (i,j)         (i+1,j)
-c
-c   alpha3 .         . alpha2    .alpha3 
-c    (i,j)              (i,j)     (i+1,j)
-c
-c             V .        Z .          . V
-c           (i,j)
-c
-c   alpha4 .         . alpha1    .alpha4
-c   (i,j+1)            (i,j+1)   (i+1,j+1) 
-c
-c             P .        U .          . P
-c          (i,j+1)                    (i+1,j+1)
-c
-c
-c
-c                       On  a :
-c
-c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
-c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-c     localise  au point  ... U (i,j) ...
-c
-c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
-c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-c     localise  au point  ... V (i,j) ...
-c
-c
-c=======================================================================
-
-      DO   l = 1 , llm
-c
-        DO    ij     = 1, ip1jmp1
-         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
-        ENDDO
-c
-        DO   ij = 1, ip1jmp1,iip1
-         masse(ij+ iim,l) = masse(ij,l)
-        ENDDO
-c
-c       DO    ij     = 1,  iim
-c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
-c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
-c       ENDDO
-c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
-c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
-c       DO    ij     = 1, iip1
-c        masse(   ij   ,l )    = massemoyn
-c        masse(ij+ip1jm,l )    = massemoys
-c       ENDDO
-       
-      END DO
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.f90	(revision 5105)
@@ -0,0 +1,108 @@
+
+! $Header$
+
+SUBROUTINE massdair( p, masse )
+  !
+  ! *********************************************************************
+  !   ....  Calcule la masse d'air  dans chaque maille   ....
+  ! *********************************************************************
+  !
+  !    Auteurs : P. Le Van , Fr. Hourdin  .
+  !   ..........
+  !
+  !  ..    p                      est  un argum. d'entree pour le s-pg ...
+  !  ..  masse                    est un  argum.de sortie pour le s-pg ...
+  !
+  !  ....  p est defini aux interfaces des llm couches   .....
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !  .....   arguments  ....
+  !
+  REAL :: p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
+
+  !   ....  Variables locales  .....
+
+  INTEGER :: l,ij
+  REAL :: massemoyn, massemoys
+
+  REAL :: SSUM
+  !
+  !
+  !   Methode pour calculer massebx et masseby .
+  !   ----------------------------------------
+  !
+  !    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+  !   alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+  !   alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+  !   alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+  !   alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+  !
+  !    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+  !
+  !    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+  !
+  !
+  !
+  !   alpha4 .         . alpha1    . alpha4
+  !    (i,j)             (i,j)       (i+1,j)
+  !
+  !         P .        U .          . P
+  !       (i,j)       (i,j)         (i+1,j)
+  !
+  !   alpha3 .         . alpha2    .alpha3
+  !    (i,j)              (i,j)     (i+1,j)
+  !
+  !         V .        Z .          . V
+  !       (i,j)
+  !
+  !   alpha4 .         . alpha1    .alpha4
+  !   (i,j+1)            (i,j+1)   (i+1,j+1)
+  !
+  !         P .        U .          . P
+  !      (i,j+1)                    (i+1,j+1)
+  !
+  !
+  !
+  !                   On  a :
+  !
+  !    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+  !               masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+  ! localise  au point  ... U (i,j) ...
+  !
+  !    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+  !               masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
+  ! localise  au point  ... V (i,j) ...
+  !
+  !
+  !=======================================================================
+
+  DO   l = 1 , llm
+  !
+    DO    ij     = 1, ip1jmp1
+     masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+    ENDDO
+  !
+    DO   ij = 1, ip1jmp1,iip1
+     masse(ij+ iim,l) = masse(ij,l)
+    ENDDO
+  !
+  !   DO    ij     = 1,  iim
+  !    masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+  !    masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm)
+  !   ENDDO
+  !    massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+  !    massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+  !   DO    ij     = 1, iip1
+  !    masse(   ij   ,l )    = massemoyn
+  !    masse(ij+ip1jm,l )    = massemoys
+  !   ENDDO
+
+  END DO
+  !
+  RETURN
+END SUBROUTINE massdair
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.F	(revision 5104)
+++ 	(revision )
@@ -1,48 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE nxgrad (klevel, rot, x, y )
-c
-c     P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INTEGER klevel
-      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
-      INTEGER   l,ij
-c
-c
-      DO l = 1,klevel
-c
-      DO ij = 2, ip1jm
-      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
-      END DO
-c
-c    ..... correction pour  y ( 1,j,l )  ......
-c
-c    ....    y(1,j,l)= y(iip1,j,l) ....
-CDIR$ IVDEP
-      DO ij = 1, ip1jm, iip1
-      y( ij,l ) = y( ij +iim,l )
-      END DO
-c
-      DO ij = iip2,ip1jm
-      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
-      END DO
-      DO ij = 1,iip1
-      x(    ij    ,l ) = 0.
-      x( ij +ip1jm,l ) = 0.
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.f90	(revision 5105)
@@ -0,0 +1,48 @@
+
+! $Header$
+
+SUBROUTINE nxgrad (klevel, rot, x, y )
+  !
+  ! P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+  INTEGER :: l,ij
+  !
+  !
+  DO l = 1,klevel
+  !
+  DO ij = 2, ip1jm
+  y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO ij = 1, ip1jm, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  DO ij = iip2,ip1jm
+  x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+  END DO
+  DO ij = 1,iip1
+  x(    ij    ,l ) = 0.
+  x( ij +ip1jm,l ) = 0.
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE nxgrad
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.F	(revision 5104)
+++ 	(revision )
@@ -1,47 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE nxgrad_gam( klevel, rot, x, y )
-c
-c  P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INTEGER klevel
-      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
-      INTEGER   l,ij
-c
-      DO l = 1,klevel
-c
-      DO ij = 2, ip1jm
-      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
-      END DO
-c
-c    ..... correction pour  y ( 1,j,l )  ......
-c
-c    ....    y(1,j,l)= y(iip1,j,l) ....
-CDIR$ IVDEP
-      DO ij = 1, ip1jm, iip1
-      y( ij,l ) = y( ij +iim,l )
-      END DO
-c
-      DO ij = iip2,ip1jm
-      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
-      END DO
-      DO ij = 1,iip1
-      x(    ij    ,l ) = 0.
-      x( ij +ip1jm,l ) = 0.
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.f90	(revision 5105)
@@ -0,0 +1,47 @@
+
+! $Header$
+
+SUBROUTINE nxgrad_gam( klevel, rot, x, y )
+  !
+  !  P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+  INTEGER :: l,ij
+  !
+  DO l = 1,klevel
+  !
+  DO ij = 2, ip1jm
+  y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO ij = 1, ip1jm, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  DO ij = iip2,ip1jm
+  x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+  END DO
+  DO ij = 1,iip1
+  x(    ij    ,l ) = 0.
+  x( ij +ip1jm,l ) = 0.
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE nxgrad_gam
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.F	(revision 5104)
+++ 	(revision )
@@ -1,47 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE nxgradst (klevel,rot, x, y )
-c
-      IMPLICIT NONE
-c     Auteur :  P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      INTEGER klevel
-      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
-      INTEGER l,ij
-c
-      DO l = 1,klevel
-c
-      DO ij = 2, ip1jm
-      y(ij,l)=( rot(ij,l) - rot(ij-1,l))
-      END DO
-c
-c    ..... correction pour  y ( 1,j,l )  ......
-c
-c    ....    y(1,j,l)= y(iip1,j,l) ....
-
-      DO ij = 1, ip1jm, iip1
-      y( ij,l ) = y( ij +iim,l )
-      END DO
-c
-      DO ij = iip2,ip1jm
-      x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
-      END DO
-      DO ij = 1,iip1
-      x(    ij    ,l ) = 0.
-      x( ij +ip1jm,l ) = 0.
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.f90	(revision 5105)
@@ -0,0 +1,47 @@
+
+! $Header$
+
+SUBROUTINE nxgradst (klevel,rot, x, y )
+  !
+  IMPLICIT NONE
+  ! Auteur :  P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+  INTEGER :: l,ij
+  !
+  DO l = 1,klevel
+  !
+  DO ij = 2, ip1jm
+  y(ij,l)=( rot(ij,l) - rot(ij-1,l))
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+
+  DO ij = 1, ip1jm, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  DO ij = iip2,ip1jm
+  x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
+  END DO
+  DO ij = 1,iip1
+  x(    ij    ,l ) = 0.
+  x( ij +ip1jm,l ) = 0.
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE nxgradst
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.F	(revision 5104)
+++ 	(revision )
@@ -1,68 +1,0 @@
-
-! $Header$
-
-       SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
-c
-c      P.Le Van .
-c   ***********************************************************
-c                                 lr
-c      calcul de  ( nxgrad (rot) )   du vect. v  ....
-c
-c       xcov et ycov  etant les compos. covariantes de  v
-c   ***********************************************************
-c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
-c      grx   et  gry     sont des arguments de sortie pour le s-prog
-c
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comdissipn.h"
-c
-c    ......  variables en arguments  .......
-c
-      INTEGER klevel
-      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
-      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
-c
-c    ......   variables locales     ........
-c
-      REAL rot(ip1jm,llm) , signe, nugradrs
-      INTEGER l,ij,iter,lr
-c    ........................................................
-c
-c
-c
-      signe    = (-1.)**lr
-      nugradrs = signe * crot
-c
-      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
-      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
-c
-      CALL     rotatf     ( klevel, grx, gry, rot )
-c
-      CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
-
-c
-c    .....   Iteration de l'operateur laplacien_rotgam  .....
-c
-      DO  iter = 1, lr -2
-        CALL laplacien_rotgam ( klevel, rot, rot )
-      ENDDO
-c
-c
-      CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
-      CALL nxgrad ( klevel, rot, grx, gry )
-c
-      DO    l = 1, klevel
-         DO  ij = 1, ip1jm
-          gry( ij,l ) = gry( ij,l ) * nugradrs
-         ENDDO
-         DO  ij = 1, ip1jmp1
-          grx( ij,l ) = grx( ij,l ) * nugradrs
-         ENDDO
-      ENDDO
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.f90	(revision 5105)
@@ -0,0 +1,68 @@
+
+! $Header$
+
+ SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
+  !
+  !  P.Le Van .
+  !   ***********************************************************
+  !                             lr
+  !  calcul de  ( nxgrad (rot) )   du vect. v  ....
+  !
+  !   xcov et ycov  etant les compos. covariantes de  v
+  !   ***********************************************************
+  ! xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+  !  grx   et  gry     sont des arguments de sortie pour le s-prog
+  !
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comdissipn.h"
+  !
+  !    ......  variables en arguments  .......
+  !
+  INTEGER :: klevel
+  REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+  REAL :: grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+  !
+  !    ......   variables locales     ........
+  !
+  REAL :: rot(ip1jm,llm) , signe, nugradrs
+  INTEGER :: l,ij,iter,lr
+  !    ........................................................
+  !
+  !
+  !
+  signe    = (-1.)**lr
+  nugradrs = signe * crot
+  !
+  CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+  CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+  !
+  CALL     rotatf     ( klevel, grx, gry, rot )
+  !
+  CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
+
+  !
+  !    .....   Iteration de l'operateur laplacien_rotgam  .....
+  !
+  DO  iter = 1, lr -2
+    CALL laplacien_rotgam ( klevel, rot, rot )
+  ENDDO
+  !
+  !
+  CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
+  CALL nxgrad ( klevel, rot, grx, gry )
+  !
+  DO    l = 1, klevel
+     DO  ij = 1, ip1jm
+      gry( ij,l ) = gry( ij,l ) * nugradrs
+     ENDDO
+     DO  ij = 1, ip1jmp1
+      grx( ij,l ) = grx( ij,l ) * nugradrs
+     ENDDO
+  ENDDO
+  !
+  RETURN
+END SUBROUTINE nxgraro2
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.F	(revision 5104)
+++ 	(revision )
@@ -1,54 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
-c   ***********************************************************
-c
-c    Auteur :  P.Le Van  
-c
-c                                 lr
-c      calcul de  ( nXgrad (rot) )   du vect. v  ....
-c
-c       xcov et ycov  etant les compos. covariantes de  v
-c   ***********************************************************
-c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
-c      grx   et  gry     sont des arguments de sortie pour le s-prog
-c
-c
-      IMPLICIT NONE
-c
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comdissipn.h"
-c
-      INTEGER klevel
-      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
-      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
-c
-      REAL rot(ip1jm,llm)
-
-      INTEGER l,ij,iter,lr
-c
-c
-c
-      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
-      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
-c
-      DO iter = 1,lr
-      CALL  rotat (klevel,grx, gry, rot )
-      CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,2)
-      CALL nxgrad (klevel,rot, grx, gry )
-c
-      DO l = 1, klevel
-      DO ij = 1, ip1jm
-      gry( ij,l ) = - gry( ij,l ) * crot
-      END DO
-      DO ij = 1, ip1jmp1
-      grx( ij,l ) = - grx( ij,l ) * crot
-      END DO
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.f90	(revision 5105)
@@ -0,0 +1,54 @@
+
+! $Header$
+
+SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
+  !   ***********************************************************
+  !
+  !    Auteur :  P.Le Van
+  !
+  !                             lr
+  !  calcul de  ( nXgrad (rot) )   du vect. v  ....
+  !
+  !   xcov et ycov  etant les compos. covariantes de  v
+  !   ***********************************************************
+  ! xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+  !  grx   et  gry     sont des arguments de sortie pour le s-prog
+  !
+  !
+  IMPLICIT NONE
+  !
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissipn.h"
+  !
+  INTEGER :: klevel
+  REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+  REAL :: grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+  !
+  REAL :: rot(ip1jm,llm)
+
+  INTEGER :: l,ij,iter,lr
+  !
+  !
+  !
+  CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+  CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+  !
+  DO iter = 1,lr
+  CALL  rotat (klevel,grx, gry, rot )
+  CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,2)
+  CALL nxgrad (klevel,rot, grx, gry )
+  !
+  DO l = 1, klevel
+  DO ij = 1, ip1jm
+  gry( ij,l ) = - gry( ij,l ) * crot
+  END DO
+  DO ij = 1, ip1jmp1
+  grx( ij,l ) = - grx( ij,l ) * crot
+  END DO
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE nxgrarot
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.F	(revision 5104)
+++ 	(revision )
@@ -1,124 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c **********************************************************************
-c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
-c *********************************************************************
-c
-c          pext               est  un argum. d'entree  pour le s-pg ..
-c     pbarx,pbary et pbarxy  sont des argum. de sortie pour le s-pg ..
-c
-c   Methode:
-c   --------
-c
-c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
-c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
-c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
-c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
-c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
-c
-c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
-c
-c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
-c
-c
-c
-c   alpha4 .         . alpha1    . alpha4
-c    (i,j)             (i,j)       (i+1,j)
-c
-c             P .        U .          . P
-c           (i,j)       (i,j)         (i+1,j)
-c
-c   alpha3 .         . alpha2    .alpha3 
-c    (i,j)              (i,j)     (i+1,j)
-c
-c             V .        Z .          . V
-c           (i,j)
-c
-c   alpha4 .         . alpha1    .alpha4
-c   (i,j+1)            (i,j+1)   (i+1,j+1) 
-c
-c             P .        U .          . P
-c          (i,j+1)                    (i+1,j+1)
-c
-c
-c
-c
-c                       On  a :
-c
-c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
-c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-c     localise  au point  ... U (i,j) ...
-c
-c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
-c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-c     localise  au point  ... V (i,j) ...
-c
-c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
-c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
-c     localise  au point  ... Z (i,j) ...
-c
-c
-c
-c=======================================================================
-
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-
-      INCLUDE "comgeom.h"
-
-      REAL pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
-      REAL pbary(  ip1jm  ),  pbarxy(  ip1jm  )
-
-      INTEGER   ij
-
-
-
-      DO ij = 1, ip1jmp1 - 1
-      pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
-      END DO
-
-c    .... correction pour pbarx( iip1,j) .....
-
-c    ...    pbarx(iip1,j)= pbarx(1,j) ...
-CDIR$ IVDEP
-      DO ij = iip1, ip1jmp1, iip1
-      pbarx( ij ) = pbarx( ij - iim )
-      END DO
-
-
-      DO ij = 1,ip1jm
-      pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     +
-     *              pext( ij+iip1 ) * alpha1p4( ij+iip1 )
-      END DO
-
-
-      DO ij = 1, ip1jm - 1
-      pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
-     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
-      END DO
-
-
-c    ....  correction pour     pbarxy( iip1,j )  ........
-
-CDIR$ IVDEP
-
-      DO ij = iip1, ip1jm, iip1
-      pbarxy( ij ) = pbarxy( ij - iim )
-      END DO
-
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.f90	(revision 5105)
@@ -0,0 +1,124 @@
+
+! $Header$
+
+SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  ! **********************************************************************
+  ! calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+  ! *********************************************************************
+  !
+  !      pext               est  un argum. d'entree  pour le s-pg ..
+  ! pbarx,pbary et pbarxy  sont des argum. de sortie pour le s-pg ..
+  !
+  !   Methode:
+  !   --------
+  !
+  !    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+  !   alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+  !   alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+  !   alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+  !   alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+  !
+  !    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+  !
+  !    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+  !
+  !
+  !
+  !   alpha4 .         . alpha1    . alpha4
+  !    (i,j)             (i,j)       (i+1,j)
+  !
+  !         P .        U .          . P
+  !       (i,j)       (i,j)         (i+1,j)
+  !
+  !   alpha3 .         . alpha2    .alpha3
+  !    (i,j)              (i,j)     (i+1,j)
+  !
+  !         V .        Z .          . V
+  !       (i,j)
+  !
+  !   alpha4 .         . alpha1    .alpha4
+  !   (i,j+1)            (i,j+1)   (i+1,j+1)
+  !
+  !         P .        U .          . P
+  !      (i,j+1)                    (i+1,j+1)
+  !
+  !
+  !
+  !
+  !                   On  a :
+  !
+  !    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+  !             Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+  ! localise  au point  ... U (i,j) ...
+  !
+  !    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+  !             Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
+  ! localise  au point  ... V (i,j) ...
+  !
+  !  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+  !           Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+  ! localise  au point  ... Z (i,j) ...
+  !
+  !
+  !
+  !=======================================================================
+
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+
+  INCLUDE "comgeom.h"
+
+  REAL :: pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
+  REAL :: pbary(  ip1jm  ),  pbarxy(  ip1jm  )
+
+  INTEGER :: ij
+
+
+
+  DO ij = 1, ip1jmp1 - 1
+  pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
+  END DO
+
+  !    .... correction pour pbarx( iip1,j) .....
+
+  !    ...    pbarx(iip1,j)= pbarx(1,j) ...
+  !DIR$ IVDEP
+  DO ij = iip1, ip1jmp1, iip1
+  pbarx( ij ) = pbarx( ij - iim )
+  END DO
+
+
+  DO ij = 1,ip1jm
+  pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     + &
+        pext( ij+iip1 ) * alpha1p4( ij+iip1 )
+  END DO
+
+
+  DO ij = 1, ip1jm - 1
+  pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + &
+        pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+  END DO
+
+
+  !    ....  correction pour     pbarxy( iip1,j )  ........
+
+  !DIR$ IVDEP
+
+  DO ij = iip1, ip1jm, iip1
+  pbarxy( ij ) = pbarxy( ij - iim )
+  END DO
+
+
+  RETURN
+END SUBROUTINE pbar
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.F	(revision 5104)
+++ 	(revision )
@@ -1,479 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
-      
-      USE comconst_mod, ONLY: pi, dtvr
-      
-      IMPLICIT NONE
-
-c=======================================================================
-c   Adaptation LMDZ:  A.Armengaud (LGGE)
-c   ----------------
-c
-c   ********************************************************************
-c   Transport des traceurs par la methode des pentes
-c   ********************************************************************
-c   Reference possible : Russel. G.L., Lerner J.A.:
-c         A new Finite-Differencing Scheme for Traceur Transport 
-c         Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 
-c   ********************************************************************
-c   q,w,masse,pbaru et pbarv 
-c                      sont des arguments d'entree  pour le s-pg ....
-c
-c=======================================================================
-
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-c   Arguments:
-c   ----------
-      integer mode
-      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
-      REAL q( iip1,jjp1,llm,0:3)
-      REAL w( ip1jmp1,llm )
-      REAL masse( iip1,jjp1,llm)
-c   Local:
-c   ------
-      LOGICAL limit
-      REAL sm ( iip1,jjp1, llm )
-      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
-      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
-      real masn,mass,zz
-      INTEGER i,j,l,iq
-
-c  modif Fred 24 03 96
-
-      real sinlon(iip1),sinlondlon(iip1)
-      real coslon(iip1),coslondlon(iip1)
-      save sinlon,coslon,sinlondlon,coslondlon
-      real dyn1,dyn2,dys1,dys2
-      real qpn,qps,dqzpn,dqzps
-      real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1)
-      real qmin,zq,pente_max
-c
-      REAL      SSUM
-      integer ismax,ismin,lati,latf
-      EXTERNAL  SSUM, ismin,ismax
-      logical first
-      save first
-c   fin modif
-
-c      EXTERNAL masskg
-      EXTERNAL advx
-      EXTERNAL advy
-      EXTERNAL advz
-
-c  modif Fred 24 03 96
-      data first/.TRUE./
-
-      limit = .TRUE.
-      pente_max=2
-c     if (mode.eq.1.or.mode.eq.3) then
-c     if (mode.eq.1) then
-      if (mode>=1) then
-        lati=2
-        latf=jjm
-      else
-        lati=1
-        latf=jjp1
-      endif
-
-      qmin=0.4995
-      qmin=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
-            PRINT*,coslondlon(i),sinlondlon(i)
-         enddo
-         coslon(1)=coslon(iip1)
-         coslondlon(1)=coslondlon(iip1)
-         sinlon(1)=sinlon(iip1)
-         sinlondlon(1)=sinlondlon(iip1)
-         PRINT*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1)
-         PRINT*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1)
-        DO l = 1,llm
-        DO j = 1,jjp1
-         DO i = 1,iip1
-         q ( i,j,l,1 )=0.
-         q ( i,j,l,2 )=0.
-         q ( i,j,l,3 )=0.  
-         ENDDO
-         ENDDO
-        ENDDO
-        
-      endif
-c   Fin modif Fred
-
-c *** q contient les qqtes de traceur avant l'advection 
-
-c *** Affectation des tableaux S a partir de Q
-c *** Rem : utilisation de SCOPY ulterieurement
- 
-       DO l = 1,llm
-        DO j = 1,jjp1
-         DO i = 1,iip1
-             s0( i,j,llm+1-l ) = q ( i,j,l,0 )
-             sx( i,j,llm+1-l ) = q ( i,j,l,1 )
-             sy( i,j,llm+1-l ) = q ( i,j,l,2 )
-             sz( i,j,llm+1-l ) = q ( i,j,l,3 )
-         ENDDO
-        ENDDO
-       ENDDO
-
-c      PRINT*,'----- S0 just before conversion -------'
-c      PRINT*,'S0(16,12,1)=',s0(16,12,1) 
-c      PRINT*,'Q(16,12,1,4)=',q(16,12,1,4)
-
-c *** On calcule la masse d'air en kg
-
-       DO  l = 1,llm
-         DO  j = 1,jjp1
-           DO  i = 1,iip1
-            sm ( i,j,llm+1-l)=masse( i,j,l )
-          ENDDO
-         ENDDO
-       ENDDO
-
-c *** On converti les champs S en atome (resp. kg) 
-c *** Les routines d'advection traitent les champs
-c *** a advecter si ces derniers sont en atome (resp. kg)
-c *** A optimiser !!!
-
-       DO  l = 1,llm
-         DO  j = 1,jjp1
-           DO  i = 1,iip1
-               s0(i,j,l) = s0(i,j,l) * sm ( i,j,l )
-               sx(i,j,l) = sx(i,j,l) * sm ( i,j,l )
-               sy(i,j,l) = sy(i,j,l) * sm ( i,j,l )
-               sz(i,j,l) = sz(i,j,l) * sm ( i,j,l )
-           ENDDO
-         ENDDO
-       ENDDO
-
-c       ss0 = 0.
-c       DO l = 1,llm
-c        DO j = 1,jjp1
-c         DO i = 1,iim
-c            ss0 = ss0 + s0 ( i,j,l )
-c         ENDDO
-c        ENDDO
-c       ENDDO
-c       PRINT*, 'valeur tot s0 avant advection=',ss0
-
-c *** Appel des subroutines d'advection en X, en Y et en Z
-c *** Advection avec "time-splitting"
-      
-c-----------------------------------------------------------
-c      PRINT*,'----- S0 just before ADVX -------'
-c      PRINT*,'S0(16,12,1)=',s0(16,12,1)
-
-c-----------------------------------------------------------
-c      do l=1,llm
-c         do j=1,jjp1
-c          do i=1,iip1
-c             zq=s0(i,j,l)/sm(i,j,l)
-c            if(zq.lt.qmin)
-c    ,       PRINT*,'avant advx1, s0(',i,',',j,',',l,')=',zq
-c          enddo
-c         enddo
-c      enddo
-CCC
-       if(mode==2) then
-          do l=1,llm
-            s0s=0.
-            s0n=0.
-            dyn1=0.
-            dys1=0.
-            dyn2=0.
-            dys2=0.
-            smn=0.
-            sms=0.
-            do i=1,iim
-               smn=smn+sm(i,1,l)
-               sms=sms+sm(i,jjp1,l)
-               s0n=s0n+s0(i,1,l)
-               s0s=s0s+s0(i,jjp1,l)
-               zz=sy(i,1,l)/sm(i,1,l)
-               dyn1=dyn1+sinlondlon(i)*zz
-               dyn2=dyn2+coslondlon(i)*zz
-               zz=sy(i,jjp1,l)/sm(i,jjp1,l)
-               dys1=dys1+sinlondlon(i)*zz
-               dys2=dys2+coslondlon(i)*zz
-            enddo
-            do i=1,iim
-               sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i)
-               sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i)
-            enddo
-            do i=1,iim
-               s0(i,1,l)=s0n/smn+sy(i,1,l)
-               s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l)
-            enddo
-
-            s0(iip1,1,l)=s0(1,1,l)
-            s0(iip1,jjp1,l)=s0(1,jjp1,l)
-
-            do i=1,iim
-               sxn(i)=s0(i+1,1,l)-s0(i,1,l)
-               sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l)
-c   on rerentre les masses
-            enddo
-            do i=1,iim
-               sy(i,1,l)=sy(i,1,l)*sm(i,1,l)
-               sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l)
-               s0(i,1,l)=s0(i,1,l)*sm(i,1,l)
-               s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l)
-            enddo
-            sxn(iip1)=sxn(1)
-            sxs(iip1)=sxs(1)
-            do i=1,iim
-               sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l)
-               sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l)
-            enddo
-            s0(iip1,1,l)=s0(1,1,l)
-            s0(iip1,jjp1,l)=s0(1,jjp1,l)
-            sy(iip1,1,l)=sy(1,1,l)
-            sy(iip1,jjp1,l)=sy(1,jjp1,l)
-            sx(1,1,l)=sx(iip1,1,l)
-            sx(1,jjp1,l)=sx(iip1,jjp1,l)
-          enddo
-      endif
-
-      if (mode==4) then
-         do l=1,llm
-            do i=1,iip1
-               sx(i,1,l)=0.
-               sx(i,jjp1,l)=0.
-               sy(i,1,l)=0.
-               sy(i,jjp1,l)=0.
-            enddo
-         enddo
-      endif
-      CALL limx(s0,sx,sm,pente_max)
-c     CALL minmaxq(zq,1.e33,-1.e33,'avant advx     ')
-       CALL advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
-c     CALL minmaxq(zq,1.e33,-1.e33,'avant advy     ')
-      if (mode==4) then
-         do l=1,llm
-            do i=1,iip1
-               sx(i,1,l)=0.
-               sx(i,jjp1,l)=0.
-               sy(i,1,l)=0.
-               sy(i,jjp1,l)=0.
-            enddo
-         enddo
-      endif
-       CALL   limy(s0,sy,sm,pente_max)
-       CALL advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz )
-c     CALL minmaxq(zq,1.e33,-1.e33,'avant advz     ')
-       do j=1,jjp1
-          do i=1,iip1
-             sz(i,j,1)=0.
-             sz(i,j,llm)=0.
-          enddo
-       enddo
-       CALL limz(s0,sz,sm,pente_max)
-       CALL advz( limit,dtvr,w,sm,s0,sx,sy,sz )
-      if (mode==4) then
-         do l=1,llm
-            do i=1,iip1
-               sx(i,1,l)=0.
-               sx(i,jjp1,l)=0.
-               sy(i,1,l)=0.
-               sy(i,jjp1,l)=0.
-            enddo
-         enddo
-      endif
-        CALL limy(s0,sy,sm,pente_max)
-       CALL advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz )
-       do l=1,llm
-          do j=1,jjp1
-             sm(iip1,j,l)=sm(1,j,l)
-             s0(iip1,j,l)=s0(1,j,l)
-             sx(iip1,j,l)=sx(1,j,l)
-             sy(iip1,j,l)=sy(1,j,l)
-             sz(iip1,j,l)=sz(1,j,l)
-          enddo
-       enddo
-
-
-c     CALL minmaxq(zq,1.e33,-1.e33,'avant advx     ')
-      if (mode==4) then
-         do l=1,llm
-            do i=1,iip1
-               sx(i,1,l)=0.
-               sx(i,jjp1,l)=0.
-               sy(i,1,l)=0.
-               sy(i,jjp1,l)=0.
-            enddo
-         enddo
-      endif
-       CALL limx(s0,sx,sm,pente_max)
-       CALL advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
-c     CALL minmaxq(zq,1.e33,-1.e33,'apres advx     ')
-c      do l=1,llm
-c         do j=1,jjp1
-c          do i=1,iip1
-c             zq=s0(i,j,l)/sm(i,j,l)
-c            if(zq.lt.qmin)
-c    ,       PRINT*,'apres advx2, s0(',i,',',j,',',l,')=',zq
-c          enddo
-c         enddo
-c      enddo
-c ***   On repasse les S dans la variable q directement 14/10/94
-c   On revient a des rapports de melange en divisant par la masse
-
-c En dehors des poles:
-
-       DO  l = 1,llm
-        DO  j = 1,jjp1
-         DO  i = 1,iim
-             q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l)
-             q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l)
-             q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l)
-             q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l)
-         ENDDO
-        ENDDO
-      ENDDO
-
-c Traitements specifiques au pole
-
-      if(mode>=1) then
-      DO l=1,llm
-c   filtrages aux poles
-         masn=ssum(iim,sm(1,1,l),1)
-         mass=ssum(iim,sm(1,jjp1,l),1)
-         qpn=ssum(iim,s0(1,1,l),1)/masn
-         qps=ssum(iim,s0(1,jjp1,l),1)/mass
-         dqzpn=ssum(iim,sz(1,1,l),1)/masn
-         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
-         do i=1,iip1
-            q( i,1,llm+1-l,3)=dqzpn
-            q( i,jjp1,llm+1-l,3)=dqzps
-            q( i,1,llm+1-l,0)=qpn
-            q( i,jjp1,llm+1-l,0)=qps
-         enddo
-         if(mode==3) then
-            dyn1=0.
-            dys1=0.
-            dyn2=0.
-            dys2=0.
-            do i=1,iim
-               dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l)
-               dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l)
-               dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
-               dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
-            enddo
-            do i=1,iim
-               q(i,1,llm+1-l,2)=
-     s          (sinlon(i)*dyn1+coslon(i)*dyn2)
-               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
-               q(i,jjp1,llm+1-l,2)=
-     s          (sinlon(i)*dys1+coslon(i)*dys2)
-               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
-     s         -q(i,jjp1,llm+1-l,2)
-            enddo
-         endif
-         if(mode==1) then
-c   on filtre les valeurs au bord de la "grande maille pole"
-            dyn1=0.
-            dys1=0.
-            dyn2=0.
-            dys2=0.
-            do i=1,iim
-               zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
-               dyn1=dyn1+sinlondlon(i)*zz
-               dyn2=dyn2+coslondlon(i)*zz
-               zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
-               dys1=dys1+sinlondlon(i)*zz
-               dys2=dys2+coslondlon(i)*zz
-            enddo
-            do i=1,iim
-               q(i,1,llm+1-l,2)=
-     s          (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
-               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
-               q(i,jjp1,llm+1-l,2)=
-     s          (sinlon(i)*dys1+coslon(i)*dys2)/2.
-               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
-     s         -q(i,jjp1,llm+1-l,2)
-            enddo
-            q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
-            q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
-
-            do i=1,iim
-               sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
-               sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
-            enddo
-            sxn(iip1)=sxn(1)
-            sxs(iip1)=sxs(1)
-            do i=1,iim
-               q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
-               q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
-            enddo
-            q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
-            q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1)
-
-         endif
-
-       ENDDO
-       endif
-
-c bouclage en longitude
-      do iq=0,3
-         do l=1,llm
-            do j=1,jjp1
-               q(iip1,j,l,iq)=q(1,j,l,iq)
-            enddo
-         enddo
-      enddo
-
-c       PRINT*, ' SORTIE DE PENTES ---  ca peut glisser ....'
-
-        DO l = 1,llm
-             DO j = 1,jjp1
-              DO i = 1,iip1
-                IF (q(i,j,l,0)<0.)  THEN
-c                    PRINT*,'------------ BIP-----------' 
-c                    PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0)
-c                    PRINT*,'QX(',i,j,l,')=',q(i,j,l,1)
-c                    PRINT*,'QY(',i,j,l,')=',q(i,j,l,2)
-c                    PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3)
-c                            PRINT*,' PBL EN SORTIE DE PENTES'
-                     q(i,j,l,0)=0.
-c                    STOP
-                 ENDIF
-          ENDDO
-         ENDDO
-        ENDDO
-
-c       PRINT*, '-------------------------------------------'
-        
-       do l=1,llm
-          do j=1,jjp1
-           do i=1,iip1
-             if(q(i,j,l,0)<qmin)
-     ,       PRINT*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)
-           enddo
-          enddo
-       enddo
-      RETURN
-      END
-
-
-
-
-
-
-
-
-
-
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.f90	(revision 5105)
@@ -0,0 +1,479 @@
+
+! $Header$
+
+SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
+
+  USE comconst_mod, ONLY: pi, dtvr
+
+  IMPLICIT NONE
+
+  !=======================================================================
+  !   Adaptation LMDZ:  A.Armengaud (LGGE)
+  !   ----------------
+  !
+  !   ********************************************************************
+  !   Transport des traceurs par la methode des pentes
+  !   ********************************************************************
+  !   Reference possible : Russel. G.L., Lerner J.A.:
+  !     A new Finite-Differencing Scheme for Traceur Transport
+  !     Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81
+  !   ********************************************************************
+  !   q,w,masse,pbaru et pbarv
+  !                  sont des arguments d'entree  pour le s-pg ....
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  !   Arguments:
+  !   ----------
+  integer :: mode
+  REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+  REAL :: q( iip1,jjp1,llm,0:3)
+  REAL :: w( ip1jmp1,llm )
+  REAL :: masse( iip1,jjp1,llm)
+  !   Local:
+  !   ------
+  LOGICAL :: limit
+  REAL :: sm ( iip1,jjp1, llm )
+  REAL :: s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+  REAL :: sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+  real :: masn,mass,zz
+  INTEGER :: i,j,l,iq
+
+  !  modif Fred 24 03 96
+
+  real :: sinlon(iip1),sinlondlon(iip1)
+  real :: coslon(iip1),coslondlon(iip1)
+  save sinlon,coslon,sinlondlon,coslondlon
+  real :: dyn1,dyn2,dys1,dys2
+  real :: qpn,qps,dqzpn,dqzps
+  real :: smn,sms,s0n,s0s,sxn(iip1),sxs(iip1)
+  real :: qmin,zq,pente_max
+  !
+  REAL :: SSUM
+  integer :: ismax,ismin,lati,latf
+  EXTERNAL  SSUM, ismin,ismax
+  logical :: first
+  save first
+  !   fin modif
+
+   ! EXTERNAL masskg
+  EXTERNAL advx
+  EXTERNAL advy
+  EXTERNAL advz
+
+  !  modif Fred 24 03 96
+  data first/.TRUE./
+
+  limit = .TRUE.
+  pente_max=2
+  ! if (mode.eq.1.or.mode.eq.3) then
+  ! if (mode.eq.1) then
+  if (mode>=1) then
+    lati=2
+    latf=jjm
+  else
+    lati=1
+    latf=jjp1
+  endif
+
+  qmin=0.4995
+  qmin=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
+        PRINT*,coslondlon(i),sinlondlon(i)
+     enddo
+     coslon(1)=coslon(iip1)
+     coslondlon(1)=coslondlon(iip1)
+     sinlon(1)=sinlon(iip1)
+     sinlondlon(1)=sinlondlon(iip1)
+     PRINT*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1)
+     PRINT*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1)
+    DO l = 1,llm
+    DO j = 1,jjp1
+     DO i = 1,iip1
+     q ( i,j,l,1 )=0.
+     q ( i,j,l,2 )=0.
+     q ( i,j,l,3 )=0.
+     ENDDO
+     ENDDO
+    ENDDO
+
+  endif
+  !   Fin modif Fred
+
+  ! *** q contient les qqtes de traceur avant l'advection
+
+  ! *** Affectation des tableaux S a partir de Q
+  ! *** Rem : utilisation de SCOPY ulterieurement
+
+   DO l = 1,llm
+    DO j = 1,jjp1
+     DO i = 1,iip1
+         s0( i,j,llm+1-l ) = q ( i,j,l,0 )
+         sx( i,j,llm+1-l ) = q ( i,j,l,1 )
+         sy( i,j,llm+1-l ) = q ( i,j,l,2 )
+         sz( i,j,llm+1-l ) = q ( i,j,l,3 )
+     ENDDO
+    ENDDO
+   ENDDO
+
+   ! PRINT*,'----- S0 just before conversion -------'
+   ! PRINT*,'S0(16,12,1)=',s0(16,12,1)
+   ! PRINT*,'Q(16,12,1,4)=',q(16,12,1,4)
+
+  ! *** On calcule la masse d'air en kg
+
+   DO  l = 1,llm
+     DO  j = 1,jjp1
+       DO  i = 1,iip1
+        sm ( i,j,llm+1-l)=masse( i,j,l )
+      ENDDO
+     ENDDO
+   ENDDO
+
+  ! *** On converti les champs S en atome (resp. kg)
+  ! *** Les routines d'advection traitent les champs
+  ! *** a advecter si ces derniers sont en atome (resp. kg)
+  ! *** A optimiser !!!
+
+   DO  l = 1,llm
+     DO  j = 1,jjp1
+       DO  i = 1,iip1
+           s0(i,j,l) = s0(i,j,l) * sm ( i,j,l )
+           sx(i,j,l) = sx(i,j,l) * sm ( i,j,l )
+           sy(i,j,l) = sy(i,j,l) * sm ( i,j,l )
+           sz(i,j,l) = sz(i,j,l) * sm ( i,j,l )
+       ENDDO
+     ENDDO
+   ENDDO
+
+    ! ss0 = 0.
+    ! DO l = 1,llm
+    !  DO j = 1,jjp1
+    !   DO i = 1,iim
+    !      ss0 = ss0 + s0 ( i,j,l )
+    !   ENDDO
+    !  ENDDO
+    ! ENDDO
+    ! PRINT*, 'valeur tot s0 avant advection=',ss0
+
+  ! *** Appel des subroutines d'advection en X, en Y et en Z
+  ! *** Advection avec "time-splitting"
+
+  !-----------------------------------------------------------
+   ! PRINT*,'----- S0 just before ADVX -------'
+   ! PRINT*,'S0(16,12,1)=',s0(16,12,1)
+
+  !-----------------------------------------------------------
+   ! do l=1,llm
+   !    do j=1,jjp1
+   !     do i=1,iip1
+   !        zq=s0(i,j,l)/sm(i,j,l)
+   !       if(zq.lt.qmin)
+  !    ,       PRINT*,'avant advx1, s0(',i,',',j,',',l,')=',zq
+   !     enddo
+   !    enddo
+   ! enddo
+  !CC
+   if(mode==2) then
+      do l=1,llm
+        s0s=0.
+        s0n=0.
+        dyn1=0.
+        dys1=0.
+        dyn2=0.
+        dys2=0.
+        smn=0.
+        sms=0.
+        do i=1,iim
+           smn=smn+sm(i,1,l)
+           sms=sms+sm(i,jjp1,l)
+           s0n=s0n+s0(i,1,l)
+           s0s=s0s+s0(i,jjp1,l)
+           zz=sy(i,1,l)/sm(i,1,l)
+           dyn1=dyn1+sinlondlon(i)*zz
+           dyn2=dyn2+coslondlon(i)*zz
+           zz=sy(i,jjp1,l)/sm(i,jjp1,l)
+           dys1=dys1+sinlondlon(i)*zz
+           dys2=dys2+coslondlon(i)*zz
+        enddo
+        do i=1,iim
+           sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i)
+           sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i)
+        enddo
+        do i=1,iim
+           s0(i,1,l)=s0n/smn+sy(i,1,l)
+           s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l)
+        enddo
+
+        s0(iip1,1,l)=s0(1,1,l)
+        s0(iip1,jjp1,l)=s0(1,jjp1,l)
+
+        do i=1,iim
+           sxn(i)=s0(i+1,1,l)-s0(i,1,l)
+           sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l)
+  !   on rerentre les masses
+        enddo
+        do i=1,iim
+           sy(i,1,l)=sy(i,1,l)*sm(i,1,l)
+           sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l)
+           s0(i,1,l)=s0(i,1,l)*sm(i,1,l)
+           s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l)
+        enddo
+        sxn(iip1)=sxn(1)
+        sxs(iip1)=sxs(1)
+        do i=1,iim
+           sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l)
+           sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l)
+        enddo
+        s0(iip1,1,l)=s0(1,1,l)
+        s0(iip1,jjp1,l)=s0(1,jjp1,l)
+        sy(iip1,1,l)=sy(1,1,l)
+        sy(iip1,jjp1,l)=sy(1,jjp1,l)
+        sx(1,1,l)=sx(iip1,1,l)
+        sx(1,jjp1,l)=sx(iip1,jjp1,l)
+      enddo
+  endif
+
+  if (mode==4) then
+     do l=1,llm
+        do i=1,iip1
+           sx(i,1,l)=0.
+           sx(i,jjp1,l)=0.
+           sy(i,1,l)=0.
+           sy(i,jjp1,l)=0.
+        enddo
+     enddo
+  endif
+  CALL limx(s0,sx,sm,pente_max)
+  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+   CALL advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
+  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advy     ')
+  if (mode==4) then
+     do l=1,llm
+        do i=1,iip1
+           sx(i,1,l)=0.
+           sx(i,jjp1,l)=0.
+           sy(i,1,l)=0.
+           sy(i,jjp1,l)=0.
+        enddo
+     enddo
+  endif
+   CALL   limy(s0,sy,sm,pente_max)
+   CALL advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz )
+  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advz     ')
+   do j=1,jjp1
+      do i=1,iip1
+         sz(i,j,1)=0.
+         sz(i,j,llm)=0.
+      enddo
+   enddo
+   CALL limz(s0,sz,sm,pente_max)
+   CALL advz( limit,dtvr,w,sm,s0,sx,sy,sz )
+  if (mode==4) then
+     do l=1,llm
+        do i=1,iip1
+           sx(i,1,l)=0.
+           sx(i,jjp1,l)=0.
+           sy(i,1,l)=0.
+           sy(i,jjp1,l)=0.
+        enddo
+     enddo
+  endif
+    CALL limy(s0,sy,sm,pente_max)
+   CALL advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz )
+   do l=1,llm
+      do j=1,jjp1
+         sm(iip1,j,l)=sm(1,j,l)
+         s0(iip1,j,l)=s0(1,j,l)
+         sx(iip1,j,l)=sx(1,j,l)
+         sy(iip1,j,l)=sy(1,j,l)
+         sz(iip1,j,l)=sz(1,j,l)
+      enddo
+   enddo
+
+
+  ! CALL minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+  if (mode==4) then
+     do l=1,llm
+        do i=1,iip1
+           sx(i,1,l)=0.
+           sx(i,jjp1,l)=0.
+           sy(i,1,l)=0.
+           sy(i,jjp1,l)=0.
+        enddo
+     enddo
+  endif
+   CALL limx(s0,sx,sm,pente_max)
+   CALL advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
+  ! CALL minmaxq(zq,1.e33,-1.e33,'apres advx     ')
+  !  do l=1,llm
+  !     do j=1,jjp1
+  !      do i=1,iip1
+  !         zq=s0(i,j,l)/sm(i,j,l)
+  !        if(zq.lt.qmin)
+  !    ,       PRINT*,'apres advx2, s0(',i,',',j,',',l,')=',zq
+  !      enddo
+  !     enddo
+  !  enddo
+  ! ***   On repasse les S dans la variable q directement 14/10/94
+  !   On revient a des rapports de melange en divisant par la masse
+
+  ! En dehors des poles:
+
+   DO  l = 1,llm
+    DO  j = 1,jjp1
+     DO  i = 1,iim
+         q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l)
+         q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l)
+         q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l)
+         q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l)
+     ENDDO
+    ENDDO
+  ENDDO
+
+  ! Traitements specifiques au pole
+
+  if(mode>=1) then
+  DO l=1,llm
+  !   filtrages aux poles
+     masn=ssum(iim,sm(1,1,l),1)
+     mass=ssum(iim,sm(1,jjp1,l),1)
+     qpn=ssum(iim,s0(1,1,l),1)/masn
+     qps=ssum(iim,s0(1,jjp1,l),1)/mass
+     dqzpn=ssum(iim,sz(1,1,l),1)/masn
+     dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+     do i=1,iip1
+        q( i,1,llm+1-l,3)=dqzpn
+        q( i,jjp1,llm+1-l,3)=dqzps
+        q( i,1,llm+1-l,0)=qpn
+        q( i,jjp1,llm+1-l,0)=qps
+     enddo
+     if(mode==3) then
+        dyn1=0.
+        dys1=0.
+        dyn2=0.
+        dys2=0.
+        do i=1,iim
+           dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l)
+           dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l)
+           dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+           dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+        enddo
+        do i=1,iim
+           q(i,1,llm+1-l,2)= &
+                 (sinlon(i)*dyn1+coslon(i)*dyn2)
+           q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+           q(i,jjp1,llm+1-l,2)= &
+                 (sinlon(i)*dys1+coslon(i)*dys2)
+           q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) &
+                 -q(i,jjp1,llm+1-l,2)
+        enddo
+     endif
+     if(mode==1) then
+  !   on filtre les valeurs au bord de la "grande maille pole"
+        dyn1=0.
+        dys1=0.
+        dyn2=0.
+        dys2=0.
+        do i=1,iim
+           zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+           dyn1=dyn1+sinlondlon(i)*zz
+           dyn2=dyn2+coslondlon(i)*zz
+           zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+           dys1=dys1+sinlondlon(i)*zz
+           dys2=dys2+coslondlon(i)*zz
+        enddo
+        do i=1,iim
+           q(i,1,llm+1-l,2)= &
+                 (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+           q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+           q(i,jjp1,llm+1-l,2)= &
+                 (sinlon(i)*dys1+coslon(i)*dys2)/2.
+           q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) &
+                 -q(i,jjp1,llm+1-l,2)
+        enddo
+        q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+        q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+
+        do i=1,iim
+           sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+           sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+        enddo
+        sxn(iip1)=sxn(1)
+        sxs(iip1)=sxs(1)
+        do i=1,iim
+           q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+           q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+        enddo
+        q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+        q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1)
+
+     endif
+
+   ENDDO
+   endif
+
+  ! bouclage en longitude
+  do iq=0,3
+     do l=1,llm
+        do j=1,jjp1
+           q(iip1,j,l,iq)=q(1,j,l,iq)
+        enddo
+     enddo
+  enddo
+
+    ! PRINT*, ' SORTIE DE PENTES ---  ca peut glisser ....'
+
+    DO l = 1,llm
+         DO j = 1,jjp1
+          DO i = 1,iip1
+            IF (q(i,j,l,0)<0.)  THEN
+                 ! PRINT*,'------------ BIP-----------'
+                 ! PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0)
+                 ! PRINT*,'QX(',i,j,l,')=',q(i,j,l,1)
+                 ! PRINT*,'QY(',i,j,l,')=',q(i,j,l,2)
+                 ! PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3)
+                 !         PRINT*,' PBL EN SORTIE DE PENTES'
+                 q(i,j,l,0)=0.
+                 ! STOP
+             ENDIF
+      ENDDO
+     ENDDO
+    ENDDO
+
+    ! PRINT*, '-------------------------------------------'
+
+   do l=1,llm
+      do j=1,jjp1
+       do i=1,iip1
+         if(q(i,j,l,0)<qmin) &
+               PRINT*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)
+       enddo
+      enddo
+   enddo
+  RETURN
+END SUBROUTINE pentes_ini
+
+
+
+
+
+
+
+
+
+
+
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.F	(revision 5104)
+++ 	(revision )
@@ -1,2148 +1,0 @@
-
-! $Id$
-
-cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998
-cDate: Wed, 15 Apr 1998 11:37:03 -0400
-cFrom: lin@explorer.gsfc.nasa.gov
-cTo: Frederic.Hourdin@lmd.jussieu.fr
-cSubject: 3D transport module of the GSFC CTM and GEOS GCM
-
-
-cThis code is sent to you by S-J Lin, DAO, NASA-GSFC
-
-cNote: this version is intended for machines like CRAY
-C-90. No multitasking directives implemented.
-
-      
-C ********************************************************************
-C
-C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard
-C Earth Observing System General Circulation Model (GEOS-GCM), and Data
-C Assimilation System (GEOS-DAS).
-C
-C ********************************************************************
-C
-C Purpose: given horizontal winds on  a hybrid sigma-p surfaces,
-C          one CALL to tpcore updates the 3-D mixing ratio
-C          fields one time step (NDT). [vertical mass flux is computed
-C          internally consistent with the discretized hydrostatic mass
-C          continuity equation of the C-Grid GEOS-GCM (for IGD=1)].
-C
-C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based
-C          on the van Leer or PPM.
-C          (see Lin and Rood 1996).
-C Version 4.5
-C Last modified: Dec. 5, 1996
-C Major changes from version 4.0: a more general vertical hybrid sigma-
-C pressure coordinate.
-C Subroutines modified: xtp, ytp, fzppm, qckxyz
-C Subroutines deleted: vanz
-C
-C Author: Shian-Jiann Lin
-C mail address:
-C                 Shian-Jiann Lin*
-C                 Code 910.3, NASA/GSFC, Greenbelt, MD 20771
-C                 Phone: 301-286-9540
-C                 E-mail: lin@dao.gsfc.nasa.gov
-C
-C *affiliation:
-C                 Joint Center for Earth Systems Technology
-C                 The University of Maryland Baltimore County
-C                 NASA - Goddard Space Flight Center
-C References:
-C
-C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi-
-C    Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070.
-C
-C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of
-C    the van Leer-type transport schemes and its applications to the moist-
-C    ure transport in a General Circulation Model. Mon. Wea. Rev., 122,
-C    1575-1593.
-C
-C ****6***0*********0*********0*********0*********0*********0**********72
-C
-      SUBROUTINE ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR,
-     &                  JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax)
-
-      implicit none
-
-c     rajout de déclarations
-c      integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd
-c      integer iu,iiu,j2,jmr,js0,jt
-c      real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp
-c      real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru
-C
-C ********************************************************************
-C
-C =============
-C INPUT:
-C =============
-C
-C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t)
-C NC: total # of constituents
-C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR
-C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1
-C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at
-C       the model top to NLAY near the surface (see fig. below).
-C       It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation)
-C
-C PS1(IMR,JNP): surface pressure at current time (t)
-C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2)
-C PS2 is replaced by the predicted PS (at t+NDT) on output.
-C Note: surface pressure can have any unit or can be multiplied by any
-C       const.
-C
-C The pressure at layer edges are defined as follows:
-C
-C        p(i,j,k) = AP(k)*PT  +  BP(k)*PS(i,j)          (1)
-C
-C Where PT is a constant having the same unit as PS.
-C AP and BP are unitless constants given at layer edges
-C defining the vertical coordinate. 
-C BP(1) = 0., BP(NLAY+1) = 1.
-C The pressure at the model top is PTOP = AP(1)*PT
-C
-C For pure sigma system set AP(k) = 1 for all k, PT = PTOP,
-C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP.
-C
-C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn
-C is a subset of the following even more general sigma-P-thelta coord.
-C currently under development.
-C  p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa))
-C
-C                  /////////////////////////////////
-C              / \ ------------- PTOP --------------  AP(1), BP(1)
-C               |
-C    delp(1)    |  ........... Q(i,j,1) ............  
-C               |
-C      W(1)    \ / ---------------------------------  AP(2), BP(2)
-C
-C
-C
-C     W(k-1)   / \ ---------------------------------  AP(k), BP(k)
-C               |
-C    delp(K)    |  ........... Q(i,j,k) ............ 
-C               |
-C      W(k)    \ / ---------------------------------  AP(k+1), BP(k+1)
-C
-C
-C
-C              / \ ---------------------------------  AP(NLAY), BP(NLAY)
-C               |
-C  delp(NLAY)   |  ........... Q(i,j,NLAY) .........  
-C               |
-C   W(NLAY)=0  \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1)
-C                 //////////////////////////////////
-C
-C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2)
-C U and V may need to be polar filtered in advance in some cases.
-C 
-C IGD:      grid type on which winds are defined.
-C IGD = 0:  A-Grid  [all variables defined at the same point from south
-C                   pole (j=1) to north pole (j=JNP) ]
-C
-C IGD = 1  GEOS-GCM C-Grid
-C                                      [North]
-C
-C                                       V(i,j)
-C                                          |
-C                                          |
-C                                          |
-C                             U(i-1,j)---Q(i,j)---U(i,j) [EAST]
-C                                          |
-C                                          |
-C                                          |
-C                                       V(i,j-1)
-C
-C         U(i,  1) is defined at South Pole.
-C         V(i,  1) is half grid north of the South Pole.
-C         V(i,JMR) is half grid south of the North Pole.
-C
-C         V must be defined at j=1 and j=JMR if IGD=1
-C         V at JNP need not be given.
-C
-C NDT: time step in seconds (need not be constant during the course of
-C      the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5
-C      (Lat-Lon) resolution. Smaller values are recommanded if the model
-C      has a well-resolved stratosphere.
-C
-C J1 defines the size of the polar cap:
-C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg.
-C North polar cap edge is located at  90 - (j1-1.5)*180/(JNP-1) deg.
-C There are currently only two choices (j1=2 or 3).
-C IMR must be an even integer if j1 = 2. Recommended value: J1=3.
-C
-C IORD, JORD, and KORD are integers controlling various options in E-W, N-S,
-C and vertical transport, respectively. Recommended values for positive
-C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non-
-C positive definite scalars or when linear correlation between constituents
-C is to be maintained.
-C
-C  _ORD= 
-C        1: 1st order upstream scheme (too diffusive, not a useful option; it
-C           can be used for debugging purposes; this is THE only known "linear"
-C           monotonic advection scheme.).
-C        2: 2nd order van Leer (full monotonicity constraint;
-C           see Lin et al 1994, MWR)
-C        3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984)
-C        4: semi-monotonic PPM (same as 3, but overshoots are allowed)
-C        5: positive-definite PPM (constraint on the subgrid distribution is
-C           only strong enough to prevent generation of negative values;
-C           both overshoots & undershoots are possible).
-C        6: un-constrained PPM (nearly diffusion free; slightly faster but
-C           positivity not quaranteed. Use this option only when the fields
-C           and winds are very smooth).
-C
-C *PPM: Piece-wise Parabolic Method
-C
-C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5.
-C for non-positive definite scalars (such as Ertel Potential Vorticity).
-C
-C The implicit numerical diffusion decreases as _ORD increases.
-C The last two options (ORDER=5, 6) should only be used when there is
-C significant explicit diffusion (such as a turbulence parameterization). You
-C might get dispersive results otherwise.
-C No filter of any kind is applied to the constituent fields here.
-C
-C AE: Radius of the sphere (meters).
-C     Recommended value for the planet earth: 6.371E6
-C
-C fill(logical):   flag to do filling for negatives (see note below).
-C
-C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s).
-C (220 m/s is a good value for troposphere model; 280 m/s otherwise)
-C
-C =============
-C Output
-C =============
-C
-C Q: mixing ratios at future time (t+NDT) (original values are over-written)
-C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic
-C          relationship. W will have the same unit as PS1 and PS2 (eg, mb).
-C          W must be divided by NDT to get the correct mass-flux unit.
-C          The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND
-C          is the pressure thickness in the "upwind" direction. For example,
-C          C(k) = W(k)/delp(k)   if W(k) > 0;
-C          C(k) = W(k)/delp(k+1) if W(k) < 0.
-C              ( W > 0 is downward, ie, toward surface)
-C PS2: predicted PS at t+NDT (original values are over-written)
-C
-C ********************************************************************
-C NOTES:
-C This forward-in-time upstream-biased transport scheme reduces to
-C the 2nd order center-in-time center-in-space mass continuity eqn.
-C if Q = 1 (constant fields will remain constant). This also ensures
-C that the computed vertical velocity to be identical to GEOS-1 GCM
-C for on-line transport.
-C
-C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when
-C winds are noisy near poles).
-C
-C Flux-Form Semi-Lagrangian transport in the East-West direction is used
-C when and where Courant # is greater than one.
-C
-C The user needs to change the parameter Jmax or Kmax if the resolution
-C is greater than 0.5 deg in N-S or 150 layers in the vertical direction.
-C (this TransPort Core is otherwise resolution independent and can be used
-C as a library routine).
-C
-C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd
-C order accurate for non-uniform grid (vertical sigma coord.).
-C
-C Time step is limitted only by transport in the meridional direction.
-C (the FFSL scheme is not implemented in the meridional direction).
-C
-C Since only 1-D limiters are applied, negative values could
-C potentially be generated when large time step is used and when the
-C initial fields contain discontinuities.
-C This does not necessarily imply the integration is unstable.
-C These negatives are typically very small. A filling algorithm is
-C activated if the user set "fill" to be true.
-C
-C The van Leer scheme used here is nearly as accurate as the original PPM
-C due to the use of a 4th order accurate reference slope. The PPM imple-
-C mented here is an improvement over the original and is also based on
-C the 4th order reference slope.
-C
-C ****6***0*********0*********0*********0*********0*********0**********72
-C
-C     User modifiable parameters
-C
-      integer,parameter :: Jmax = 361, kmax = 150
-C
-C ****6***0*********0*********0*********0*********0*********0**********72
-C
-C Input-Output arrays
-C
-      
-      real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP),
-     &     U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1),
-     &     BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax
-      integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE
-      integer IMRD2
-      real    PT       
-      logical  cross, fill, dum
-C
-C Local dynamic arrays
-C
-      real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP),
-     &     fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY),
-     &     WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP),
-     &     delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP),
-     &     UA(IMR,JNP),qtmp(-IMR:2*IMR)
-C
-C Local static  arrays
-C
-      real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax),
-     &     cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax)
-      data NDT0, NSTEP /0, 0/
-      data cross /.TRUE./
-      REAL DTDY, DTDY5, RCAP
-      INTEGER JS0, JN0, IML, JMR, IMJM
-      SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML,
-     &     DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
-C
-      INTEGER NDT0, NSTEP, j2, k,j,i,ic,l,JS,JN,IMH
-      INTEGER IU,IIU,JT,iad,jad,krd
-      REAL r23,r3,PI,DL,DP,DT,CR1,MAXDT,ZTC,D5
-      REAL sum1,sum2,ru
-            
-      JMR = JNP -1
-      IMJM  = IMR*JNP
-      j2 = JNP - j1 + 1
-      NSTEP = NSTEP + 1
-C
-C *********** Initialization **********************
-      if(NSTEP==1) then
-c
-      write(6,*) '------------------------------------ '
-      write(6,*) 'NASA/GSFC Transport Core Version 4.5'
-      write(6,*) '------------------------------------ '
-c
-      WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1
-      WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT
-C
-C controles sur les parametres
-      if(NLAY<6) then
-        write(6,*) 'NLAY must be >= 6'
-        stop
-      endif
-      if (JNP<NLAY) then
-         write(6,*) 'JNP must be >= NLAY'
-        stop
-      endif
-      IMRD2=mod(IMR,2)
-      if (j1==2.and.IMRD2/=0) then
-         write(6,*) 'if j1=2 IMR must be an even integer'
-        stop
-      endif
-
-C
-      if(Jmax<JNP .or. Kmax<NLAY) then
-        write(6,*) 'Jmax or Kmax is too small'
-        stop
-      endif
-C
-      DO k=1,NLAY
-      DAP(k) = (AP(k+1) - AP(k))*PT
-      DBK(k) =  BP(k+1) - BP(k)
-      ENDDO     
-C
-      PI = 4. * ATAN(1.)
-      DL = 2.*PI / REAL(IMR)
-      DP =    PI / REAL(JMR)
-C
-      if(IGD==0) then
-C Compute analytic cosine at cell edges
-            CALL cosa(cosp,cose,JNP,PI,DP)
-      else
-C Define cosine consistent with GEOS-GCM (using dycore2.0 or later)
-            CALL cosc(cosp,cose,JNP,PI,DP)
-      endif
-C
-      do J=2,JMR
-      acosp(j) = 1. / cosp(j)
-      END DO
-C
-C Inverse of the Scaled polar cap area.
-C
-      RCAP  = DP / (IMR*(1.-COS((j1-1.5)*DP)))
-      acosp(1)   = RCAP
-      acosp(JNP) = RCAP
-      endif
-C
-      if(NDT0 /= NDT) then
-      DT   = NDT
-      NDT0 = NDT
-
-	if(Umax < 180.) then
-         write(6,*) 'Umax may be too small!'
-	endif
-      CR1  = abs(Umax*DT)/(DL*AE)
-      MaxDT = DP*AE / abs(Umax) + 0.5
-      write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT
-      if(MaxDT < abs(NDT)) then
-            write(6,*) 'Warning!!! NDT maybe too large!'
-      endif
-C
-      if(CR1>=0.95) then
-      JS0 = 0
-      JN0 = 0
-      IML = IMR-2
-      ZTC = 0.
-      else
-      ZTC  = acos(CR1) * (180./PI)
-C
-      JS0 = REAL(JMR)*(90.-ZTC)/180. + 2
-      JS0 = max(JS0, J1+1)
-      IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
-      JN0 = JNP-JS0+1
-      endif
-C     
-C
-      do J=2,JMR
-      DTDX(j)  = DT / ( DL*AE*COSP(J) )
-
-c     PRINT*,'dtdx=',dtdx(j)
-      DTDX5(j) = 0.5*DTDX(j)
-      enddo
-C
-      
-      DTDY  = DT /(AE*DP)
-c      PRINT*,'dtdy=',dtdy
-      DTDY5 = 0.5*DTDY
-C
-c      write(6,*) 'J1=',J1,' J2=', J2
-      endif
-C
-C *********** End Initialization **********************
-C
-C delp = pressure thickness: the psudo-density in a hydrostatic system.
-      do  k=1,NLAY
-         do  j=1,JNP
-            do  i=1,IMR
-               delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j)
-               delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j)       
-            enddo
-         enddo
-      enddo
-          
-C
-      if(j1/=2) then
-      DO IC=1,NC
-      DO L=1,NLAY
-      DO I=1,IMR
-      Q(I,  2,L,IC) = Q(I,  1,L,IC)
-      Q(I,JMR,L,IC) = Q(I,JNP,L,IC)
-      END DO
-      END DO
-      END DO
-      endif
-C
-C Compute "tracer density"
-      DO IC=1,NC
-      DO k=1,NLAY
-      DO j=1,JNP
-      DO i=1,IMR
-      DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k)
-      END DO
-      END DO
-      END DO
-      END DO
-C
-      do k=1,NLAY
-C
-      if(IGD==0) then
-C Convert winds on A-Grid to Courant # on C-Grid.
-      CALL A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
-      else
-C Convert winds on C-grid to Courant #
-      do j=j1,j2
-      do i=2,IMR
-      CRX(i,J) = dtdx(j)*U(i-1,j,k)
-      END DO
-      END DO
-   
-C
-      do j=j1,j2
-      CRX(1,J) = dtdx(j)*U(IMR,j,k)
-      END DO
-C
-      do i=1,IMR*JMR
-      CRY(i,2) = DTDY*V(i,1,k)
-      END DO
-      endif
-C     
-C Determine JS and JN
-      JS = j1
-      JN = j2
-C
-      do j=JS0,j1+1,-1
-      do i=1,IMR
-      if(abs(CRX(i,j))>1.) then
-            JS = j
-            go to 2222
-      endif
-      enddo
-      enddo
-C
-2222  continue
-      do j=JN0,j2-1
-      do i=1,IMR
-      if(abs(CRX(i,j))>1.) then
-            JN = j
-            go to 2233
-      endif
-      enddo
-      enddo
-2233  continue
-C
-      if(j1/=2) then           ! Enlarged polar cap.
-      do i=1,IMR
-      DPI(i,  2,k) = 0.
-      DPI(i,JMR,k) = 0.
-      enddo
-      endif
-C
-C ******* Compute horizontal mass fluxes ************
-C
-C N-S component
-      do j=j1,j2+1
-      D5 = 0.5 * COSE(j)
-      do i=1,IMR
-      ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k))
-      enddo
-      enddo
-C
-      do j=j1,j2
-      DO i=1,IMR
-      DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
-      END DO
-      END DO
-C
-C Poles
-      sum1 = ymass(IMR,j1  )
-      sum2 = ymass(IMR,J2+1)
-      do i=1,IMR-1
-      sum1 = sum1 + ymass(i,j1  )
-      sum2 = sum2 + ymass(i,J2+1)
-      enddo
-C
-      sum1 = - sum1 * RCAP
-      sum2 =   sum2 * RCAP
-      do i=1,IMR
-      DPI(i,  1,k) = sum1
-      DPI(i,JNP,k) = sum2
-      enddo
-C
-C E-W component
-C
-      do j=j1,j2
-      do i=2,IMR
-      PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k))
-      enddo
-      enddo
-C
-      do j=j1,j2
-      PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k))
-      enddo
-C
-      do j=j1,j2
-      DO i=1,IMR
-      xmass(i,j) = PU(i,j)*CRX(i,j)
-      END DO
-      END DO
-C
-      DO j=j1,j2
-      DO i=1,IMR-1
-      DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j)
-      END DO
-      END DO
-C
-      DO j=j1,j2
-      DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j)
-      END DO
-C
-      DO j=j1,j2
-      do i=1,IMR-1
-      UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j))
-      enddo
-      enddo
-C
-      DO j=j1,j2
-      UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j))
-      enddo
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c Rajouts pour LMDZ.3.3
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-      do i=1,IMR
-         do j=1,JNP
-             VA(i,j)=0.
-         enddo
-      enddo
-
-      do i=1,imr*(JMR-1)
-      VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3))
-      enddo
-C
-      if(j1==2) then
-	IMH = IMR/2
-      do i=1,IMH
-      VA(i,      1) = 0.5*(CRY(i,2)-CRY(i+IMH,2))
-      VA(i+IMH,  1) = -VA(i,1)
-      VA(i,    JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR))
-      VA(i+IMH,JNP) = -VA(i,JNP)
-      enddo
-      VA(IMR,1)=VA(1,1)
-      VA(IMR,JNP)=VA(1,JNP)
-      endif
-C
-C ****6***0*********0*********0*********0*********0*********0**********72
-      do IC=1,NC
-C
-      do i=1,IMJM
-      wk1(i,1,1) = 0.
-      wk1(i,1,2) = 0.
-      enddo
-C
-C E-W advective cross term
-      do j=J1,J2
-      if(J>JS  .and. J<JN) GO TO 250
-C
-      do i=1,IMR
-      qtmp(i) = q(i,j,k,IC)
-      enddo
-C
-      do i=-IML,0
-      qtmp(i)       = q(IMR+i,j,k,IC)
-      qtmp(IMR+1-i) = q(1-i,j,k,IC)
-      enddo
-C
-      DO i=1,IMR
-      iu = UA(i,j)
-      ru = UA(i,j) - iu
-      iiu = i-iu
-      if(UA(i,j)>=0.) then
-      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
-      else
-      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
-      endif
-      wk1(i,j,1) = wk1(i,j,1) - qtmp(i)
-      END DO
-250   continue
-      END DO
-C
-      if(JN/=0) then
-      do j=JS+1,JN-1
-C
-      do i=1,IMR
-      qtmp(i) = q(i,j,k,IC)
-      enddo
-C
-      qtmp(0)     = q(IMR,J,k,IC)
-      qtmp(IMR+1) = q(  1,J,k,IC)
-C
-      do i=1,imr
-      iu = i - UA(i,j)
-      wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1))
-      enddo
-      enddo
-      endif
-C ****6***0*********0*********0*********0*********0*********0**********72
-C Contribution from the N-S advection
-      do i=1,imr*(j2-j1+1)
-      JT = REAL(J1) - VA(i,j1)
-      wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
-      enddo
-C
-      do i=1,IMJM
-      wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1)
-      wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2)
-      enddo
-C
-	if(cross) then
-C Add cross terms in the vertical direction.
-	if(IORD >= 2) then
-		iad = 2
-	else
-		iad = 1
-	endif
-C
-	if(JORD >= 2) then
-		jad = 2
-	else
-		jad = 1
-	endif
-      CALL xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad)
-      CALL yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad)
-      do j=1,JNP
-      do i=1,IMR
-      q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j)
-      enddo
-      enddo
-      endif
-C
-      CALL xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2)
-     &        ,CRX,fx1,xmass,IORD)
-
-      CALL ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY,
-     &  DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD)
-C
-      END DO
-      END DO
-C
-C ******* Compute vertical mass flux (same unit as PS) ***********
-C
-C 1st step: compute total column mass CONVERGENCE.
-C
-      do j=1,JNP
-      do i=1,IMR
-      CRY(i,j) = DPI(i,j,1)
-      END DO
-      END DO
-C
-      do k=2,NLAY
-      do j=1,JNP
-      do i=1,IMR
-      CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
-      END DO
-      END DO
-      END DO
-C
-      do j=1,JNP
-      do i=1,IMR
-C
-C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption.
-C Changes (increases) to surface pressure = total column mass convergence
-C
-      PS2(i,j)  = PS1(i,j) + CRY(i,j)
-C
-C 3rd step: compute vertical mass flux from mass conservation principle.
-C
-      W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j)
-      W(i,j,NLAY) = 0.
-      END DO
-      END DO
-C
-      do k=2,NLAY-1
-      do j=1,JNP
-      do i=1,IMR
-      W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
-      END DO
-      END DO
-      END DO
-C
-      DO k=1,NLAY
-      DO j=1,JNP
-      DO i=1,IMR
-      delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j)
-      END DO
-      END DO
-      END DO
-C
-	KRD = max(3, KORD)
-      do IC=1,NC
-C
-C****6***0*********0*********0*********0*********0*********0**********72
-   
-      CALL FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI,
-     &           DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD)
-C
-    
-      if(fill) CALL qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2,
-     &                     cosp,acosp,.FALSE.,IC,NSTEP)
-C
-C Recover tracer mixing ratio from "density" using predicted
-C "air density" (pressure thickness) at time-level n+1
-C
-      DO k=1,NLAY
-      DO j=1,JNP
-      DO i=1,IMR
-            Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k)
-c            PRINT*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC)
-      enddo
-      enddo
-      enddo
-C     
-      if(j1/=2) then
-      DO k=1,NLAY
-      DO I=1,IMR
-c     j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord
-      Q(I,  2,k,IC) = Q(I,  1,k,IC)
-      Q(I,JMR,k,IC) = Q(I,JNP,k,IC)
-      END DO
-      END DO
-      endif
-      END DO
-C
-      if(j1/=2) then
-      DO k=1,NLAY
-      DO i=1,IMR
-      W(i,  2,k) = W(i,  1,k)
-      W(i,JMR,k) = W(i,JNP,k)
-      END DO
-      END DO
-      endif
-C
-      RETURN
-      END
-C
-C****6***0*********0*********0*********0*********0*********0**********72
-      SUBROUTINE FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6,
-     &                 flux,wk1,wk2,wz2,delp,KORD)
-      implicit none
-      integer,parameter :: kmax = 150 
-      real,parameter :: R23 = 2./3., R3 = 1./3.
-      integer IMR,JNP,NLAY,J1,KORD
-      real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY),
-     &     wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY),
-     &     DQDT(IMR,JNP,NLAY)
-C Assuming JNP >= NLAY
-      real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*),
-     &     wz2(IMR,*)
-      integer JMR,IMJM,NLAYM1,LMT,K,I,J
-      real c0,c1,c2,tmp,qmax,qmin,a,b,fct,a1,a2,cm,cp
-C
-      JMR = JNP - 1
-      IMJM = IMR*JNP
-      NLAYM1 = NLAY - 1
-C
-      LMT = KORD - 3
-C
-C ****6***0*********0*********0*********0*********0*********0**********72
-C Compute DC for PPM
-C ****6***0*********0*********0*********0*********0*********0**********72
-C
-      do k=1,NLAYM1
-      do i=1,IMJM
-      DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
-      END DO
-      END DO
-C
-      DO k=2,NLAYM1
-      DO I=1,IMJM
-       c0 =  delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1))
-       c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k))    
-       c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k))
-      tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1))
-      Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k)
-      Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1))
-      DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp)   
-      END DO
-      END DO
-     
-C     
-C ****6***0*********0*********0*********0*********0*********0**********72
-C Loop over latitudes  (to save memory)
-C ****6***0*********0*********0*********0*********0*********0**********72
-C
-      DO j=1,JNP
-      if((j==2 .or. j==JMR) .and. j1/=2) goto 2000
-C
-      DO k=1,NLAY
-      DO i=1,IMR
-      wz2(i,k) =   WZ(i,j,k)
-      wk1(i,k) =    P(i,j,k)
-      wk2(i,k) = delp(i,j,k)
-      flux(i,k) = DC(i,j,k)  !this flux is actually the monotone slope
-      enddo
-      enddo
-C
-C****6***0*********0*********0*********0*********0*********0**********72
-C Compute first guesses at cell interfaces
-C First guesses are required to be continuous.
-C ****6***0*********0*********0*********0*********0*********0**********72
-C
-C three-cell parabolic subgrid distribution at model top
-C two-cell parabolic with zero gradient subgrid distribution 
-C at the surface.
-C
-C First guess top edge value
-      DO i=1,IMR
-C three-cell PPM
-C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
-      a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/
-     &         (wk2(i,1)+wk2(i,2)) ) /
-     &       ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) )
-      b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - 
-     &    R23*a*(2.*wk2(i,1)+wk2(i,2))
-      AL(i,1) =  wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b)
-      AL(i,2) =  wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1)
-C
-C Check if change sign
-      if(wk1(i,1)*AL(i,1)<=0.) then
-		 AL(i,1) = 0.
-             flux(i,1) = 0.
-	else
-             flux(i,1) =  wk1(i,1) - AL(i,1)
-	endif
-      END DO
-C
-C Bottom
-      DO i=1,IMR
-C 2-cell PPM with zero gradient right at the surface
-C
-      fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 /
-     & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1)))
-      AR(i,NLAY) = wk1(i,NLAY) + fct
-      AL(i,NLAY) = wk1(i,NLAY) - (fct+fct)
-      if(wk1(i,NLAY)*AR(i,NLAY)<=0.) AR(i,NLAY) = 0.
-      flux(i,NLAY) = AR(i,NLAY) -  wk1(i,NLAY)
-      END DO
-     
-C
-C****6***0*********0*********0*********0*********0*********0**********72
-C 4th order interpolation in the interior.
-C****6***0*********0*********0*********0*********0*********0**********72
-C
-      DO k=3,NLAYM1
-      DO i=1,IMR
-      c1 =  DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k))
-      c2 =  2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1))
-      A1   =  (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k))
-      A2   =  (wk2(i,k  )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1))
-      AL(i,k) = wk1(i,k-1) + c1 + c2 *
-     &        ( wk2(i,k  )*(c1*(A1 - A2)+A2*flux(i,k-1)) -
-     &          wk2(i,k-1)*A1*flux(i,k)  )
-C      print *,'AL1',i,k, AL(i,k)
-      END DO
-      END DO
-C
-      do i=1,IMR*NLAYM1
-      AR(i,1) = AL(i,2)
-C      print *,'AR1',i,AR(i,1)
-      END DO
-C
-      do i=1,IMR*NLAY
-      A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1)))
-C      print *,'A61',i,A6(i,1)
-      END DO
-C
-C****6***0*********0*********0*********0*********0*********0**********72
-C Top & Bot always monotonic
-      CALL lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0)
-      CALL lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY),
-     &            wk1(1,NLAY),IMR,0)
-C
-C Interior depending on KORD
-      if(LMT<=2)
-     &  CALL lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2),
-     &              IMR*(NLAY-2),LMT)
-C
-C****6***0*********0*********0*********0*********0*********0**********72
-C
-      DO i=1,IMR*NLAYM1
-      IF(wz2(i,1)>0.) then
-        CM = wz2(i,1) / wk2(i,1)
-        flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM))
-      else
-C        print *,'test2-0',i,j,wz2(i,1),wk2(i,2)
-        CP= wz2(i,1) / wk2(i,2)        
-C        print *,'testCP',CP
-        flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP))
-C        print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23
-      endif
-      END DO
-C
-      DO i=1,IMR*NLAYM1
-      flux(i,2) = wz2(i,1) * flux(i,2)
-      END DO
-C
-      do i=1,IMR
-      DQ(i,j,   1) = DQ(i,j,   1) - flux(i,   2)
-      DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY)
-      END DO
-C
-      do k=2,NLAYM1
-      do i=1,IMR
-      DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
-      END DO
-      END DO
-2000  continue
-      END DO
-      return
-      end
-C
-      SUBROUTINE xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC,
-     &               fx1,xmass,IORD)
-      implicit none
-      integer IMR,JNP,IML,j1,j2,JN,JS,IORD
-      real PU,DQ,Q,UC,fx1,xmass
-      real dc,qtmp
-      integer ISAVE(IMR)
-      dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP)
-     &    ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML)
-      dimension PU(IMR,JNP),Q(IMR,JNP)
-      integer jvan,j1vl,j2vl,j,i,iu,itmp,ist,imp
-      real rut
-C
-      IMP = IMR + 1
-C
-C van Leer at high latitudes
-      jvan = max(1,JNP/18)
-      j1vl = j1+jvan
-      j2vl = j2-jvan
-C
-      do j=j1,j2
-C
-      do i=1,IMR
-      qtmp(i) = q(i,j)
-      enddo
-C
-      if(j>=JN .or. j<=JS) goto 2222
-C ************* Eulerian **********
-C
-      qtmp(0)     = q(IMR,J)
-      qtmp(-1)    = q(IMR-1,J)
-      qtmp(IMP)   = q(1,J)
-      qtmp(IMP+1) = q(2,J)
-C
-      IF(IORD==1 .or. j==j1 .or. j==j2) THEN
-      DO i=1,IMR
-      iu = REAL(i) - uc(i,j)
-      fx1(i) = qtmp(iu)
-      END DO
-      ELSE
-      CALL xmist(IMR,IML,Qtmp,DC)
-      DC(0) = DC(IMR)
-C
-      if(IORD==2 .or. j<=j1vl .or. j>=j2vl) then
-      DO i=1,IMR
-      iu = REAL(i) - uc(i,j)
-      fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
-      END DO
-      else
-      CALL fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
-      endif
-C
-      ENDIF
-C
-      DO i=1,IMR
-      fx1(i) = fx1(i)*xmass(i,j)
-      END DO
-C
-      goto 1309
-C
-C ***** Conservative (flux-form) Semi-Lagrangian transport *****
-C
-2222  continue
-C
-      do i=-IML,0
-      qtmp(i)     = q(IMR+i,j)
-      qtmp(IMP-i) = q(1-i,j)
-      enddo
-C
-      IF(IORD==1 .or. j==j1 .or. j==j2) THEN
-      DO i=1,IMR
-      itmp = INT(uc(i,j))
-      ISAVE(i) = i - itmp
-      iu = i - uc(i,j)
-      fx1(i) = (uc(i,j) - itmp)*qtmp(iu)
-      END DO
-      ELSE
-      CALL xmist(IMR,IML,Qtmp,DC)
-C
-      do i=-IML,0
-      DC(i)     = DC(IMR+i)
-      DC(IMP-i) = DC(1-i)
-      enddo
-C
-      DO i=1,IMR
-      itmp = INT(uc(i,j))
-      rut  = uc(i,j) - itmp
-      ISAVE(i) = i - itmp
-      iu = i - uc(i,j)
-      fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut))
-      END DO
-      ENDIF
-C
-      do i=1,IMR
-      IF(uc(i,j)>1.) then
-CDIR$ NOVECTOR
-        do ist = ISAVE(i),i-1
-        fx1(i) = fx1(i) + qtmp(ist)
-        enddo
-      elseIF(uc(i,j)<-1.) then
-        do ist = i,ISAVE(i)-1
-        fx1(i) = fx1(i) - qtmp(ist)
-        enddo
-CDIR$ VECTOR
-      endif
-      END DO
-      do i=1,IMR
-      fx1(i) = PU(i,j)*fx1(i)
-      enddo
-C
-C ***************************************
-C
-1309  fx1(IMP) = fx1(1)
-      DO i=1,IMR
-      DQ(i,j) =  DQ(i,j) + fx1(i)-fx1(i+1)
-      END DO
-C
-C ***************************************
-C
-      END DO
-      return
-      end
-C
-      SUBROUTINE fxppm(IMR,IML,UT,P,DC,flux,IORD)
-      implicit none
-      integer IMR,IML,IORD
-      real UT,P,DC,flux
-      real,parameter ::  R3 = 1./3., R23 = 2./3. 
-      DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
-      REAL :: AR(0:IMR),AL(0:IMR),A6(0:IMR)
-      integer LMT,IMP,JLVL,i
-c      logical first
-c      data first /.TRUE./
-c      SAVE LMT
-c      if(first) then
-C
-C correction calcul de LMT a chaque passage pour pouvoir choisir
-c plusieurs schemas PPM pour differents traceurs
-c      IF (IORD.LE.0) then
-c            if(IMR.GE.144) then
-c                  LMT = 0
-c            elseif(IMR.GE.72) then
-c                  LMT = 1
-c            else
-c                  LMT = 2
-c            endif
-c      else
-c            LMT = IORD - 3
-c      endif
-C
-      LMT = IORD - 3
-c      write(6,*) 'PPM option in E-W direction = ', LMT
-c      first = .FALSE.
-C      endif
-C
-      DO i=1,IMR
-      AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3
-      END DO
-C
-      do i=1,IMR-1
-      AR(i) = AL(i+1)
-      END DO
-      AR(IMR) = AL(1)
-C
-      do i=1,IMR
-      A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
-      END DO
-C
-      if(LMT<=2) CALL lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT)
-C
-      AL(0) = AL(IMR)
-      AR(0) = AR(IMR)
-      A6(0) = A6(IMR)
-C
-      DO i=1,IMR
-      IF(UT(i)>0.) then
-      flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) +
-     &                 A6(i-1)*(1.-R23*UT(i)) )
-      else
-      flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) +
-     &                        A6(i)*(1.+R23*UT(i)))
-      endif
-      enddo
-      return
-      end
-C
-      SUBROUTINE xmist(IMR,IML,P,DC)
-      implicit none
-      integer IMR,IML
-      real,parameter :: R24 = 1./24.
-      real :: P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
-      integer :: i
-      real :: tmp,pmax,pmin
-C
-      do i=1,IMR
-      tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2))
-      Pmax = max(P(i-1), p(i), p(i+1)) - p(i)
-      Pmin = p(i) - min(P(i-1), p(i), p(i+1))
-      DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp)
-      END DO
-      return
-      end
-C
-      SUBROUTINE ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2
-     &              ,ymass,fx,A6,AR,AL,JORD)
-      implicit none
-      integer :: IMR,JNP,j1,j2,JORD
-      real :: acosp,RCAP,DQ,P,VC,DC2,ymass,fx,A6,AR,AL
-      dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP)
-     &       ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP)
-C Work array
-      DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
-      integer :: JMR,len,i,jt,j
-      real :: sum1,sum2
-C
-      JMR = JNP - 1
-      len = IMR*(J2-J1+2)
-C
-      if(JORD==1) then
-      DO i=1,len
-      JT = REAL(J1) - VC(i,J1)
-      fx(i,j1) = p(i,JT)
-      END DO
-      else
-   
-      CALL ymist(IMR,JNP,j1,P,DC2,4)
-C
-      if(JORD<=0 .or. JORD>=3) then
-   
-      CALL fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
-    
-      else
-      DO i=1,len
-      JT = REAL(J1) - VC(i,J1)
-      fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
-      END DO
-      endif
-      endif
-C
-      DO i=1,len
-      fx(i,j1) = fx(i,j1)*ymass(i,j1)
-      END DO
-C
-      DO j=j1,j2
-      DO i=1,IMR
-      DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j)
-      END DO
-      END DO
-C
-C Poles
-      sum1 = fx(IMR,j1  )
-      sum2 = fx(IMR,J2+1)
-      do i=1,IMR-1
-      sum1 = sum1 + fx(i,j1  )
-      sum2 = sum2 + fx(i,J2+1)
-      enddo
-C
-      sum1 = DQ(1,  1) - sum1 * RCAP
-      sum2 = DQ(1,JNP) + sum2 * RCAP
-      do i=1,IMR
-      DQ(i,  1) = sum1
-      DQ(i,JNP) = sum2
-      enddo
-C
-      if(j1/=2) then
-      do i=1,IMR
-      DQ(i,  2) = sum1
-      DQ(i,JMR) = sum2
-      enddo
-      endif
-C
-      return
-      end
-C
-      subroutine  ymist(IMR,JNP,j1,P,DC,ID)
-      implicit none
-      integer :: IMR,JNP,j1,ID
-      real,parameter :: R24 = 1./24.
-      real :: P(IMR,JNP),DC(IMR,JNP)
-      integer :: iimh,jmr,ijm3,imh,i
-      real :: pmax,pmin,tmp
-C
-      IMH = IMR / 2
-      JMR = JNP - 1
-      IJM3 = IMR*(JMR-3)
-C
-      IF(ID==2) THEN
-      do i=1,IMR*(JMR-1)
-      tmp = 0.25*(p(i,3) - p(i,1))
-      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
-      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
-      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
-      END DO
-      ELSE
-      do i=1,IMH
-C J=2
-      tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24
-      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
-      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
-      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
-C J=JMR
-      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24
-      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
-      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
-      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
-      END DO
-      do i=IMH+1,IMR
-C J=2
-      tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24
-      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
-      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
-      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
-C J=JMR
-      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24
-      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
-      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
-      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
-      END DO
-C
-      do i=1,IJM3
-      tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24
-      Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3)
-      Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4))
-      DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp)
-      END DO
-      ENDIF
-C
-      if(j1/=2) then
-      do i=1,IMR
-      DC(i,1) = 0.
-      DC(i,JNP) = 0.
-      enddo
-      else
-C Determine slopes in polar caps for scalars!
-C
-      do i=1,IMH
-C South
-      tmp = 0.25*(p(i,2) - p(i+imh,2))
-      Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1)
-      Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2))
-      DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp)
-C North.
-      tmp = 0.25*(p(i+imh,JMR) - p(i,JMR))
-      Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP)
-      Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR))
-      DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp)
-      END DO
-C
-      do i=imh+1,IMR
-      DC(i,  1) =  - DC(i-imh,  1)
-      DC(i,JNP) =  - DC(i-imh,JNP)
-      END DO
-      endif
-      return
-      end
-C
-      SUBROUTINE fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
-      implicit none
-      integer IMR,JNP,j1,j2,JORD
-      real,parameter :: R3 = 1./3., R23 = 2./3.
-      real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
-C Local work arrays.
-      real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
-      integer LMT,i
-      integer IMH,JMR,j11,IMJM1,len
-c      logical first
-C      data first /.TRUE./
-C      SAVE LMT
-C
-      IMH = IMR / 2
-      JMR = JNP - 1
-      j11 = j1-1
-      IMJM1 = IMR*(J2-J1+2)
-      len   = IMR*(J2-J1+3)
-C      if(first) then
-C      IF(JORD.LE.0) then
-C            if(JMR.GE.90) then
-C                  LMT = 0
-C            elseif(JMR.GE.45) then
-C                  LMT = 1
-C            else
-C                  LMT = 2
-C            endif
-C      else
-C            LMT = JORD - 3
-C      endif
-C
-C      first = .FALSE.
-C      endif
-C     
-c modifs pour pouvoir choisir plusieurs schemas PPM
-      LMT = JORD - 3      
-C
-      DO i=1,IMR*JMR
-      AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3
-      AR(i,1) = AL(i,2)
-      END DO
-C
-CPoles:
-C
-      DO i=1,IMH
-      AL(i,1) = AL(i+IMH,2)
-      AL(i+IMH,1) = AL(i,2)
-C
-      AR(i,JNP) = AR(i+IMH,JMR)
-      AR(i+IMH,JNP) = AR(i,JMR)
-      ENDDO
-
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c   Rajout pour LMDZ.3.3
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-      AR(IMR,1)=AL(1,1)
-      AR(IMR,JNP)=AL(1,JNP)
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-      
-           
-      do i=1,len
-      A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
-      END DO
-C
-      if(LMT<=2) CALL lmtppm(DC(1,j11),A6(1,j11),AR(1,j11)
-     &                       ,AL(1,j11),P(1,j11),len,LMT)
-C
-     
-      DO i=1,IMJM1
-      IF(VC(i,j1)>0.) then
-      flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) +
-     &                         A6(i,j11)*(1.-R23*VC(i,j1)) )
-      else
-      flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) +
-     &                        A6(i,j1)*(1.+R23*VC(i,j1)))
-      endif
-      END DO
-      return
-      end
-C
-	SUBROUTINE yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
-        implicit none
-        integer IMR,JNP,j1,j2,IAD
-	REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
-        REAL WK(IMR,-1:JNP+2)
-        INTEGER JMR,IMH,i,j,jp
-        REAL rv,a1,b1,sum1,sum2
-C
-	JMR = JNP-1
-	IMH = IMR/2
-	do j=1,JNP
-	do i=1,IMR
-	wk(i,j) = p(i,j)
-	enddo
-	enddo
-C Poles:
-	do i=1,IMH
-	wk(i,   -1) = p(i+IMH,3)
-	wk(i+IMH,-1) = p(i,3)
-	wk(i,    0) = p(i+IMH,2)
-	wk(i+IMH,0) = p(i,2)
-	wk(i,JNP+1) = p(i+IMH,JMR)
-	wk(i+IMH,JNP+1) = p(i,JMR)
-	wk(i,JNP+2) = p(i+IMH,JNP-2)
-	wk(i+IMH,JNP+2) = p(i,JNP-2)
-	enddo
-c        write(*,*) 'toto 1' 
-C --------------------------------
-      IF(IAD==2) then
-      do j=j1-1,j2+1
-      do i=1,IMR
-c      write(*,*) 'avt NINT','i=',i,'j=',j
-      JP = NINT(VA(i,j))      
-      rv = JP - VA(i,j)
-c      write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv
-      JP = j - JP
-c      write(*,*) 'JP2=',JP
-      a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp)
-      b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1))
-c      write(*,*) 'a1=',a1,'b1=',b1
-      ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j)
-      enddo
-      enddo
-c      write(*,*) 'toto 2'
-C
-      ELSEIF(IAD==1) then
-	do j=j1-1,j2+1
-      do i=1,imr
-      JP = REAL(j)-VA(i,j)
-      ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
-      enddo
-      enddo
-      ENDIF
-C
-	if(j1/=2) then
-	sum1 = 0.
-	sum2 = 0.
-      do i=1,imr
-      sum1 = sum1 + ady(i,2)
-      sum2 = sum2 + ady(i,JMR)
-      enddo
-	sum1 = sum1 / IMR
-	sum2 = sum2 / IMR
-C
-      do i=1,imr
-      ady(i,  2) =  sum1
-      ady(i,JMR) =  sum2
-      ady(i,  1) =  sum1
-      ady(i,JNP) =  sum2
-      enddo
-	else
-C Poles:
-	sum1 = 0.
-	sum2 = 0.
-      do i=1,imr
-      sum1 = sum1 + ady(i,1)
-      sum2 = sum2 + ady(i,JNP)
-      enddo
-	sum1 = sum1 / IMR
-	sum2 = sum2 / IMR
-C
-      do i=1,imr
-      ady(i,  1) =  sum1
-      ady(i,JNP) =  sum2
-      enddo
-	endif
-C
-	return
-	end
-C
-	SUBROUTINE xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD)
-        implicit none
-        INTEGER IMR,JNP,j1,j2,JS,JN,IML,IAD
-	REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
-        INTEGER JMR,j,i,ip,iu,iiu
-        REAL ru,a1,b1
-C
-	JMR = JNP-1
-      do j=j1,j2
-      if(J>JS  .and. J<JN) GO TO 1309
-C
-      do i=1,IMR
-      qtmp(i) = p(i,j)
-      enddo
-C
-      do i=-IML,0
-      qtmp(i)       = p(IMR+i,j)
-      qtmp(IMR+1-i) = p(1-i,j)
-      enddo
-C
-      IF(IAD==2) THEN
-      DO i=1,IMR
-      IP = NINT(UA(i,j))
-      ru = IP - UA(i,j)
-      IP = i - IP
-      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
-      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
-      adx(i,j) = qtmp(ip) + ru*(a1*ru + b1)
-      enddo
-      ELSEIF(IAD==1) then
-      DO i=1,IMR
-      iu = UA(i,j)
-      ru = UA(i,j) - iu
-      iiu = i-iu
-      if(UA(i,j)>=0.) then
-      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
-      else
-      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
-      endif
-      enddo
-      ENDIF
-C
-      do i=1,IMR
-      adx(i,j) = adx(i,j) - p(i,j)
-      enddo
-1309  continue
-      END DO
-C
-C Eulerian upwind
-C
-      do j=JS+1,JN-1
-C
-      do i=1,IMR
-      qtmp(i) = p(i,j)
-      enddo
-C
-      qtmp(0)     = p(IMR,J)
-      qtmp(IMR+1) = p(1,J)
-C
-      IF(IAD==2) THEN
-      qtmp(-1)     = p(IMR-1,J)
-      qtmp(IMR+2) = p(2,J)
-      do i=1,imr
-      IP = NINT(UA(i,j))
-      ru = IP - UA(i,j)
-      IP = i - IP
-      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
-      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
-      adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1)
-      enddo
-      ELSEIF(IAD==1) then
-C 1st order
-      DO i=1,IMR
-      IP = i - UA(i,j)
-      adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1))
-      enddo
-      ENDIF
-      enddo
-C
-	if(j1/=2) then
-      do i=1,IMR
-      adx(i,  2) = 0.
-      adx(i,JMR) = 0.
-      enddo
-	endif
-C set cross term due to x-adv at the poles to zero.
-      do i=1,IMR
-      adx(i,  1) = 0.
-      adx(i,JNP) = 0.
-      enddo
-	return
-	end
-C
-      SUBROUTINE lmtppm(DC,A6,AR,AL,P,IM,LMT)
-      implicit none
-C
-C A6 =  CURVATURE OF THE TEST PARABOLA
-C AR =  RIGHT EDGE VALUE OF THE TEST PARABOLA
-C AL =  LEFT  EDGE VALUE OF THE TEST PARABOLA
-C DC =  0.5 * MISMATCH
-C P  =  CELL-AVERAGED VALUE
-C IM =  VECTOR LENGTH
-C
-C OPTIONS:
-C
-C LMT = 0: FULL MONOTONICITY
-C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS)
-C LMT = 2: POSITIVE-DEFINITE CONSTRAINT
-C
-      real,parameter :: R12 = 1./12. 
-      real :: A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
-      integer :: IM,LMT
-      INTEGER i
-      REAL da1,da2,a6da,fmin
-C
-      if(LMT==0) then
-C Full constraint
-      do i=1,IM
-      if(DC(i)==0.) then
-            AR(i) = p(i)
-            AL(i) = p(i)
-            A6(i) = 0.
-      else
-      da1  = AR(i) - AL(i)
-      da2  = da1**2
-      A6DA = A6(i)*da1
-      if(A6DA < -da2) then
-            A6(i) = 3.*(AL(i)-p(i))
-            AR(i) = AL(i) - A6(i)
-      elseif(A6DA > da2) then
-            A6(i) = 3.*(AR(i)-p(i))
-            AL(i) = AR(i) - A6(i)
-      endif
-      endif
-      END DO
-      elseif(LMT==1) then
-C Semi-monotonic constraint
-      do i=1,IM
-      if(abs(AR(i)-AL(i)) >= -A6(i)) go to 150
-      if(p(i)<AR(i) .and. p(i)<AL(i)) then
-            AR(i) = p(i)
-            AL(i) = p(i)
-            A6(i) = 0.
-      elseif(AR(i) > AL(i)) then
-            A6(i) = 3.*(AL(i)-p(i))
-            AR(i) = AL(i) - A6(i)
-      else
-            A6(i) = 3.*(AR(i)-p(i))
-            AL(i) = AR(i) - A6(i)
-      endif
-150   continue
-      END DO
-      elseif(LMT==2) then
-      do i=1,IM
-      if(abs(AR(i)-AL(i)) >= -A6(i)) go to 250
-      fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
-      if(fmin>=0.) go to 250
-      if(p(i)<AR(i) .and. p(i)<AL(i)) then
-            AR(i) = p(i)
-            AL(i) = p(i)
-            A6(i) = 0.
-      elseif(AR(i) > AL(i)) then
-            A6(i) = 3.*(AL(i)-p(i))
-            AR(i) = AL(i) - A6(i)
-      else
-            A6(i) = 3.*(AR(i)-p(i))
-            AL(i) = AR(i) - A6(i)
-      endif
-250   continue
-      END DO
-      endif
-      return
-      end
-C
-      SUBROUTINE A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
-      implicit none
-      integer IMR,JMR,j1,j2
-      real :: U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*),DTDY5
-      integer i,j
-C
-      do j=j1,j2
-      do i=2,IMR
-      CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
-      END DO
-      END DO
-C
-      do j=j1,j2
-      CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
-      END DO
-C
-      do i=1,IMR*JMR
-      CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
-      END DO
-      return
-      end
-C
-      SUBROUTINE cosa(cosp,cose,JNP,PI,DP)
-      implicit none
-      integer JNP
-      real :: cosp(*),cose(*),PI,DP
-      integer JMR,j,jeq
-      real ph5
-      JMR = JNP-1
-      do j=2,JNP
-        ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
-        cose(j) = cos(ph5)
-      END DO
-C
-      JEQ = (JNP+1) / 2
-      if(JMR == 2*(JMR/2) ) then
-      do j=JNP, JEQ+1, -1
-       cose(j) =  cose(JNP+2-j)
-      enddo
-      else
-C cell edge at equator.
-       cose(JEQ+1) =  1.
-      do j=JNP, JEQ+2, -1
-       cose(j) =  cose(JNP+2-j)
-       enddo
-      endif
-C
-      do j=2,JMR
-      cosp(j) = 0.5*(cose(j)+cose(j+1))
-      END DO
-      cosp(1) = 0.
-      cosp(JNP) = 0.
-      return
-      end
-C
-      SUBROUTINE cosc(cosp,cose,JNP,PI,DP)
-      implicit none
-      integer JNP
-      real :: cosp(*),cose(*),PI,DP
-      real phi
-      integer j
-C
-      phi = -0.5*PI
-      do j=2,JNP-1
-      phi  =  phi + DP
-      cosp(j) = cos(phi)
-      END DO
-        cosp(  1) = 0.
-        cosp(JNP) = 0.
-C
-      do j=2,JNP
-        cose(j) = 0.5*(cosp(j)+cosp(j-1))
-      END DO
-C
-      do j=2,JNP-1
-       cosp(j) = 0.5*(cose(j)+cose(j+1))
-      END DO
-      return
-      end
-C
-      SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp,
-     &                   cross,IC,NSTEP)
-C
-      real,parameter :: tiny = 1.E-60 
-      INTEGER :: IMR,JNP,NLAY,j1,j2,IC,NSTEP
-      REAL :: Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
-      logical cross
-      INTEGER :: NLAYM1,len,ip,L,icr,ipy,ipx,i
-      real :: qup,qly,dup,sum
-C
-      NLAYM1 = NLAY-1
-      len = IMR*(j2-j1+1)
-      ip = 0
-C
-C Top layer
-      L = 1
-	icr = 1
-      CALL filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
-      if(ipy==0) goto 50
-      CALL filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
-      if(ipx==0) goto 50
-C
-      if(cross) then
-      CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-      endif
-      if(icr==0) goto 50
-C
-C Vertical filling...
-      do i=1,len
-      IF( Q(i,j1,1)<0.) THEN
-      ip = ip + 1
-          Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1)
-          Q(i,j1,1) = 0.
-      endif
-      enddo
-C
-50    continue
-      DO L = 2,NLAYM1
-      icr = 1
-C
-      CALL filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
-      if(ipy==0) goto 225
-      CALL filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
-      if(ipx==0) go to 225
-      if(cross) then
-      CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-      endif
-      if(icr==0) goto 225
-C
-      do i=1,len
-      IF( Q(I,j1,L)<0.) THEN
-C
-      ip = ip + 1
-C From above
-          qup =  Q(I,j1,L-1)
-          qly = -Q(I,j1,L)
-          dup  = min(qly,qup)
-          Q(I,j1,L-1) = qup - dup
-          Q(I,j1,L  ) = dup-qly
-C Below
-          Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L)
-          Q(I,j1,L)   = 0.
-      ENDIF
-      ENDDO
-225   CONTINUE
-      END DO
-C
-C BOTTOM LAYER
-      sum = 0.
-      L = NLAY
-C
-      CALL filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
-      if(ipy==0) goto 911
-      CALL filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
-      if(ipx==0) goto 911
-C
-      CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-      if(icr==0) goto 911
-C
-      DO  I=1,len
-      IF( Q(I,j1,L)<0.) THEN
-      ip = ip + 1
-c
-C From above
-C
-          qup = Q(I,j1,NLAYM1)
-          qly = -Q(I,j1,L)
-          dup = min(qly,qup)
-          Q(I,j1,NLAYM1) = qup - dup
-C From "below" the surface.
-          sum = sum + qly-dup
-          Q(I,j1,L) = 0.
-       ENDIF
-      ENDDO
-C
-911   continue
-C
-      if(ip>IMR) then
-      write(6,*) 'IC=',IC,' STEP=',NSTEP,
-     &           ' Vertical filling pts=',ip
-      endif
-C
-      if(sum>1.e-25) then
-      write(6,*) IC,NSTEP,' Mass source from the ground=',sum
-      endif
-      RETURN
-      END
-C
-      SUBROUTINE filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-      implicit none
-      integer :: IMR,JNP,j1,j2,icr
-      real :: q(IMR,*),cosp(*),acosp(*),tiny
-      integer :: i,j
-      real :: dq,dn,d0,d1,ds,d2
-      icr = 0
-      do j=j1+1,j2-1
-      DO i=1,IMR-1
-      IF(q(i,j)<0.) THEN
-      icr =  1
-      dq  = - q(i,j)*cosp(j)
-C N-E
-      dn = q(i+1,j+1)*cosp(j+1)
-      d0 = max(0.,dn)
-      d1 = min(dq,d0)
-      q(i+1,j+1) = (dn - d1)*acosp(j+1)
-      dq = dq - d1
-C S-E
-      ds = q(i+1,j-1)*cosp(j-1)
-      d0 = max(0.,ds)
-      d2 = min(dq,d0)
-      q(i+1,j-1) = (ds - d2)*acosp(j-1)
-      q(i,j) = (d2 - dq)*acosp(j) + tiny
-      endif
-      END DO
-      if(icr==0 .and. q(IMR,j)>=0.) goto 65
-      DO i=2,IMR
-      IF(q(i,j)<0.) THEN
-      icr =  1
-      dq  = - q(i,j)*cosp(j)
-C N-W
-      dn = q(i-1,j+1)*cosp(j+1)
-      d0 = max(0.,dn)
-      d1 = min(dq,d0)
-      q(i-1,j+1) = (dn - d1)*acosp(j+1)
-      dq = dq - d1
-C S-W
-      ds = q(i-1,j-1)*cosp(j-1)
-      d0 = max(0.,ds)
-      d2 = min(dq,d0)
-      q(i-1,j-1) = (ds - d2)*acosp(j-1)
-      q(i,j) = (d2 - dq)*acosp(j) + tiny
-      endif
-      END DO
-C *****************************************
-C i=1
-      i=1
-      IF(q(i,j)<0.) THEN
-      icr =  1
-      dq  = - q(i,j)*cosp(j)
-C N-W
-      dn = q(IMR,j+1)*cosp(j+1)
-      d0 = max(0.,dn)
-      d1 = min(dq,d0)
-      q(IMR,j+1) = (dn - d1)*acosp(j+1)
-      dq = dq - d1
-C S-W
-      ds = q(IMR,j-1)*cosp(j-1)
-      d0 = max(0.,ds)
-      d2 = min(dq,d0)
-      q(IMR,j-1) = (ds - d2)*acosp(j-1)
-      q(i,j) = (d2 - dq)*acosp(j) + tiny
-      endif
-C *****************************************
-C i=IMR
-      i=IMR
-      IF(q(i,j)<0.) THEN
-      icr =  1
-      dq  = - q(i,j)*cosp(j)
-C N-E
-      dn = q(1,j+1)*cosp(j+1)
-      d0 = max(0.,dn)
-      d1 = min(dq,d0)
-      q(1,j+1) = (dn - d1)*acosp(j+1)
-      dq = dq - d1
-C S-E
-      ds = q(1,j-1)*cosp(j-1)
-      d0 = max(0.,ds)
-      d2 = min(dq,d0)
-      q(1,j-1) = (ds - d2)*acosp(j-1)
-      q(i,j) = (d2 - dq)*acosp(j) + tiny
-      endif
-C *****************************************
-65    continue
-      END DO
-C
-      do i=1,IMR
-      if(q(i,j1)<0. .or. q(i,j2)<0.) then
-      icr = 1
-      goto 80
-      endif
-      enddo
-C
-80    continue
-C
-      if(q(1,1)<0. .or. q(1,jnp)<0.) then
-      icr = 1
-      endif
-C
-      return
-      end
-C
-      SUBROUTINE filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
-      implicit none
-      integer :: IMR,JNP,j1,j2,ipy
-      real :: q(IMR,*),cosp(*),acosp(*),tiny
-      real :: DP,CAP1,dq,dn,d0,d1,ds,d2
-      INTEGER :: i,j
-c      logical first
-c      data first /.TRUE./
-c      save cap1
-C
-c      if(first) then
-      DP = 4.*ATAN(1.)/REAL(JNP-1)
-      CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
-c      first = .FALSE.
-c      endif
-C
-      ipy = 0
-      do j=j1+1,j2-1
-      DO i=1,IMR
-      IF(q(i,j)<0.) THEN
-      ipy =  1
-      dq  = - q(i,j)*cosp(j)
-C North
-      dn = q(i,j+1)*cosp(j+1)
-      d0 = max(0.,dn)
-      d1 = min(dq,d0)
-      q(i,j+1) = (dn - d1)*acosp(j+1)
-      dq = dq - d1
-C South
-      ds = q(i,j-1)*cosp(j-1)
-      d0 = max(0.,ds)
-      d2 = min(dq,d0)
-      q(i,j-1) = (ds - d2)*acosp(j-1)
-      q(i,j) = (d2 - dq)*acosp(j) + tiny
-      endif
-      END DO
-      END DO
-C
-      do i=1,imr
-      IF(q(i,j1)<0.) THEN
-      ipy =  1
-      dq  = - q(i,j1)*cosp(j1)
-C North
-      dn = q(i,j1+1)*cosp(j1+1)
-      d0 = max(0.,dn)
-      d1 = min(dq,d0)
-      q(i,j1+1) = (dn - d1)*acosp(j1+1)
-      q(i,j1) = (d1 - dq)*acosp(j1) + tiny
-      endif
-      enddo
-C
-      j = j2
-      do i=1,imr
-      IF(q(i,j)<0.) THEN
-      ipy =  1
-      dq  = - q(i,j)*cosp(j)
-C South
-      ds = q(i,j-1)*cosp(j-1)
-      d0 = max(0.,ds)
-      d2 = min(dq,d0)
-      q(i,j-1) = (ds - d2)*acosp(j-1)
-      q(i,j) = (d2 - dq)*acosp(j) + tiny
-      endif
-      enddo
-C
-C Check Poles.
-      if(q(1,1)<0.) then
-      dq = q(1,1)*cap1/REAL(IMR)*acosp(j1)
-      do i=1,imr
-      q(i,1) = 0.
-      q(i,j1) = q(i,j1) + dq
-      if(q(i,j1)<0.) ipy = 1
-      enddo
-      endif
-C
-      if(q(1,JNP)<0.) then
-      dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2)
-      do i=1,imr
-      q(i,JNP) = 0.
-      q(i,j2) = q(i,j2) + dq
-      if(q(i,j2)<0.) ipy = 1
-      enddo
-      endif
-C
-      return
-      end
-C
-      SUBROUTINE filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
-      implicit none
-      integer :: IMR,JNP,j1,j2,ipx
-      real :: q(IMR,*),qtmp(JNP,IMR),tiny
-      integer :: i,j
-      real :: d0,d1,d2
-C
-      ipx = 0
-C Copy & swap direction for vectorization.
-      do i=1,imr
-      do j=j1,j2
-      qtmp(j,i) = q(i,j)
-      END DO
-      END DO
-C
-      do i=2,imr-1
-      do j=j1,j2
-      if(qtmp(j,i)<0.) then
-      ipx =  1
-c west
-      d0 = max(0.,qtmp(j,i-1))
-      d1 = min(-qtmp(j,i),d0)
-      qtmp(j,i-1) = qtmp(j,i-1) - d1
-      qtmp(j,i) = qtmp(j,i) + d1
-c east
-      d0 = max(0.,qtmp(j,i+1))
-      d2 = min(-qtmp(j,i),d0)
-      qtmp(j,i+1) = qtmp(j,i+1) - d2
-      qtmp(j,i) = qtmp(j,i) + d2 + tiny
-      endif
-      END DO
-      END DO
-c
-      i=1
-      do j=j1,j2
-      if(qtmp(j,i)<0.) then
-      ipx =  1
-c west
-      d0 = max(0.,qtmp(j,imr))
-      d1 = min(-qtmp(j,i),d0)
-      qtmp(j,imr) = qtmp(j,imr) - d1
-      qtmp(j,i) = qtmp(j,i) + d1
-c east
-      d0 = max(0.,qtmp(j,i+1))
-      d2 = min(-qtmp(j,i),d0)
-      qtmp(j,i+1) = qtmp(j,i+1) - d2
-c
-      qtmp(j,i) = qtmp(j,i) + d2 + tiny
-      endif
-      END DO
-      i=IMR
-      do j=j1,j2
-      if(qtmp(j,i)<0.) then
-      ipx =  1
-c west
-      d0 = max(0.,qtmp(j,i-1))
-      d1 = min(-qtmp(j,i),d0)
-      qtmp(j,i-1) = qtmp(j,i-1) - d1
-      qtmp(j,i) = qtmp(j,i) + d1
-c east
-      d0 = max(0.,qtmp(j,1))
-      d2 = min(-qtmp(j,i),d0)
-      qtmp(j,1) = qtmp(j,1) - d2
-c
-      qtmp(j,i) = qtmp(j,i) + d2 + tiny
-      endif
-      END DO
-C
-      if(ipx/=0) then
-      do j=j1,j2
-      do i=1,imr
-      q(i,j) = qtmp(j,i)
-      END DO
-      END DO
-      else
-C
-C Poles.
-      if(q(1,1)<0 .or. q(1,JNP)<0.) ipx = 1
-      endif
-      return
-      end
-C
-      SUBROUTINE zflip(q,im,km,nc)
-      implicit none
-C This routine flip the array q (in the vertical).
-      integer :: im,km,nc
-      real q(im,km,nc)
-C local dynamic array
-      real qtmp(im,km)
-      integer IC,k,i
-C
-      do IC = 1, nc
-C
-      do k=1,km
-      do i=1,im
-      qtmp(i,k) = q(i,km+1-k,IC)
-      END DO
-      END DO
-C
-      do i=1,im*km
-      q(i,1,IC) = qtmp(i,1)
-      END DO
-      END DO
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90	(revision 5105)
@@ -0,0 +1,2148 @@
+
+! $Id$
+
+!From lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998
+!Date: Wed, 15 Apr 1998 11:37:03 -0400
+!From: lin@explorer.gsfc.nasa.gov
+!To: Frederic.Hourdin@lmd.jussieu.fr
+!Subject: 3D transport module of the GSFC CTM and GEOS GCM
+
+
+!This code is sent to you by S-J Lin, DAO, NASA-GSFC
+
+!Note: this version is intended for machines like CRAY
+!-90. No multitasking directives implemented.
+
+
+! ********************************************************************
+!
+! TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard
+! Earth Observing System General Circulation Model (GEOS-GCM), and Data
+! Assimilation System (GEOS-DAS).
+!
+! ********************************************************************
+!
+! Purpose: given horizontal winds on  a hybrid sigma-p surfaces,
+!      one CALL to tpcore updates the 3-D mixing ratio
+!      fields one time step (NDT). [vertical mass flux is computed
+!      internally consistent with the discretized hydrostatic mass
+!      continuity equation of the C-Grid GEOS-GCM (for IGD=1)].
+!
+! Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based
+!      on the van Leer or PPM.
+!      (see Lin and Rood 1996).
+! Version 4.5
+! Last modified: Dec. 5, 1996
+! Major changes from version 4.0: a more general vertical hybrid sigma-
+! pressure coordinate.
+! Subroutines modified: xtp, ytp, fzppm, qckxyz
+! Subroutines deleted: vanz
+!
+! Author: Shian-Jiann Lin
+! mail address:
+!             Shian-Jiann Lin*
+!             Code 910.3, NASA/GSFC, Greenbelt, MD 20771
+!             Phone: 301-286-9540
+!             E-mail: lin@dao.gsfc.nasa.gov
+!
+! *affiliation:
+!             Joint Center for Earth Systems Technology
+!             The University of Maryland Baltimore County
+!             NASA - Goddard Space Flight Center
+! References:
+!
+! 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi-
+!    Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070.
+!
+! 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of
+!    the van Leer-type transport schemes and its applications to the moist-
+!    ure transport in a General Circulation Model. Mon. Wea. Rev., 122,
+!    1575-1593.
+!
+! ****6***0*********0*********0*********0*********0*********0**********72
+!
+SUBROUTINE ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR, &
+        JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax)
+
+  implicit none
+
+  ! rajout de déclarations
+  !  integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd
+  !  integer iu,iiu,j2,jmr,js0,jt
+  !  real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp
+  !  real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru
+  !
+  ! ********************************************************************
+  !
+  ! =============
+  ! INPUT:
+  ! =============
+  !
+  ! Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t)
+  ! NC: total # of constituents
+  ! IMR: first dimension (E-W); # of Grid intervals in E-W is IMR
+  ! JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1
+  ! NLAY: 3rd dimension (# of layers); vertical index increases from 1 at
+  !   the model top to NLAY near the surface (see fig. below).
+  !   It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation)
+  !
+  ! PS1(IMR,JNP): surface pressure at current time (t)
+  ! PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2)
+  ! PS2 is replaced by the predicted PS (at t+NDT) on output.
+  ! Note: surface pressure can have any unit or can be multiplied by any
+  !   const.
+  !
+  ! The pressure at layer edges are defined as follows:
+  !
+  !    p(i,j,k) = AP(k)*PT  +  BP(k)*PS(i,j)          (1)
+  !
+  ! Where PT is a constant having the same unit as PS.
+  ! AP and BP are unitless constants given at layer edges
+  ! defining the vertical coordinate.
+  ! BP(1) = 0., BP(NLAY+1) = 1.
+  ! The pressure at the model top is PTOP = AP(1)*PT
+  !
+  ! For pure sigma system set AP(k) = 1 for all k, PT = PTOP,
+  ! BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP.
+  !
+  ! Note: the sigma-P coordinate is a subset of Eq. 1, which in turn
+  ! is a subset of the following even more general sigma-P-thelta coord.
+  ! currently under development.
+  !  p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa))
+  !
+  !              /////////////////////////////////
+  !          / \ ------------- PTOP --------------  AP(1), BP(1)
+  !           |
+  !    delp(1)    |  ........... Q(i,j,1) ............
+  !           |
+  !  W(1)    \ / ---------------------------------  AP(2), BP(2)
+  !
+  !
+  !
+  ! W(k-1)   / \ ---------------------------------  AP(k), BP(k)
+  !           |
+  !    delp(K)    |  ........... Q(i,j,k) ............
+  !           |
+  !  W(k)    \ / ---------------------------------  AP(k+1), BP(k+1)
+  !
+  !
+  !
+  !          / \ ---------------------------------  AP(NLAY), BP(NLAY)
+  !           |
+  !  delp(NLAY)   |  ........... Q(i,j,NLAY) .........
+  !           |
+  !   W(NLAY)=0  \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1)
+  !             //////////////////////////////////
+  !
+  ! U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2)
+  ! U and V may need to be polar filtered in advance in some cases.
+  !
+  ! IGD:      grid type on which winds are defined.
+  ! IGD = 0:  A-Grid  [all variables defined at the same point from south
+  !               pole (j=1) to north pole (j=JNP) ]
+  !
+  ! IGD = 1  GEOS-GCM C-Grid
+  !                                  [North]
+  !
+  !                                   V(i,j)
+  !                                      |
+  !                                      |
+  !                                      |
+  !                         U(i-1,j)---Q(i,j)---U(i,j) [EAST]
+  !                                      |
+  !                                      |
+  !                                      |
+  !                                   V(i,j-1)
+  !
+  !     U(i,  1) is defined at South Pole.
+  !     V(i,  1) is half grid north of the South Pole.
+  !     V(i,JMR) is half grid south of the North Pole.
+  !
+  !     V must be defined at j=1 and j=JMR if IGD=1
+  !     V at JNP need not be given.
+  !
+  ! NDT: time step in seconds (need not be constant during the course of
+  !  the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5
+  !  (Lat-Lon) resolution. Smaller values are recommanded if the model
+  !  has a well-resolved stratosphere.
+  !
+  ! J1 defines the size of the polar cap:
+  ! South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg.
+  ! North polar cap edge is located at  90 - (j1-1.5)*180/(JNP-1) deg.
+  ! There are currently only two choices (j1=2 or 3).
+  ! IMR must be an even integer if j1 = 2. Recommended value: J1=3.
+  !
+  ! IORD, JORD, and KORD are integers controlling various options in E-W, N-S,
+  ! and vertical transport, respectively. Recommended values for positive
+  ! definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non-
+  ! positive definite scalars or when linear correlation between constituents
+  ! is to be maintained.
+  !
+  !  _ORD=
+  !    1: 1st order upstream scheme (too diffusive, not a useful option; it
+  !       can be used for debugging purposes; this is THE only known "linear"
+  !       monotonic advection scheme.).
+  !    2: 2nd order van Leer (full monotonicity constraint;
+  !       see Lin et al 1994, MWR)
+  !    3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984)
+  !    4: semi-monotonic PPM (same as 3, but overshoots are allowed)
+  !    5: positive-definite PPM (constraint on the subgrid distribution is
+  !       only strong enough to prevent generation of negative values;
+  !       both overshoots & undershoots are possible).
+  !    6: un-constrained PPM (nearly diffusion free; slightly faster but
+  !       positivity not quaranteed. Use this option only when the fields
+  !       and winds are very smooth).
+  !
+  ! *PPM: Piece-wise Parabolic Method
+  !
+  ! Note that KORD <=2 options are no longer supported. DO not use option 4 or 5.
+  ! for non-positive definite scalars (such as Ertel Potential Vorticity).
+  !
+  ! The implicit numerical diffusion decreases as _ORD increases.
+  ! The last two options (ORDER=5, 6) should only be used when there is
+  ! significant explicit diffusion (such as a turbulence parameterization). You
+  ! might get dispersive results otherwise.
+  ! No filter of any kind is applied to the constituent fields here.
+  !
+  ! AE: Radius of the sphere (meters).
+  ! Recommended value for the planet earth: 6.371E6
+  !
+  ! fill(logical):   flag to do filling for negatives (see note below).
+  !
+  ! Umax: Estimate (upper limit) of the maximum U-wind speed (m/s).
+  ! (220 m/s is a good value for troposphere model; 280 m/s otherwise)
+  !
+  ! =============
+  ! Output
+  ! =============
+  !
+  ! Q: mixing ratios at future time (t+NDT) (original values are over-written)
+  ! W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic
+  !      relationship. W will have the same unit as PS1 and PS2 (eg, mb).
+  !      W must be divided by NDT to get the correct mass-flux unit.
+  !      The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND
+  !      is the pressure thickness in the "upwind" direction. For example,
+  !      C(k) = W(k)/delp(k)   if W(k) > 0;
+  !      C(k) = W(k)/delp(k+1) if W(k) < 0.
+  !          ( W > 0 is downward, ie, toward surface)
+  ! PS2: predicted PS at t+NDT (original values are over-written)
+  !
+  ! ********************************************************************
+  ! NOTES:
+  ! This forward-in-time upstream-biased transport scheme reduces to
+  ! the 2nd order center-in-time center-in-space mass continuity eqn.
+  ! if Q = 1 (constant fields will remain constant). This also ensures
+  ! that the computed vertical velocity to be identical to GEOS-1 GCM
+  ! for on-line transport.
+  !
+  ! A larger polar cap is used if j1=3 (recommended for C-Grid winds or when
+  ! winds are noisy near poles).
+  !
+  ! Flux-Form Semi-Lagrangian transport in the East-West direction is used
+  ! when and where Courant # is greater than one.
+  !
+  ! The user needs to change the parameter Jmax or Kmax if the resolution
+  ! is greater than 0.5 deg in N-S or 150 layers in the vertical direction.
+  ! (this TransPort Core is otherwise resolution independent and can be used
+  ! as a library routine).
+  !
+  ! PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd
+  ! order accurate for non-uniform grid (vertical sigma coord.).
+  !
+  ! Time step is limitted only by transport in the meridional direction.
+  ! (the FFSL scheme is not implemented in the meridional direction).
+  !
+  ! Since only 1-D limiters are applied, negative values could
+  ! potentially be generated when large time step is used and when the
+  ! initial fields contain discontinuities.
+  ! This does not necessarily imply the integration is unstable.
+  ! These negatives are typically very small. A filling algorithm is
+  ! activated if the user set "fill" to be true.
+  !
+  ! The van Leer scheme used here is nearly as accurate as the original PPM
+  ! due to the use of a 4th order accurate reference slope. The PPM imple-
+  ! mented here is an improvement over the original and is also based on
+  ! the 4th order reference slope.
+  !
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  !
+  ! User modifiable parameters
+  !
+  integer,parameter :: Jmax = 361, kmax = 150
+  !
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  !
+  ! Input-Output arrays
+  !
+
+  real :: Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP), &
+        U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1), &
+        BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax
+  integer :: IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE
+  integer :: IMRD2
+  real :: PT
+  logical :: cross, fill, dum
+  !
+  ! Local dynamic arrays
+  !
+  real :: CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP), &
+        fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY), &
+        WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP), &
+        delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP), &
+        UA(IMR,JNP),qtmp(-IMR:2*IMR)
+  !
+  ! Local static  arrays
+  !
+  real :: DTDX(Jmax), DTDX5(Jmax), acosp(Jmax), &
+        cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax)
+  data NDT0, NSTEP /0, 0/
+  data cross /.TRUE./
+  REAL :: DTDY, DTDY5, RCAP
+  INTEGER :: JS0, JN0, IML, JMR, IMJM
+  SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, &
+        DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
+  !
+  INTEGER :: NDT0, NSTEP, j2, k,j,i,ic,l,JS,JN,IMH
+  INTEGER :: IU,IIU,JT,iad,jad,krd
+  REAL :: r23,r3,PI,DL,DP,DT,CR1,MAXDT,ZTC,D5
+  REAL :: sum1,sum2,ru
+
+  JMR = JNP -1
+  IMJM  = IMR*JNP
+  j2 = JNP - j1 + 1
+  NSTEP = NSTEP + 1
+  !
+  ! *********** Initialization **********************
+  if(NSTEP==1) then
+  !
+  write(6,*) '------------------------------------ '
+  write(6,*) 'NASA/GSFC Transport Core Version 4.5'
+  write(6,*) '------------------------------------ '
+  !
+  WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1
+  WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT
+  !
+  ! controles sur les parametres
+  if(NLAY<6) then
+    write(6,*) 'NLAY must be >= 6'
+    stop
+  endif
+  if (JNP<NLAY) then
+     write(6,*) 'JNP must be >= NLAY'
+    stop
+  endif
+  IMRD2=mod(IMR,2)
+  if (j1==2.and.IMRD2/=0) then
+     write(6,*) 'if j1=2 IMR must be an even integer'
+    stop
+  endif
+
+  !
+  if(Jmax<JNP .or. Kmax<NLAY) then
+    write(6,*) 'Jmax or Kmax is too small'
+    stop
+  endif
+  !
+  DO k=1,NLAY
+  DAP(k) = (AP(k+1) - AP(k))*PT
+  DBK(k) =  BP(k+1) - BP(k)
+  ENDDO
+  !
+  PI = 4. * ATAN(1.)
+  DL = 2.*PI / REAL(IMR)
+  DP =    PI / REAL(JMR)
+  !
+  if(IGD==0) then
+  ! Compute analytic cosine at cell edges
+        CALL cosa(cosp,cose,JNP,PI,DP)
+  else
+  ! Define cosine consistent with GEOS-GCM (using dycore2.0 or later)
+        CALL cosc(cosp,cose,JNP,PI,DP)
+  endif
+  !
+  do J=2,JMR
+  acosp(j) = 1. / cosp(j)
+  END DO
+  !
+  ! Inverse of the Scaled polar cap area.
+  !
+  RCAP  = DP / (IMR*(1.-COS((j1-1.5)*DP)))
+  acosp(1)   = RCAP
+  acosp(JNP) = RCAP
+  endif
+  !
+  if(NDT0 /= NDT) then
+  DT   = NDT
+  NDT0 = NDT
+
+    if(Umax < 180.) then
+     write(6,*) 'Umax may be too small!'
+    endif
+  CR1  = abs(Umax*DT)/(DL*AE)
+  MaxDT = DP*AE / abs(Umax) + 0.5
+  write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT
+  if(MaxDT < abs(NDT)) then
+        write(6,*) 'Warning!!! NDT maybe too large!'
+  endif
+  !
+  if(CR1>=0.95) then
+  JS0 = 0
+  JN0 = 0
+  IML = IMR-2
+  ZTC = 0.
+  else
+  ZTC  = acos(CR1) * (180./PI)
+  !
+  JS0 = REAL(JMR)*(90.-ZTC)/180. + 2
+  JS0 = max(JS0, J1+1)
+  IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
+  JN0 = JNP-JS0+1
+  endif
+  !
+  !
+  do J=2,JMR
+  DTDX(j)  = DT / ( DL*AE*COSP(J) )
+
+  ! PRINT*,'dtdx=',dtdx(j)
+  DTDX5(j) = 0.5*DTDX(j)
+  enddo
+  !
+
+  DTDY  = DT /(AE*DP)
+   ! PRINT*,'dtdy=',dtdy
+  DTDY5 = 0.5*DTDY
+  !
+  !  write(6,*) 'J1=',J1,' J2=', J2
+  endif
+  !
+  ! *********** End Initialization **********************
+  !
+  ! delp = pressure thickness: the psudo-density in a hydrostatic system.
+  do  k=1,NLAY
+     do  j=1,JNP
+        do  i=1,IMR
+           delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j)
+           delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j)
+        enddo
+     enddo
+  enddo
+
+  !
+  if(j1/=2) then
+  DO IC=1,NC
+  DO L=1,NLAY
+  DO I=1,IMR
+  Q(I,  2,L,IC) = Q(I,  1,L,IC)
+  Q(I,JMR,L,IC) = Q(I,JNP,L,IC)
+  END DO
+  END DO
+  END DO
+  endif
+  !
+  ! Compute "tracer density"
+  DO IC=1,NC
+  DO k=1,NLAY
+  DO j=1,JNP
+  DO i=1,IMR
+  DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k)
+  END DO
+  END DO
+  END DO
+  END DO
+  !
+  do k=1,NLAY
+  !
+  if(IGD==0) then
+  ! Convert winds on A-Grid to Courant # on C-Grid.
+  CALL A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+  else
+  ! Convert winds on C-grid to Courant #
+  do j=j1,j2
+  do i=2,IMR
+  CRX(i,J) = dtdx(j)*U(i-1,j,k)
+  END DO
+  END DO
+
+  !
+  do j=j1,j2
+  CRX(1,J) = dtdx(j)*U(IMR,j,k)
+  END DO
+  !
+  do i=1,IMR*JMR
+  CRY(i,2) = DTDY*V(i,1,k)
+  END DO
+  endif
+  !
+  ! Determine JS and JN
+  JS = j1
+  JN = j2
+  !
+  do j=JS0,j1+1,-1
+  do i=1,IMR
+  if(abs(CRX(i,j))>1.) then
+        JS = j
+        go to 2222
+  endif
+  enddo
+  enddo
+  !
+2222   continue
+  do j=JN0,j2-1
+  do i=1,IMR
+  if(abs(CRX(i,j))>1.) then
+        JN = j
+        go to 2233
+  endif
+  enddo
+  enddo
+2233   continue
+  !
+  if(j1/=2) then           ! Enlarged polar cap.
+  do i=1,IMR
+  DPI(i,  2,k) = 0.
+  DPI(i,JMR,k) = 0.
+  enddo
+  endif
+  !
+  ! ******* Compute horizontal mass fluxes ************
+  !
+  ! N-S component
+  do j=j1,j2+1
+  D5 = 0.5 * COSE(j)
+  do i=1,IMR
+  ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k))
+  enddo
+  enddo
+  !
+  do j=j1,j2
+  DO i=1,IMR
+  DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
+  END DO
+  END DO
+  !
+  ! Poles
+  sum1 = ymass(IMR,j1  )
+  sum2 = ymass(IMR,J2+1)
+  do i=1,IMR-1
+  sum1 = sum1 + ymass(i,j1  )
+  sum2 = sum2 + ymass(i,J2+1)
+  enddo
+  !
+  sum1 = - sum1 * RCAP
+  sum2 =   sum2 * RCAP
+  do i=1,IMR
+  DPI(i,  1,k) = sum1
+  DPI(i,JNP,k) = sum2
+  enddo
+  !
+  ! E-W component
+  !
+  do j=j1,j2
+  do i=2,IMR
+  PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k))
+  enddo
+  enddo
+  !
+  do j=j1,j2
+  PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k))
+  enddo
+  !
+  do j=j1,j2
+  DO i=1,IMR
+  xmass(i,j) = PU(i,j)*CRX(i,j)
+  END DO
+  END DO
+  !
+  DO j=j1,j2
+  DO i=1,IMR-1
+  DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j)
+  END DO
+  END DO
+  !
+  DO j=j1,j2
+  DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j)
+  END DO
+  !
+  DO j=j1,j2
+  do i=1,IMR-1
+  UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j))
+  enddo
+  enddo
+  !
+  DO j=j1,j2
+  UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j))
+  enddo
+  !cccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! Rajouts pour LMDZ.3.3
+  !cccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  do i=1,IMR
+     do j=1,JNP
+         VA(i,j)=0.
+     enddo
+  enddo
+
+  do i=1,imr*(JMR-1)
+  VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3))
+  enddo
+  !
+  if(j1==2) then
+    IMH = IMR/2
+  do i=1,IMH
+  VA(i,      1) = 0.5*(CRY(i,2)-CRY(i+IMH,2))
+  VA(i+IMH,  1) = -VA(i,1)
+  VA(i,    JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR))
+  VA(i+IMH,JNP) = -VA(i,JNP)
+  enddo
+  VA(IMR,1)=VA(1,1)
+  VA(IMR,JNP)=VA(1,JNP)
+  endif
+  !
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  do IC=1,NC
+  !
+  do i=1,IMJM
+  wk1(i,1,1) = 0.
+  wk1(i,1,2) = 0.
+  enddo
+  !
+  ! E-W advective cross term
+  do j=J1,J2
+  if(J>JS  .and. J<JN) GO TO 250
+  !
+  do i=1,IMR
+  qtmp(i) = q(i,j,k,IC)
+  enddo
+  !
+  do i=-IML,0
+  qtmp(i)       = q(IMR+i,j,k,IC)
+  qtmp(IMR+1-i) = q(1-i,j,k,IC)
+  enddo
+  !
+  DO i=1,IMR
+  iu = UA(i,j)
+  ru = UA(i,j) - iu
+  iiu = i-iu
+  if(UA(i,j)>=0.) then
+  wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+  else
+  wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+  endif
+  wk1(i,j,1) = wk1(i,j,1) - qtmp(i)
+  END DO
+250   continue
+  END DO
+  !
+  if(JN/=0) then
+  do j=JS+1,JN-1
+  !
+  do i=1,IMR
+  qtmp(i) = q(i,j,k,IC)
+  enddo
+  !
+  qtmp(0)     = q(IMR,J,k,IC)
+  qtmp(IMR+1) = q(  1,J,k,IC)
+  !
+  do i=1,imr
+  iu = i - UA(i,j)
+  wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1))
+  enddo
+  enddo
+  endif
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  ! Contribution from the N-S advection
+  do i=1,imr*(j2-j1+1)
+  JT = REAL(J1) - VA(i,j1)
+  wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
+  enddo
+  !
+  do i=1,IMJM
+  wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1)
+  wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2)
+  enddo
+  !
+    if(cross) then
+  ! Add cross terms in the vertical direction.
+    if(IORD >= 2) then
+            iad = 2
+    else
+            iad = 1
+    endif
+  !
+    if(JORD >= 2) then
+            jad = 2
+    else
+            jad = 1
+    endif
+  CALL xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad)
+  CALL yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad)
+  do j=1,JNP
+  do i=1,IMR
+  q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j)
+  enddo
+  enddo
+  endif
+  !
+  CALL xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) &
+        ,CRX,fx1,xmass,IORD)
+
+  CALL ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY, &
+        DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD)
+  !
+  END DO
+  END DO
+  !
+  ! ******* Compute vertical mass flux (same unit as PS) ***********
+  !
+  ! 1st step: compute total column mass CONVERGENCE.
+  !
+  do j=1,JNP
+  do i=1,IMR
+  CRY(i,j) = DPI(i,j,1)
+  END DO
+  END DO
+  !
+  do k=2,NLAY
+  do j=1,JNP
+  do i=1,IMR
+  CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
+  END DO
+  END DO
+  END DO
+  !
+  do j=1,JNP
+  do i=1,IMR
+  !
+  ! 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption.
+  ! Changes (increases) to surface pressure = total column mass convergence
+  !
+  PS2(i,j)  = PS1(i,j) + CRY(i,j)
+  !
+  ! 3rd step: compute vertical mass flux from mass conservation principle.
+  !
+  W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j)
+  W(i,j,NLAY) = 0.
+  END DO
+  END DO
+  !
+  do k=2,NLAY-1
+  do j=1,JNP
+  do i=1,IMR
+  W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
+  END DO
+  END DO
+  END DO
+  !
+  DO k=1,NLAY
+  DO j=1,JNP
+  DO i=1,IMR
+  delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j)
+  END DO
+  END DO
+  END DO
+  !
+    KRD = max(3, KORD)
+  do IC=1,NC
+  !
+  !****6***0*********0*********0*********0*********0*********0**********72
+
+  CALL FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI, &
+        DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD)
+  !
+
+  if(fill) CALL qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2, &
+        cosp,acosp,.FALSE.,IC,NSTEP)
+  !
+  ! Recover tracer mixing ratio from "density" using predicted
+  ! "air density" (pressure thickness) at time-level n+1
+  !
+  DO k=1,NLAY
+  DO j=1,JNP
+  DO i=1,IMR
+        Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k)
+         ! PRINT*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC)
+  enddo
+  enddo
+  enddo
+  !
+  if(j1/=2) then
+  DO k=1,NLAY
+  DO I=1,IMR
+  ! j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord
+  Q(I,  2,k,IC) = Q(I,  1,k,IC)
+  Q(I,JMR,k,IC) = Q(I,JNP,k,IC)
+  END DO
+  END DO
+  endif
+  END DO
+  !
+  if(j1/=2) then
+  DO k=1,NLAY
+  DO i=1,IMR
+  W(i,  2,k) = W(i,  1,k)
+  W(i,JMR,k) = W(i,JNP,k)
+  END DO
+  END DO
+  endif
+  !
+  RETURN
+END SUBROUTINE ppm3d
+!
+!****6***0*********0*********0*********0*********0*********0**********72
+SUBROUTINE FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6, &
+        flux,wk1,wk2,wz2,delp,KORD)
+  implicit none
+  integer,parameter :: kmax = 150
+  real,parameter :: R23 = 2./3., R3 = 1./3.
+  integer :: IMR,JNP,NLAY,J1,KORD
+  real :: WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY), &
+        wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY), &
+        DQDT(IMR,JNP,NLAY)
+  ! Assuming JNP >= NLAY
+  real :: AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*), &
+        wz2(IMR,*)
+  integer :: JMR,IMJM,NLAYM1,LMT,K,I,J
+  real :: c0,c1,c2,tmp,qmax,qmin,a,b,fct,a1,a2,cm,cp
+  !
+  JMR = JNP - 1
+  IMJM = IMR*JNP
+  NLAYM1 = NLAY - 1
+  !
+  LMT = KORD - 3
+  !
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  ! Compute DC for PPM
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  !
+  do k=1,NLAYM1
+  do i=1,IMJM
+  DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
+  END DO
+  END DO
+  !
+  DO k=2,NLAYM1
+  DO I=1,IMJM
+   c0 =  delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1))
+   c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k))
+   c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k))
+  tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1))
+  Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k)
+  Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1))
+  DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp)
+  END DO
+  END DO
+
+  !
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  ! Loop over latitudes  (to save memory)
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  !
+  DO j=1,JNP
+  if((j==2 .or. j==JMR) .and. j1/=2) goto 2000
+  !
+  DO k=1,NLAY
+  DO i=1,IMR
+  wz2(i,k) =   WZ(i,j,k)
+  wk1(i,k) =    P(i,j,k)
+  wk2(i,k) = delp(i,j,k)
+  flux(i,k) = DC(i,j,k)  !this flux is actually the monotone slope
+  enddo
+  enddo
+  !
+  !****6***0*********0*********0*********0*********0*********0**********72
+  ! Compute first guesses at cell interfaces
+  ! First guesses are required to be continuous.
+  ! ****6***0*********0*********0*********0*********0*********0**********72
+  !
+  ! three-cell parabolic subgrid distribution at model top
+  ! two-cell parabolic with zero gradient subgrid distribution
+  ! at the surface.
+  !
+  ! First guess top edge value
+  DO i=1,IMR
+  ! three-cell PPM
+  ! Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
+  a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/ &
+        (wk2(i,1)+wk2(i,2)) ) / &
+        ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) )
+  b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - &
+        R23*a*(2.*wk2(i,1)+wk2(i,2))
+  AL(i,1) =  wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b)
+  AL(i,2) =  wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1)
+  !
+  ! Check if change sign
+  if(wk1(i,1)*AL(i,1)<=0.) then
+             AL(i,1) = 0.
+         flux(i,1) = 0.
+    else
+         flux(i,1) =  wk1(i,1) - AL(i,1)
+    endif
+  END DO
+  !
+  ! Bottom
+  DO i=1,IMR
+  ! 2-cell PPM with zero gradient right at the surface
+  !
+  fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 / &
+        ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1)))
+  AR(i,NLAY) = wk1(i,NLAY) + fct
+  AL(i,NLAY) = wk1(i,NLAY) - (fct+fct)
+  if(wk1(i,NLAY)*AR(i,NLAY)<=0.) AR(i,NLAY) = 0.
+  flux(i,NLAY) = AR(i,NLAY) -  wk1(i,NLAY)
+  END DO
+
+  !
+  !****6***0*********0*********0*********0*********0*********0**********72
+  ! 4th order interpolation in the interior.
+  !****6***0*********0*********0*********0*********0*********0**********72
+  !
+  DO k=3,NLAYM1
+  DO i=1,IMR
+  c1 =  DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k))
+  c2 =  2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1))
+  A1   =  (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k))
+  A2   =  (wk2(i,k  )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1))
+  AL(i,k) = wk1(i,k-1) + c1 + c2 * &
+        ( wk2(i,k  )*(c1*(A1 - A2)+A2*flux(i,k-1)) - &
+        wk2(i,k-1)*A1*flux(i,k)  )
+   ! print *,'AL1',i,k, AL(i,k)
+  END DO
+  END DO
+  !
+  do i=1,IMR*NLAYM1
+  AR(i,1) = AL(i,2)
+   ! print *,'AR1',i,AR(i,1)
+  END DO
+  !
+  do i=1,IMR*NLAY
+  A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1)))
+   ! print *,'A61',i,A6(i,1)
+  END DO
+  !
+  !****6***0*********0*********0*********0*********0*********0**********72
+  ! Top & Bot always monotonic
+  CALL lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0)
+  CALL lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY), &
+        wk1(1,NLAY),IMR,0)
+  !
+  ! Interior depending on KORD
+  if(LMT<=2) &
+        CALL lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2), &
+        IMR*(NLAY-2),LMT)
+  !
+  !****6***0*********0*********0*********0*********0*********0**********72
+  !
+  DO i=1,IMR*NLAYM1
+  IF(wz2(i,1)>0.) then
+    CM = wz2(i,1) / wk2(i,1)
+    flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM))
+  else
+     ! print *,'test2-0',i,j,wz2(i,1),wk2(i,2)
+    CP= wz2(i,1) / wk2(i,2)
+     ! print *,'testCP',CP
+    flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP))
+     ! print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23
+  endif
+  END DO
+  !
+  DO i=1,IMR*NLAYM1
+  flux(i,2) = wz2(i,1) * flux(i,2)
+  END DO
+  !
+  do i=1,IMR
+  DQ(i,j,   1) = DQ(i,j,   1) - flux(i,   2)
+  DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY)
+  END DO
+  !
+  do k=2,NLAYM1
+  do i=1,IMR
+  DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
+  END DO
+  END DO
+2000   continue
+  END DO
+  return
+end subroutine fzppm
+!
+SUBROUTINE xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC, &
+        fx1,xmass,IORD)
+  implicit none
+  integer :: IMR,JNP,IML,j1,j2,JN,JS,IORD
+  real :: PU,DQ,Q,UC,fx1,xmass
+  real :: dc,qtmp
+  integer :: ISAVE(IMR)
+  dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP) &
+        ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML)
+  dimension PU(IMR,JNP),Q(IMR,JNP)
+  integer :: jvan,j1vl,j2vl,j,i,iu,itmp,ist,imp
+  real :: rut
+  !
+  IMP = IMR + 1
+  !
+  ! van Leer at high latitudes
+  jvan = max(1,JNP/18)
+  j1vl = j1+jvan
+  j2vl = j2-jvan
+  !
+  do j=j1,j2
+  !
+  do i=1,IMR
+  qtmp(i) = q(i,j)
+  enddo
+  !
+  if(j>=JN .or. j<=JS) goto 2222
+  ! ************* Eulerian **********
+  !
+  qtmp(0)     = q(IMR,J)
+  qtmp(-1)    = q(IMR-1,J)
+  qtmp(IMP)   = q(1,J)
+  qtmp(IMP+1) = q(2,J)
+  !
+  IF(IORD==1 .or. j==j1 .or. j==j2) THEN
+  DO i=1,IMR
+  iu = REAL(i) - uc(i,j)
+  fx1(i) = qtmp(iu)
+  END DO
+  ELSE
+  CALL xmist(IMR,IML,Qtmp,DC)
+  DC(0) = DC(IMR)
+  !
+  if(IORD==2 .or. j<=j1vl .or. j>=j2vl) then
+  DO i=1,IMR
+  iu = REAL(i) - uc(i,j)
+  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
+  END DO
+  else
+  CALL fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
+  endif
+  !
+  ENDIF
+  !
+  DO i=1,IMR
+  fx1(i) = fx1(i)*xmass(i,j)
+  END DO
+  !
+  goto 1309
+  !
+  ! ***** Conservative (flux-form) Semi-Lagrangian transport *****
+  !
+2222   continue
+  !
+  do i=-IML,0
+  qtmp(i)     = q(IMR+i,j)
+  qtmp(IMP-i) = q(1-i,j)
+  enddo
+  !
+  IF(IORD==1 .or. j==j1 .or. j==j2) THEN
+  DO i=1,IMR
+  itmp = INT(uc(i,j))
+  ISAVE(i) = i - itmp
+  iu = i - uc(i,j)
+  fx1(i) = (uc(i,j) - itmp)*qtmp(iu)
+  END DO
+  ELSE
+  CALL xmist(IMR,IML,Qtmp,DC)
+  !
+  do i=-IML,0
+  DC(i)     = DC(IMR+i)
+  DC(IMP-i) = DC(1-i)
+  enddo
+  !
+  DO i=1,IMR
+  itmp = INT(uc(i,j))
+  rut  = uc(i,j) - itmp
+  ISAVE(i) = i - itmp
+  iu = i - uc(i,j)
+  fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut))
+  END DO
+  ENDIF
+  !
+  do i=1,IMR
+  IF(uc(i,j)>1.) then
+  !DIR$ NOVECTOR
+    do ist = ISAVE(i),i-1
+    fx1(i) = fx1(i) + qtmp(ist)
+    enddo
+  elseIF(uc(i,j)<-1.) then
+    do ist = i,ISAVE(i)-1
+    fx1(i) = fx1(i) - qtmp(ist)
+    enddo
+  !DIR$ VECTOR
+  endif
+  END DO
+  do i=1,IMR
+  fx1(i) = PU(i,j)*fx1(i)
+  enddo
+  !
+  ! ***************************************
+  !
+1309   fx1(IMP) = fx1(1)
+  DO i=1,IMR
+  DQ(i,j) =  DQ(i,j) + fx1(i)-fx1(i+1)
+  END DO
+  !
+  ! ***************************************
+  !
+  END DO
+  return
+end subroutine xtp
+!
+SUBROUTINE fxppm(IMR,IML,UT,P,DC,flux,IORD)
+  implicit none
+  integer :: IMR,IML,IORD
+  real :: UT,P,DC,flux
+  real,parameter ::  R3 = 1./3., R23 = 2./3.
+  DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
+  REAL :: AR(0:IMR),AL(0:IMR),A6(0:IMR)
+  integer :: LMT,IMP,JLVL,i
+   ! logical first
+   ! data first /.TRUE./
+   ! SAVE LMT
+   ! if(first) then
+  !
+  ! correction calcul de LMT a chaque passage pour pouvoir choisir
+  ! plusieurs schemas PPM pour differents traceurs
+  !  IF (IORD.LE.0) then
+  !        if(IMR.GE.144) then
+  !              LMT = 0
+  !        elseif(IMR.GE.72) then
+  !              LMT = 1
+  !        else
+  !              LMT = 2
+  !        endif
+  !  else
+  !        LMT = IORD - 3
+  !  endif
+  !
+  LMT = IORD - 3
+   ! write(6,*) 'PPM option in E-W direction = ', LMT
+   ! first = .FALSE.
+   ! endif
+  !
+  DO i=1,IMR
+  AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3
+  END DO
+  !
+  do i=1,IMR-1
+  AR(i) = AL(i+1)
+  END DO
+  AR(IMR) = AL(1)
+  !
+  do i=1,IMR
+  A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
+  END DO
+  !
+  if(LMT<=2) CALL lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT)
+  !
+  AL(0) = AL(IMR)
+  AR(0) = AR(IMR)
+  A6(0) = A6(IMR)
+  !
+  DO i=1,IMR
+  IF(UT(i)>0.) then
+  flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + &
+        A6(i-1)*(1.-R23*UT(i)) )
+  else
+  flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + &
+        A6(i)*(1.+R23*UT(i)))
+  endif
+  enddo
+  return
+end subroutine fxppm
+!
+SUBROUTINE xmist(IMR,IML,P,DC)
+  implicit none
+  integer :: IMR,IML
+  real,parameter :: R24 = 1./24.
+  real :: P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+  integer :: i
+  real :: tmp,pmax,pmin
+  !
+  do i=1,IMR
+  tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2))
+  Pmax = max(P(i-1), p(i), p(i+1)) - p(i)
+  Pmin = p(i) - min(P(i-1), p(i), p(i+1))
+  DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp)
+  END DO
+  return
+end subroutine xmist
+!
+SUBROUTINE ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2 &
+        ,ymass,fx,A6,AR,AL,JORD)
+  implicit none
+  integer :: IMR,JNP,j1,j2,JORD
+  real :: acosp,RCAP,DQ,P,VC,DC2,ymass,fx,A6,AR,AL
+  dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP) &
+        ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP)
+  ! Work array
+  DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+  integer :: JMR,len,i,jt,j
+  real :: sum1,sum2
+  !
+  JMR = JNP - 1
+  len = IMR*(J2-J1+2)
+  !
+  if(JORD==1) then
+  DO i=1,len
+  JT = REAL(J1) - VC(i,J1)
+  fx(i,j1) = p(i,JT)
+  END DO
+  else
+
+  CALL ymist(IMR,JNP,j1,P,DC2,4)
+  !
+  if(JORD<=0 .or. JORD>=3) then
+
+  CALL fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+
+  else
+  DO i=1,len
+  JT = REAL(J1) - VC(i,J1)
+  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
+  END DO
+  endif
+  endif
+  !
+  DO i=1,len
+  fx(i,j1) = fx(i,j1)*ymass(i,j1)
+  END DO
+  !
+  DO j=j1,j2
+  DO i=1,IMR
+  DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j)
+  END DO
+  END DO
+  !
+  ! Poles
+  sum1 = fx(IMR,j1  )
+  sum2 = fx(IMR,J2+1)
+  do i=1,IMR-1
+  sum1 = sum1 + fx(i,j1  )
+  sum2 = sum2 + fx(i,J2+1)
+  enddo
+  !
+  sum1 = DQ(1,  1) - sum1 * RCAP
+  sum2 = DQ(1,JNP) + sum2 * RCAP
+  do i=1,IMR
+  DQ(i,  1) = sum1
+  DQ(i,JNP) = sum2
+  enddo
+  !
+  if(j1/=2) then
+  do i=1,IMR
+  DQ(i,  2) = sum1
+  DQ(i,JMR) = sum2
+  enddo
+  endif
+  !
+  return
+end subroutine ytp
+!
+subroutine  ymist(IMR,JNP,j1,P,DC,ID)
+  implicit none
+  integer :: IMR,JNP,j1,ID
+  real,parameter :: R24 = 1./24.
+  real :: P(IMR,JNP),DC(IMR,JNP)
+  integer :: iimh,jmr,ijm3,imh,i
+  real :: pmax,pmin,tmp
+  !
+  IMH = IMR / 2
+  JMR = JNP - 1
+  IJM3 = IMR*(JMR-3)
+  !
+  IF(ID==2) THEN
+  do i=1,IMR*(JMR-1)
+  tmp = 0.25*(p(i,3) - p(i,1))
+  Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+  Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+  DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+  END DO
+  ELSE
+  do i=1,IMH
+  ! J=2
+  tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24
+  Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+  Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+  DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+  ! J=JMR
+  tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24
+  Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+  Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+  DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+  END DO
+  do i=IMH+1,IMR
+  ! J=2
+  tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24
+  Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+  Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+  DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+  ! J=JMR
+  tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24
+  Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+  Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+  DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+  END DO
+  !
+  do i=1,IJM3
+  tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24
+  Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3)
+  Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4))
+  DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+  END DO
+  ENDIF
+  !
+  if(j1/=2) then
+  do i=1,IMR
+  DC(i,1) = 0.
+  DC(i,JNP) = 0.
+  enddo
+  else
+  ! Determine slopes in polar caps for scalars!
+  !
+  do i=1,IMH
+  ! South
+  tmp = 0.25*(p(i,2) - p(i+imh,2))
+  Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1)
+  Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2))
+  DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp)
+  ! North.
+  tmp = 0.25*(p(i+imh,JMR) - p(i,JMR))
+  Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP)
+  Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR))
+  DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp)
+  END DO
+  !
+  do i=imh+1,IMR
+  DC(i,  1) =  - DC(i-imh,  1)
+  DC(i,JNP) =  - DC(i-imh,JNP)
+  END DO
+  endif
+  return
+end subroutine ymist
+!
+SUBROUTINE fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+  implicit none
+  integer :: IMR,JNP,j1,j2,JORD
+  real,parameter :: R3 = 1./3., R23 = 2./3.
+  real :: VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
+  ! Local work arrays.
+  real :: AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+  integer :: LMT,i
+  integer :: IMH,JMR,j11,IMJM1,len
+   ! logical first
+   ! data first /.TRUE./
+   ! SAVE LMT
+  !
+  IMH = IMR / 2
+  JMR = JNP - 1
+  j11 = j1-1
+  IMJM1 = IMR*(J2-J1+2)
+  len   = IMR*(J2-J1+3)
+   ! if(first) then
+   ! IF(JORD.LE.0) then
+   !       if(JMR.GE.90) then
+   !             LMT = 0
+   !       elseif(JMR.GE.45) then
+   !             LMT = 1
+   !       else
+   !             LMT = 2
+   !       endif
+   ! else
+   !       LMT = JORD - 3
+   ! endif
+  !
+  !  first = .FALSE.
+  !  endif
+  !
+  ! modifs pour pouvoir choisir plusieurs schemas PPM
+  LMT = JORD - 3
+  !
+  DO i=1,IMR*JMR
+  AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3
+  AR(i,1) = AL(i,2)
+  END DO
+  !
+  !Poles:
+  !
+  DO i=1,IMH
+  AL(i,1) = AL(i+IMH,2)
+  AL(i+IMH,1) = AL(i,2)
+  !
+  AR(i,JNP) = AR(i+IMH,JMR)
+  AR(i+IMH,JNP) = AR(i,JMR)
+  ENDDO
+
+  !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  !   Rajout pour LMDZ.3.3
+  !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  AR(IMR,1)=AL(1,1)
+  AR(IMR,JNP)=AL(1,JNP)
+  !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  do i=1,len
+  A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
+  END DO
+  !
+  if(LMT<=2) CALL lmtppm(DC(1,j11),A6(1,j11),AR(1,j11) &
+        ,AL(1,j11),P(1,j11),len,LMT)
+  !
+
+  DO i=1,IMJM1
+  IF(VC(i,j1)>0.) then
+  flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) + &
+        A6(i,j11)*(1.-R23*VC(i,j1)) )
+  else
+  flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + &
+        A6(i,j1)*(1.+R23*VC(i,j1)))
+  endif
+  END DO
+  return
+end subroutine fyppm
+!
+  SUBROUTINE yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
+    implicit none
+    integer :: IMR,JNP,j1,j2,IAD
+    REAL :: p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
+    REAL :: WK(IMR,-1:JNP+2)
+    INTEGER :: JMR,IMH,i,j,jp
+    REAL :: rv,a1,b1,sum1,sum2
+  !
+    JMR = JNP-1
+    IMH = IMR/2
+    do j=1,JNP
+    do i=1,IMR
+    wk(i,j) = p(i,j)
+    enddo
+    enddo
+  ! Poles:
+    do i=1,IMH
+    wk(i,   -1) = p(i+IMH,3)
+    wk(i+IMH,-1) = p(i,3)
+    wk(i,    0) = p(i+IMH,2)
+    wk(i+IMH,0) = p(i,2)
+    wk(i,JNP+1) = p(i+IMH,JMR)
+    wk(i+IMH,JNP+1) = p(i,JMR)
+    wk(i,JNP+2) = p(i+IMH,JNP-2)
+    wk(i+IMH,JNP+2) = p(i,JNP-2)
+    enddo
+     ! write(*,*) 'toto 1'
+  ! --------------------------------
+  IF(IAD==2) then
+  do j=j1-1,j2+1
+  do i=1,IMR
+   ! write(*,*) 'avt NINT','i=',i,'j=',j
+  JP = NINT(VA(i,j))
+  rv = JP - VA(i,j)
+   ! write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv
+  JP = j - JP
+   ! write(*,*) 'JP2=',JP
+  a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp)
+  b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1))
+   ! write(*,*) 'a1=',a1,'b1=',b1
+  ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j)
+  enddo
+  enddo
+   ! write(*,*) 'toto 2'
+  !
+  ELSEIF(IAD==1) then
+    do j=j1-1,j2+1
+  do i=1,imr
+  JP = REAL(j)-VA(i,j)
+  ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
+  enddo
+  enddo
+  ENDIF
+  !
+    if(j1/=2) then
+    sum1 = 0.
+    sum2 = 0.
+  do i=1,imr
+  sum1 = sum1 + ady(i,2)
+  sum2 = sum2 + ady(i,JMR)
+  enddo
+    sum1 = sum1 / IMR
+    sum2 = sum2 / IMR
+  !
+  do i=1,imr
+  ady(i,  2) =  sum1
+  ady(i,JMR) =  sum2
+  ady(i,  1) =  sum1
+  ady(i,JNP) =  sum2
+  enddo
+    else
+  ! Poles:
+    sum1 = 0.
+    sum2 = 0.
+  do i=1,imr
+  sum1 = sum1 + ady(i,1)
+  sum2 = sum2 + ady(i,JNP)
+  enddo
+    sum1 = sum1 / IMR
+    sum2 = sum2 / IMR
+  !
+  do i=1,imr
+  ady(i,  1) =  sum1
+  ady(i,JNP) =  sum2
+  enddo
+    endif
+  !
+    return
+end subroutine yadv
+!
+  SUBROUTINE xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD)
+    implicit none
+    INTEGER :: IMR,JNP,j1,j2,JS,JN,IML,IAD
+    REAL :: p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
+    INTEGER :: JMR,j,i,ip,iu,iiu
+    REAL :: ru,a1,b1
+  !
+    JMR = JNP-1
+  do j=j1,j2
+  if(J>JS  .and. J<JN) GO TO 1309
+  !
+  do i=1,IMR
+  qtmp(i) = p(i,j)
+  enddo
+  !
+  do i=-IML,0
+  qtmp(i)       = p(IMR+i,j)
+  qtmp(IMR+1-i) = p(1-i,j)
+  enddo
+  !
+  IF(IAD==2) THEN
+  DO i=1,IMR
+  IP = NINT(UA(i,j))
+  ru = IP - UA(i,j)
+  IP = i - IP
+  a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+  b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+  adx(i,j) = qtmp(ip) + ru*(a1*ru + b1)
+  enddo
+  ELSEIF(IAD==1) then
+  DO i=1,IMR
+  iu = UA(i,j)
+  ru = UA(i,j) - iu
+  iiu = i-iu
+  if(UA(i,j)>=0.) then
+  adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+  else
+  adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+  endif
+  enddo
+  ENDIF
+  !
+  do i=1,IMR
+  adx(i,j) = adx(i,j) - p(i,j)
+  enddo
+1309   continue
+  END DO
+  !
+  ! Eulerian upwind
+  !
+  do j=JS+1,JN-1
+  !
+  do i=1,IMR
+  qtmp(i) = p(i,j)
+  enddo
+  !
+  qtmp(0)     = p(IMR,J)
+  qtmp(IMR+1) = p(1,J)
+  !
+  IF(IAD==2) THEN
+  qtmp(-1)     = p(IMR-1,J)
+  qtmp(IMR+2) = p(2,J)
+  do i=1,imr
+  IP = NINT(UA(i,j))
+  ru = IP - UA(i,j)
+  IP = i - IP
+  a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+  b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+  adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1)
+  enddo
+  ELSEIF(IAD==1) then
+  ! 1st order
+  DO i=1,IMR
+  IP = i - UA(i,j)
+  adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1))
+  enddo
+  ENDIF
+  enddo
+  !
+    if(j1/=2) then
+  do i=1,IMR
+  adx(i,  2) = 0.
+  adx(i,JMR) = 0.
+  enddo
+    endif
+  ! set cross term due to x-adv at the poles to zero.
+  do i=1,IMR
+  adx(i,  1) = 0.
+  adx(i,JNP) = 0.
+  enddo
+    return
+end subroutine xadv
+!
+SUBROUTINE lmtppm(DC,A6,AR,AL,P,IM,LMT)
+  implicit none
+  !
+  ! A6 =  CURVATURE OF THE TEST PARABOLA
+  ! AR =  RIGHT EDGE VALUE OF THE TEST PARABOLA
+  ! AL =  LEFT  EDGE VALUE OF THE TEST PARABOLA
+  ! DC =  0.5 * MISMATCH
+  ! P  =  CELL-AVERAGED VALUE
+  ! IM =  VECTOR LENGTH
+  !
+  ! OPTIONS:
+  !
+  ! LMT = 0: FULL MONOTONICITY
+  ! LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS)
+  ! LMT = 2: POSITIVE-DEFINITE CONSTRAINT
+  !
+  real,parameter :: R12 = 1./12.
+  real :: A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+  integer :: IM,LMT
+  INTEGER :: i
+  REAL :: da1,da2,a6da,fmin
+  !
+  if(LMT==0) then
+  ! Full constraint
+  do i=1,IM
+  if(DC(i)==0.) then
+        AR(i) = p(i)
+        AL(i) = p(i)
+        A6(i) = 0.
+  else
+  da1  = AR(i) - AL(i)
+  da2  = da1**2
+  A6DA = A6(i)*da1
+  if(A6DA < -da2) then
+        A6(i) = 3.*(AL(i)-p(i))
+        AR(i) = AL(i) - A6(i)
+  elseif(A6DA > da2) then
+        A6(i) = 3.*(AR(i)-p(i))
+        AL(i) = AR(i) - A6(i)
+  endif
+  endif
+  END DO
+  elseif(LMT==1) then
+  ! Semi-monotonic constraint
+  do i=1,IM
+  if(abs(AR(i)-AL(i)) >= -A6(i)) go to 150
+  if(p(i)<AR(i) .and. p(i)<AL(i)) then
+        AR(i) = p(i)
+        AL(i) = p(i)
+        A6(i) = 0.
+  elseif(AR(i) > AL(i)) then
+        A6(i) = 3.*(AL(i)-p(i))
+        AR(i) = AL(i) - A6(i)
+  else
+        A6(i) = 3.*(AR(i)-p(i))
+        AL(i) = AR(i) - A6(i)
+  endif
+150   continue
+  END DO
+  elseif(LMT==2) then
+  do i=1,IM
+  if(abs(AR(i)-AL(i)) >= -A6(i)) go to 250
+  fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
+  if(fmin>=0.) go to 250
+  if(p(i)<AR(i) .and. p(i)<AL(i)) then
+        AR(i) = p(i)
+        AL(i) = p(i)
+        A6(i) = 0.
+  elseif(AR(i) > AL(i)) then
+        A6(i) = 3.*(AL(i)-p(i))
+        AR(i) = AL(i) - A6(i)
+  else
+        A6(i) = 3.*(AR(i)-p(i))
+        AL(i) = AR(i) - A6(i)
+  endif
+250   continue
+  END DO
+  endif
+  return
+end subroutine lmtppm
+!
+SUBROUTINE A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+  implicit none
+  integer :: IMR,JMR,j1,j2
+  real :: U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*),DTDY5
+  integer :: i,j
+  !
+  do j=j1,j2
+  do i=2,IMR
+  CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
+  END DO
+  END DO
+  !
+  do j=j1,j2
+  CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
+  END DO
+  !
+  do i=1,IMR*JMR
+  CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
+  END DO
+  return
+end subroutine a2c
+!
+SUBROUTINE cosa(cosp,cose,JNP,PI,DP)
+  implicit none
+  integer :: JNP
+  real :: cosp(*),cose(*),PI,DP
+  integer :: JMR,j,jeq
+  real :: ph5
+  JMR = JNP-1
+  do j=2,JNP
+    ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
+    cose(j) = cos(ph5)
+  END DO
+  !
+  JEQ = (JNP+1) / 2
+  if(JMR == 2*(JMR/2) ) then
+  do j=JNP, JEQ+1, -1
+   cose(j) =  cose(JNP+2-j)
+  enddo
+  else
+  ! cell edge at equator.
+   cose(JEQ+1) =  1.
+  do j=JNP, JEQ+2, -1
+   cose(j) =  cose(JNP+2-j)
+   enddo
+  endif
+  !
+  do j=2,JMR
+  cosp(j) = 0.5*(cose(j)+cose(j+1))
+  END DO
+  cosp(1) = 0.
+  cosp(JNP) = 0.
+  return
+end subroutine cosa
+!
+SUBROUTINE cosc(cosp,cose,JNP,PI,DP)
+  implicit none
+  integer :: JNP
+  real :: cosp(*),cose(*),PI,DP
+  real :: phi
+  integer :: j
+  !
+  phi = -0.5*PI
+  do j=2,JNP-1
+  phi  =  phi + DP
+  cosp(j) = cos(phi)
+  END DO
+    cosp(  1) = 0.
+    cosp(JNP) = 0.
+  !
+  do j=2,JNP
+    cose(j) = 0.5*(cosp(j)+cosp(j-1))
+  END DO
+  !
+  do j=2,JNP-1
+   cosp(j) = 0.5*(cose(j)+cose(j+1))
+  END DO
+  return
+end subroutine cosc
+!
+SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, &
+        cross,IC,NSTEP)
+  !
+  real,parameter :: tiny = 1.E-60
+  INTEGER :: IMR,JNP,NLAY,j1,j2,IC,NSTEP
+  REAL :: Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
+  logical :: cross
+  INTEGER :: NLAYM1,len,ip,L,icr,ipy,ipx,i
+  real :: qup,qly,dup,sum
+  !
+  NLAYM1 = NLAY-1
+  len = IMR*(j2-j1+1)
+  ip = 0
+  !
+  ! Top layer
+  L = 1
+    icr = 1
+  CALL filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+  if(ipy==0) goto 50
+  CALL filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+  if(ipx==0) goto 50
+  !
+  if(cross) then
+  CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+  endif
+  if(icr==0) goto 50
+  !
+  ! Vertical filling...
+  do i=1,len
+  IF( Q(i,j1,1)<0.) THEN
+  ip = ip + 1
+      Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1)
+      Q(i,j1,1) = 0.
+  endif
+  enddo
+  !
+50   continue
+  DO L = 2,NLAYM1
+  icr = 1
+  !
+  CALL filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+  if(ipy==0) goto 225
+  CALL filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+  if(ipx==0) go to 225
+  if(cross) then
+  CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+  endif
+  if(icr==0) goto 225
+  !
+  do i=1,len
+  IF( Q(I,j1,L)<0.) THEN
+  !
+  ip = ip + 1
+  ! From above
+      qup =  Q(I,j1,L-1)
+      qly = -Q(I,j1,L)
+      dup  = min(qly,qup)
+      Q(I,j1,L-1) = qup - dup
+      Q(I,j1,L  ) = dup-qly
+  ! Below
+      Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L)
+      Q(I,j1,L)   = 0.
+  ENDIF
+  ENDDO
+225   CONTINUE
+  END DO
+  !
+  ! BOTTOM LAYER
+  sum = 0.
+  L = NLAY
+  !
+  CALL filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+  if(ipy==0) goto 911
+  CALL filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+  if(ipx==0) goto 911
+  !
+  CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+  if(icr==0) goto 911
+  !
+  DO  I=1,len
+  IF( Q(I,j1,L)<0.) THEN
+  ip = ip + 1
+  !
+  ! From above
+  !
+      qup = Q(I,j1,NLAYM1)
+      qly = -Q(I,j1,L)
+      dup = min(qly,qup)
+      Q(I,j1,NLAYM1) = qup - dup
+  ! From "below" the surface.
+      sum = sum + qly-dup
+      Q(I,j1,L) = 0.
+   ENDIF
+  ENDDO
+  !
+911   continue
+  !
+  if(ip>IMR) then
+  write(6,*) 'IC=',IC,' STEP=',NSTEP, &
+        ' Vertical filling pts=',ip
+  endif
+  !
+  if(sum>1.e-25) then
+  write(6,*) IC,NSTEP,' Mass source from the ground=',sum
+  endif
+  RETURN
+END SUBROUTINE qckxyz
+!
+SUBROUTINE filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+  implicit none
+  integer :: IMR,JNP,j1,j2,icr
+  real :: q(IMR,*),cosp(*),acosp(*),tiny
+  integer :: i,j
+  real :: dq,dn,d0,d1,ds,d2
+  icr = 0
+  do j=j1+1,j2-1
+  DO i=1,IMR-1
+  IF(q(i,j)<0.) THEN
+  icr =  1
+  dq  = - q(i,j)*cosp(j)
+  ! N-E
+  dn = q(i+1,j+1)*cosp(j+1)
+  d0 = max(0.,dn)
+  d1 = min(dq,d0)
+  q(i+1,j+1) = (dn - d1)*acosp(j+1)
+  dq = dq - d1
+  ! S-E
+  ds = q(i+1,j-1)*cosp(j-1)
+  d0 = max(0.,ds)
+  d2 = min(dq,d0)
+  q(i+1,j-1) = (ds - d2)*acosp(j-1)
+  q(i,j) = (d2 - dq)*acosp(j) + tiny
+  endif
+  END DO
+  if(icr==0 .and. q(IMR,j)>=0.) goto 65
+  DO i=2,IMR
+  IF(q(i,j)<0.) THEN
+  icr =  1
+  dq  = - q(i,j)*cosp(j)
+  ! N-W
+  dn = q(i-1,j+1)*cosp(j+1)
+  d0 = max(0.,dn)
+  d1 = min(dq,d0)
+  q(i-1,j+1) = (dn - d1)*acosp(j+1)
+  dq = dq - d1
+  ! S-W
+  ds = q(i-1,j-1)*cosp(j-1)
+  d0 = max(0.,ds)
+  d2 = min(dq,d0)
+  q(i-1,j-1) = (ds - d2)*acosp(j-1)
+  q(i,j) = (d2 - dq)*acosp(j) + tiny
+  endif
+  END DO
+  ! *****************************************
+  ! i=1
+  i=1
+  IF(q(i,j)<0.) THEN
+  icr =  1
+  dq  = - q(i,j)*cosp(j)
+  ! N-W
+  dn = q(IMR,j+1)*cosp(j+1)
+  d0 = max(0.,dn)
+  d1 = min(dq,d0)
+  q(IMR,j+1) = (dn - d1)*acosp(j+1)
+  dq = dq - d1
+  ! S-W
+  ds = q(IMR,j-1)*cosp(j-1)
+  d0 = max(0.,ds)
+  d2 = min(dq,d0)
+  q(IMR,j-1) = (ds - d2)*acosp(j-1)
+  q(i,j) = (d2 - dq)*acosp(j) + tiny
+  endif
+  ! *****************************************
+  ! i=IMR
+  i=IMR
+  IF(q(i,j)<0.) THEN
+  icr =  1
+  dq  = - q(i,j)*cosp(j)
+  ! N-E
+  dn = q(1,j+1)*cosp(j+1)
+  d0 = max(0.,dn)
+  d1 = min(dq,d0)
+  q(1,j+1) = (dn - d1)*acosp(j+1)
+  dq = dq - d1
+  ! S-E
+  ds = q(1,j-1)*cosp(j-1)
+  d0 = max(0.,ds)
+  d2 = min(dq,d0)
+  q(1,j-1) = (ds - d2)*acosp(j-1)
+  q(i,j) = (d2 - dq)*acosp(j) + tiny
+  endif
+  ! *****************************************
+65   continue
+  END DO
+  !
+  do i=1,IMR
+  if(q(i,j1)<0. .or. q(i,j2)<0.) then
+  icr = 1
+  goto 80
+  endif
+  enddo
+  !
+80   continue
+  !
+  if(q(1,1)<0. .or. q(1,jnp)<0.) then
+  icr = 1
+  endif
+  !
+  return
+end subroutine filcr
+!
+SUBROUTINE filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+  implicit none
+  integer :: IMR,JNP,j1,j2,ipy
+  real :: q(IMR,*),cosp(*),acosp(*),tiny
+  real :: DP,CAP1,dq,dn,d0,d1,ds,d2
+  INTEGER :: i,j
+   ! logical first
+   ! data first /.TRUE./
+   ! save cap1
+  !
+  !  if(first) then
+  DP = 4.*ATAN(1.)/REAL(JNP-1)
+  CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
+   ! first = .FALSE.
+   ! endif
+  !
+  ipy = 0
+  do j=j1+1,j2-1
+  DO i=1,IMR
+  IF(q(i,j)<0.) THEN
+  ipy =  1
+  dq  = - q(i,j)*cosp(j)
+  ! North
+  dn = q(i,j+1)*cosp(j+1)
+  d0 = max(0.,dn)
+  d1 = min(dq,d0)
+  q(i,j+1) = (dn - d1)*acosp(j+1)
+  dq = dq - d1
+  ! South
+  ds = q(i,j-1)*cosp(j-1)
+  d0 = max(0.,ds)
+  d2 = min(dq,d0)
+  q(i,j-1) = (ds - d2)*acosp(j-1)
+  q(i,j) = (d2 - dq)*acosp(j) + tiny
+  endif
+  END DO
+  END DO
+  !
+  do i=1,imr
+  IF(q(i,j1)<0.) THEN
+  ipy =  1
+  dq  = - q(i,j1)*cosp(j1)
+  ! North
+  dn = q(i,j1+1)*cosp(j1+1)
+  d0 = max(0.,dn)
+  d1 = min(dq,d0)
+  q(i,j1+1) = (dn - d1)*acosp(j1+1)
+  q(i,j1) = (d1 - dq)*acosp(j1) + tiny
+  endif
+  enddo
+  !
+  j = j2
+  do i=1,imr
+  IF(q(i,j)<0.) THEN
+  ipy =  1
+  dq  = - q(i,j)*cosp(j)
+  ! South
+  ds = q(i,j-1)*cosp(j-1)
+  d0 = max(0.,ds)
+  d2 = min(dq,d0)
+  q(i,j-1) = (ds - d2)*acosp(j-1)
+  q(i,j) = (d2 - dq)*acosp(j) + tiny
+  endif
+  enddo
+  !
+  ! Check Poles.
+  if(q(1,1)<0.) then
+  dq = q(1,1)*cap1/REAL(IMR)*acosp(j1)
+  do i=1,imr
+  q(i,1) = 0.
+  q(i,j1) = q(i,j1) + dq
+  if(q(i,j1)<0.) ipy = 1
+  enddo
+  endif
+  !
+  if(q(1,JNP)<0.) then
+  dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2)
+  do i=1,imr
+  q(i,JNP) = 0.
+  q(i,j2) = q(i,j2) + dq
+  if(q(i,j2)<0.) ipy = 1
+  enddo
+  endif
+  !
+  return
+end subroutine filns
+!
+SUBROUTINE filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
+  implicit none
+  integer :: IMR,JNP,j1,j2,ipx
+  real :: q(IMR,*),qtmp(JNP,IMR),tiny
+  integer :: i,j
+  real :: d0,d1,d2
+  !
+  ipx = 0
+  ! Copy & swap direction for vectorization.
+  do i=1,imr
+  do j=j1,j2
+  qtmp(j,i) = q(i,j)
+  END DO
+  END DO
+  !
+  do i=2,imr-1
+  do j=j1,j2
+  if(qtmp(j,i)<0.) then
+  ipx =  1
+  ! west
+  d0 = max(0.,qtmp(j,i-1))
+  d1 = min(-qtmp(j,i),d0)
+  qtmp(j,i-1) = qtmp(j,i-1) - d1
+  qtmp(j,i) = qtmp(j,i) + d1
+  ! east
+  d0 = max(0.,qtmp(j,i+1))
+  d2 = min(-qtmp(j,i),d0)
+  qtmp(j,i+1) = qtmp(j,i+1) - d2
+  qtmp(j,i) = qtmp(j,i) + d2 + tiny
+  endif
+  END DO
+  END DO
+  !
+  i=1
+  do j=j1,j2
+  if(qtmp(j,i)<0.) then
+  ipx =  1
+  ! west
+  d0 = max(0.,qtmp(j,imr))
+  d1 = min(-qtmp(j,i),d0)
+  qtmp(j,imr) = qtmp(j,imr) - d1
+  qtmp(j,i) = qtmp(j,i) + d1
+  ! east
+  d0 = max(0.,qtmp(j,i+1))
+  d2 = min(-qtmp(j,i),d0)
+  qtmp(j,i+1) = qtmp(j,i+1) - d2
+  !
+  qtmp(j,i) = qtmp(j,i) + d2 + tiny
+  endif
+  END DO
+  i=IMR
+  do j=j1,j2
+  if(qtmp(j,i)<0.) then
+  ipx =  1
+  ! west
+  d0 = max(0.,qtmp(j,i-1))
+  d1 = min(-qtmp(j,i),d0)
+  qtmp(j,i-1) = qtmp(j,i-1) - d1
+  qtmp(j,i) = qtmp(j,i) + d1
+  ! east
+  d0 = max(0.,qtmp(j,1))
+  d2 = min(-qtmp(j,i),d0)
+  qtmp(j,1) = qtmp(j,1) - d2
+  !
+  qtmp(j,i) = qtmp(j,i) + d2 + tiny
+  endif
+  END DO
+  !
+  if(ipx/=0) then
+  do j=j1,j2
+  do i=1,imr
+  q(i,j) = qtmp(j,i)
+  END DO
+  END DO
+  else
+  !
+  ! Poles.
+  if(q(1,1)<0 .or. q(1,JNP)<0.) ipx = 1
+  endif
+  return
+end subroutine filew
+!
+SUBROUTINE zflip(q,im,km,nc)
+  implicit none
+  ! This routine flip the array q (in the vertical).
+  integer :: im,km,nc
+  real :: q(im,km,nc)
+  ! local dynamic array
+  real :: qtmp(im,km)
+  integer :: IC,k,i
+  !
+  do IC = 1, nc
+  !
+  do k=1,km
+  do i=1,im
+  qtmp(i,k) = q(i,km+1-k,IC)
+  END DO
+  END DO
+  !
+  do i=1,im*km
+  q(i,1,IC) = qtmp(i,1)
+  END DO
+  END DO
+  return
+end subroutine zflip
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/prather.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.F	(revision 5104)
+++ 	(revision )
@@ -1,362 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
-      
-      USE comconst_mod, ONLY: pi
-      
-      IMPLICIT NONE
-
-c=======================================================================
-c   Adaptation LMDZ:  A.Armengaud (LGGE)
-c   ----------------
-c
-c   ************************************************
-c   Transport des traceurs par la methode de prather
-c   Ref : 
-c
-c   ************************************************
-c   q,w,pext,pbaru et pbarv : arguments d'entree  pour le s-pg
-c
-c=======================================================================
-
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-c   Arguments:
-c   ----------
-      INTEGER iq,nt
-      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
-      REAL masse(iip1,jjp1,llm)
-      REAL q( iip1,jjp1,llm,0:9)
-      REAL w( ip1jmp1,llm )
-      integer ordre,ilim
-
-c   Local:
-c   ------
-      LOGICAL limit
-      real zq(iip1,jjp1,llm)
-      REAL sm ( iip1,jjp1, llm )
-      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
-      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
-      REAL sxx( iip1,jjp1,llm)
-      REAL sxy( iip1,jjp1,llm)
-      REAL sxz( iip1,jjp1,llm)
-      REAL syy( iip1,jjp1,llm )
-      REAL syz( iip1,jjp1,llm )
-      REAL szz( iip1,jjp1,llm ),zz
-      INTEGER i,j,l,indice
-      real sxn(iip1),sxs(iip1)
-
-      real sinlon(iip1),sinlondlon(iip1)
-      real coslon(iip1),coslondlon(iip1)
-      real qmin,qmax
-      save qmin,qmax
-      save sinlon,coslon,sinlondlon,coslondlon
-      real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps
-      real masn,mass
-c
-      REAL      SSUM
-      integer ismax,ismin
-      EXTERNAL  SSUM, ismin,ismax
-      logical first
-      save first
-      EXTERNAL advxp,advyp,advzp 
-
-
-      data first/.TRUE./
-      data qmin,qmax/-1.e33,1.e33/
-
-
-c==========================================================================
-c==========================================================================
-c     MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt
-c==========================================================================
-c==========================================================================
-      REAL dt
-c==========================================================================
-      limit = .TRUE.
- 
-      if(first) then
-         PRINT*,'SCHEMA PRATHER'
-         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)
-
-        DO l = 1,llm
-        DO j = 1,jjp1
-        DO i = 1,iip1
-        q( i,j,l,1 )=0.
-        q( i,j,l,2)=0.
-        q( i,j,l,3)=0.
-        q( i,j,l,4)=0.
-        q( i,j,l,5)=0.
-        q( i,j,l,6)=0.
-        q( i,j,l,7)=0.
-        q( i,j,l,8)=0.
-        q( i,j,l,9)=0.
-        ENDDO
-        ENDDO
-        ENDDO
-      endif
-c   Fin modif Fred
-
-c *** On calcule la masse d'air en kg
-
-       DO l = 1,llm
-        DO j = 1,jjp1
-         DO i = 1,iip1
-         sm( i,j,llm+1-l ) =masse(i,j,l)
-         ENDDO
-        ENDDO
-       ENDDO
-
-c *** q contient les qqtes de traceur avant l'advection 
-
-c *** Affectation des tableaux S a partir de Q
- 
-       DO l = 1,llm
-        DO j = 1,jjp1
-         DO i = 1,iip1
-       s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l)
-       sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l)
-       sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l)
-       sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l)
-       sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l)
-       sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l)
-       sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l)
-       syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l)
-       syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l)
-       szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l)
-         ENDDO
-        ENDDO
-       ENDDO
-c *** Appel des subroutines d'advection en X, en Y et en Z
-c *** Advection avec "time-splitting"
-      
-c-----------------------------------------------------------
-       do indice =1,nt
-       CALL advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
-     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
-        END DO
-        do l=1,llm
-        do i=1,iip1
-        sy(i,1,l)=0.
-        sy(i,jjp1,l)=0.
-        enddo
-        enddo
-c---------------------------------------------------------
-       CALL advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
-     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
-c---------------------------------------------------------
-
-c---------------------------------------------------------
-       do j=1,jjp1
-          do i=1,iip1
-             sz(i,j,1)=0.
-             sz(i,j,llm)=0.
-             sxz(i,j,1)=0.
-             sxz(i,j,llm)=0.
-             syz(i,j,1)=0.
-             syz(i,j,llm)=0.
-             szz(i,j,1)=0.
-             szz(i,j,llm)=0.
-          enddo
-       enddo
-       CALL advzp( limit,dt*nt,w,sm,s0,sx,sy,sz
-     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
-        do l=1,llm
-        do i=1,iip1
-        sy(i,1,l)=0.
-        sy(i,jjp1,l)=0.
-        enddo
-        enddo
-
-c---------------------------------------------------------
-
-c---------------------------------------------------------
-       CALL advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
-     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
-c---------------------------------------------------------
-       DO l = 1,llm
-        DO j = 1,jjp1
-             s0( iip1,j,l)=s0( 1,j,l )
-             sx( iip1,j,l)=sx( 1,j,l )
-             sy( iip1,j,l)=sy( 1,j,l )
-             sz( iip1,j,l)=sz( 1,j,l )
-             sxx( iip1,j,l)=sxx( 1,j,l )
-             sxy( iip1,j,l)=sxy( 1,j,l) 
-             sxz( iip1,j,l)=sxz( 1,j,l )
-             syy( iip1,j,l)=syy( 1,j,l )
-             syz( iip1,j,l)=syz( 1,j,l)
-             szz( iip1,j,l)=szz( 1,j,l )
-        ENDDO
-       ENDDO
-       do indice=1,nt
-       CALL advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
-     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
-        END DO
-c---------------------------------------------------------
-c---------------------------------------------------------
-c ***   On repasse les S dans la variable qpr
-c ***   On repasse les S dans la variable q directement 14/10/94
-
-       DO  l = 1,llm
-        DO  j = 1,jjp1
-         DO  i = 1,iip1
-      q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l)
-      q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l)
-      ENDDO
-      ENDDO
-      ENDDO
-
-c---------------------------------------------------------
-c      go to  777
-c   filtrages aux poles
-
-c Traitements specifiques au pole
-
-c   filtrages aux poles
-         DO l=1,llm
-c   filtrages aux poles
-         masn=ssum(iim,sm(1,1,l),1)
-         mass=ssum(iim,sm(1,jjp1,l),1)
-         qpn=ssum(iim,s0(1,1,l),1)/masn
-         qps=ssum(iim,s0(1,jjp1,l),1)/mass
-         dqzpn=ssum(iim,sz(1,1,l),1)/masn
-         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
-         do i=1,iip1
-          q( i,1,llm+1-l,3)=dqzpn
-          q( i,jjp1,llm+1-l,3)=dqzps
-          q( i,1,llm+1-l,0)=qpn
-          q( i,jjp1,llm+1-l,0)=qps
-         enddo
-c       enddo
-c         PRINT*,'qpn',qpn,'qps',qps
-c          PRINT*,'dqzpn',dqzpn,'dqzps',dqzps
-c       enddo
-           dyn1=0.
-           dys1=0.
-           dyn2=0.
-           dys2=0.
-        do i=1,iim
-        zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
-        dyn1=dyn1+sinlondlon(i)*zz
-        dyn2=dyn2+coslondlon(i)*zz
-        zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
-        dys1=dys1+sinlondlon(i)*zz
-        dys2=dys2+coslondlon(i)*zz
-        enddo
-         do i=1,iim
-         q(i,1,llm+1-l,2)=
-     $   (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
-         q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)
-     $          +q(i,1,llm+1-l,2)
-         q(i,jjp1,llm+1-l,2)=
-     $   (sinlon(i)*dys1+coslon(i)*dys2)/2.
-         q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
-     $      -q(i,jjp1,llm+1-l,2)
-         enddo
-      q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
-      q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
-      do i=1,iim
-      sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
-      sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
-      enddo
-      sxn(iip1)=sxn(1)
-      sxs(iip1)=sxs(1)
-      do i=1,iim
-      q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
-      q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
-      END DO
-      q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
-      q(1,jjp1,llm+1-l,1)=
-     $   q(iip1,jjp1,llm+1-l,1)
-        enddo
-         do l=1,llm
-           do i=1,iim
-            q( i,1,llm+1-l,4)=0.
-            q( i,jjp1,llm+1-l,4)=0.
-            q( i,1,llm+1-l,5)=0.
-            q( i,jjp1,llm+1-l,5)=0.
-            q( i,1,llm+1-l,6)=0.
-            q( i,jjp1,llm+1-l,6)=0.
-            q( i,1,llm+1-l,7)=0.
-            q( i,jjp1,llm+1-l,7)=0.
-            q( i,1,llm+1-l,8)=0.
-            q( i,jjp1,llm+1-l,8)=0.
-            q( i,1,llm+1-l,9)=0.
-            q( i,jjp1,llm+1-l,9)=0.
-          enddo
-         ENDDO
-
-777      continue
-c
-c   bouclage en longitude
-      do l=1,llm
-      do j=1,jjp1
-      q(iip1,j,l,0)=q(1,j,l,0)
-      q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0)
-      q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1)
-      q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2)
-      q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3)
-      q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4)
-      q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5)
-      q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6)
-      q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7)
-      q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8)
-      q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9)
-      enddo
-      enddo
-        DO l = 1,llm
-    	 DO j = 2,jjm
-           DO i = 1,iip1
-         IF (q(i,j,l,0)<0.)  THEN
-         PRINT*,'------------ BIP-----------' 
-         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0),
-     $          q(i,j-1,l,0)
-         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
-         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2),
-     $   q(i,j-1,l,2)   
-         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
-c    		     PRINT*,' PBL EN SORTIE D'' ADVZP'
-                     q(i,j,l,0)=0.
-c                  STOP
-               ENDIF
-           ENDDO
-         ENDDO
-         do j=1,jjp1,jjm
-         do i=1,iip1
-               IF (q(i,j,l,0)<0.)  THEN
-               PRINT*,'------------ BIP 2-----------'
-         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0)
-         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
-         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2)
-         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
-
-                     q(i,j,l,0)=0.
-c                  STOP
-               ENDIF
-         enddo
-         enddo
-        ENDDO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.f90	(revision 5105)
@@ -0,0 +1,362 @@
+
+! $Header$
+
+SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
+
+  USE comconst_mod, ONLY: pi
+
+  IMPLICIT NONE
+
+  !=======================================================================
+  !   Adaptation LMDZ:  A.Armengaud (LGGE)
+  !   ----------------
+  !
+  !   ************************************************
+  !   Transport des traceurs par la methode de prather
+  !   Ref :
+  !
+  !   ************************************************
+  !   q,w,pext,pbaru et pbarv : arguments d'entree  pour le s-pg
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  !   Arguments:
+  !   ----------
+  INTEGER :: iq,nt
+  REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+  REAL :: masse(iip1,jjp1,llm)
+  REAL :: q( iip1,jjp1,llm,0:9)
+  REAL :: w( ip1jmp1,llm )
+  integer :: ordre,ilim
+
+  !   Local:
+  !   ------
+  LOGICAL :: limit
+  real :: zq(iip1,jjp1,llm)
+  REAL :: sm ( iip1,jjp1, llm )
+  REAL :: s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+  REAL :: sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+  REAL :: sxx( iip1,jjp1,llm)
+  REAL :: sxy( iip1,jjp1,llm)
+  REAL :: sxz( iip1,jjp1,llm)
+  REAL :: syy( iip1,jjp1,llm )
+  REAL :: syz( iip1,jjp1,llm )
+  REAL :: szz( iip1,jjp1,llm ),zz
+  INTEGER :: i,j,l,indice
+  real :: sxn(iip1),sxs(iip1)
+
+  real :: sinlon(iip1),sinlondlon(iip1)
+  real :: coslon(iip1),coslondlon(iip1)
+  real :: qmin,qmax
+  save qmin,qmax
+  save sinlon,coslon,sinlondlon,coslondlon
+  real :: dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps
+  real :: masn,mass
+  !
+  REAL :: SSUM
+  integer :: ismax,ismin
+  EXTERNAL  SSUM, ismin,ismax
+  logical :: first
+  save first
+  EXTERNAL advxp,advyp,advzp
+
+
+  data first/.TRUE./
+  data qmin,qmax/-1.e33,1.e33/
+
+
+  !==========================================================================
+  !==========================================================================
+  ! MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt
+  !==========================================================================
+  !==========================================================================
+  REAL :: dt
+  !==========================================================================
+  limit = .TRUE.
+
+  if(first) then
+     PRINT*,'SCHEMA PRATHER'
+     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)
+
+    DO l = 1,llm
+    DO j = 1,jjp1
+    DO i = 1,iip1
+    q( i,j,l,1 )=0.
+    q( i,j,l,2)=0.
+    q( i,j,l,3)=0.
+    q( i,j,l,4)=0.
+    q( i,j,l,5)=0.
+    q( i,j,l,6)=0.
+    q( i,j,l,7)=0.
+    q( i,j,l,8)=0.
+    q( i,j,l,9)=0.
+    ENDDO
+    ENDDO
+    ENDDO
+  endif
+  !   Fin modif Fred
+
+  ! *** On calcule la masse d'air en kg
+
+   DO l = 1,llm
+    DO j = 1,jjp1
+     DO i = 1,iip1
+     sm( i,j,llm+1-l ) =masse(i,j,l)
+     ENDDO
+    ENDDO
+   ENDDO
+
+  ! *** q contient les qqtes de traceur avant l'advection
+
+  ! *** Affectation des tableaux S a partir de Q
+
+   DO l = 1,llm
+    DO j = 1,jjp1
+     DO i = 1,iip1
+   s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l)
+   sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l)
+   sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l)
+   sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l)
+   sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l)
+   sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l)
+   sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l)
+   syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l)
+   syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l)
+   szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l)
+     ENDDO
+    ENDDO
+   ENDDO
+  ! *** Appel des subroutines d'advection en X, en Y et en Z
+  ! *** Advection avec "time-splitting"
+
+  !-----------------------------------------------------------
+   do indice =1,nt
+   CALL advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz &
+         ,sxx,sxy,sxz,syy,syz,szz,1 )
+    END DO
+    do l=1,llm
+    do i=1,iip1
+    sy(i,1,l)=0.
+    sy(i,jjp1,l)=0.
+    enddo
+    enddo
+  !---------------------------------------------------------
+   CALL advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz &
+         ,sxx,sxy,sxz,syy,syz,szz,1 )
+  !---------------------------------------------------------
+
+  !---------------------------------------------------------
+   do j=1,jjp1
+      do i=1,iip1
+         sz(i,j,1)=0.
+         sz(i,j,llm)=0.
+         sxz(i,j,1)=0.
+         sxz(i,j,llm)=0.
+         syz(i,j,1)=0.
+         syz(i,j,llm)=0.
+         szz(i,j,1)=0.
+         szz(i,j,llm)=0.
+      enddo
+   enddo
+   CALL advzp( limit,dt*nt,w,sm,s0,sx,sy,sz &
+         ,sxx,sxy,sxz,syy,syz,szz,1 )
+    do l=1,llm
+    do i=1,iip1
+    sy(i,1,l)=0.
+    sy(i,jjp1,l)=0.
+    enddo
+    enddo
+
+  !---------------------------------------------------------
+
+  !---------------------------------------------------------
+   CALL advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz &
+         ,sxx,sxy,sxz,syy,syz,szz,1 )
+  !---------------------------------------------------------
+   DO l = 1,llm
+    DO j = 1,jjp1
+         s0( iip1,j,l)=s0( 1,j,l )
+         sx( iip1,j,l)=sx( 1,j,l )
+         sy( iip1,j,l)=sy( 1,j,l )
+         sz( iip1,j,l)=sz( 1,j,l )
+         sxx( iip1,j,l)=sxx( 1,j,l )
+         sxy( iip1,j,l)=sxy( 1,j,l)
+         sxz( iip1,j,l)=sxz( 1,j,l )
+         syy( iip1,j,l)=syy( 1,j,l )
+         syz( iip1,j,l)=syz( 1,j,l)
+         szz( iip1,j,l)=szz( 1,j,l )
+    ENDDO
+   ENDDO
+   do indice=1,nt
+   CALL advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz &
+         ,sxx,sxy,sxz,syy,syz,szz,1 )
+    END DO
+  !---------------------------------------------------------
+  !---------------------------------------------------------
+  ! ***   On repasse les S dans la variable qpr
+  ! ***   On repasse les S dans la variable q directement 14/10/94
+
+   DO  l = 1,llm
+    DO  j = 1,jjp1
+     DO  i = 1,iip1
+  q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l)
+  q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l)
+  ENDDO
+  ENDDO
+  ENDDO
+
+  !---------------------------------------------------------
+   ! go to  777
+  !   filtrages aux poles
+
+  ! Traitements specifiques au pole
+
+  !   filtrages aux poles
+     DO l=1,llm
+  !   filtrages aux poles
+     masn=ssum(iim,sm(1,1,l),1)
+     mass=ssum(iim,sm(1,jjp1,l),1)
+     qpn=ssum(iim,s0(1,1,l),1)/masn
+     qps=ssum(iim,s0(1,jjp1,l),1)/mass
+     dqzpn=ssum(iim,sz(1,1,l),1)/masn
+     dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+     do i=1,iip1
+      q( i,1,llm+1-l,3)=dqzpn
+      q( i,jjp1,llm+1-l,3)=dqzps
+      q( i,1,llm+1-l,0)=qpn
+      q( i,jjp1,llm+1-l,0)=qps
+     enddo
+    ! enddo
+    !   PRINT*,'qpn',qpn,'qps',qps
+    !    PRINT*,'dqzpn',dqzpn,'dqzps',dqzps
+    ! enddo
+       dyn1=0.
+       dys1=0.
+       dyn2=0.
+       dys2=0.
+    do i=1,iim
+    zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+    dyn1=dyn1+sinlondlon(i)*zz
+    dyn2=dyn2+coslondlon(i)*zz
+    zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+    dys1=dys1+sinlondlon(i)*zz
+    dys2=dys2+coslondlon(i)*zz
+    enddo
+     do i=1,iim
+     q(i,1,llm+1-l,2)= &
+           (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+     q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0) &
+           +q(i,1,llm+1-l,2)
+     q(i,jjp1,llm+1-l,2)= &
+           (sinlon(i)*dys1+coslon(i)*dys2)/2.
+     q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) &
+           -q(i,jjp1,llm+1-l,2)
+     enddo
+  q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+  q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+  do i=1,iim
+  sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+  sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+  enddo
+  sxn(iip1)=sxn(1)
+  sxs(iip1)=sxs(1)
+  do i=1,iim
+  q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+  q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+  END DO
+  q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+  q(1,jjp1,llm+1-l,1)= &
+        q(iip1,jjp1,llm+1-l,1)
+    enddo
+     do l=1,llm
+       do i=1,iim
+        q( i,1,llm+1-l,4)=0.
+        q( i,jjp1,llm+1-l,4)=0.
+        q( i,1,llm+1-l,5)=0.
+        q( i,jjp1,llm+1-l,5)=0.
+        q( i,1,llm+1-l,6)=0.
+        q( i,jjp1,llm+1-l,6)=0.
+        q( i,1,llm+1-l,7)=0.
+        q( i,jjp1,llm+1-l,7)=0.
+        q( i,1,llm+1-l,8)=0.
+        q( i,jjp1,llm+1-l,8)=0.
+        q( i,1,llm+1-l,9)=0.
+        q( i,jjp1,llm+1-l,9)=0.
+      enddo
+     ENDDO
+
+777   continue
+  !
+  !   bouclage en longitude
+  do l=1,llm
+  do j=1,jjp1
+  q(iip1,j,l,0)=q(1,j,l,0)
+  q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0)
+  q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1)
+  q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2)
+  q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3)
+  q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4)
+  q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5)
+  q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6)
+  q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7)
+  q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8)
+  q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9)
+  enddo
+  enddo
+    DO l = 1,llm
+     DO j = 2,jjm
+       DO i = 1,iip1
+     IF (q(i,j,l,0)<0.)  THEN
+     PRINT*,'------------ BIP-----------'
+     PRINT*,'S0(',i,j,l,')=',q(i,j,l,0), &
+           q(i,j-1,l,0)
+     PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+     PRINT*,'SY(',i,j,l,')=',q(i,j,l,2), &
+           q(i,j-1,l,2)
+     PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+  !    		     PRINT*,' PBL EN SORTIE D'' ADVZP'
+                 q(i,j,l,0)=0.
+               ! STOP
+           ENDIF
+       ENDDO
+     ENDDO
+     do j=1,jjp1,jjm
+     do i=1,iip1
+           IF (q(i,j,l,0)<0.)  THEN
+           PRINT*,'------------ BIP 2-----------'
+     PRINT*,'S0(',i,j,l,')=',q(i,j,l,0)
+     PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+     PRINT*,'SY(',i,j,l,')=',q(i,j,l,2)
+     PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+
+                 q(i,j,l,0)=0.
+               ! STOP
+           ENDIF
+     enddo
+     enddo
+    ENDDO
+  RETURN
+END SUBROUTINE prather
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.F	(revision 5104)
+++ 	(revision )
@@ -1,107 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE psextbar ( ps, psexbarxy )
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c **********************************************************************
-c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
-c **********************************************************************
-c
-c         ps          est un  argum. d'entree  pour le s-pg ..
-c         psexbarxy   est un  argum. de sortie pour le s-pg ..
-c
-c   Methode:
-c   --------
-c
-c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
-c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
-c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
-c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
-c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
-c
-c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
-c
-c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
-c
-c
-c
-c   alpha4 .         . alpha1    . alpha4
-c    (i,j)             (i,j)       (i+1,j)
-c
-c             P .        U .          . P
-c           (i,j)       (i,j)         (i+1,j)
-c
-c   alpha3 .         . alpha2    .alpha3 
-c    (i,j)              (i,j)     (i+1,j)
-c
-c             V .        Z .          . V
-c           (i,j)
-c
-c   alpha4 .         . alpha1    .alpha4
-c   (i,j+1)            (i,j+1)   (i+1,j+1) 
-c
-c             P .        U .          . P
-c          (i,j+1)                    (i+1,j+1)
-c
-c
-c
-c
-c                       On  a :
-c
-c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
-c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-c     localise  au point  ... U (i,j) ...
-c
-c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
-c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-c     localise  au point  ... V (i,j) ...
-c
-c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
-c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
-c     localise  au point  ... Z (i,j) ...
-c
-c
-c
-c=======================================================================
-
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )
-
-      INTEGER  l, ij
-c
-
-      DO ij = 1, ip1jmp1
-       pext(ij) = ps(ij) * aire(ij)
-      ENDDO
-
-
-      DO     ij = 1, ip1jm - 1
-      psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
-     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
-      END DO
-
-
-c    ....  correction pour     psexbarxy( iip1,j )  ........
-
-CDIR$ IVDEP
-
-      DO ij = iip1, ip1jm, iip1
-      psexbarxy( ij ) = psexbarxy( ij - iim )
-      END DO
-
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.f90	(revision 5105)
@@ -0,0 +1,107 @@
+
+! $Header$
+
+SUBROUTINE psextbar ( ps, psexbarxy )
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  ! **********************************************************************
+  ! calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+  ! **********************************************************************
+  !
+  !     ps          est un  argum. d'entree  pour le s-pg ..
+  !     psexbarxy   est un  argum. de sortie pour le s-pg ..
+  !
+  !   Methode:
+  !   --------
+  !
+  !    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+  !   alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+  !   alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+  !   alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+  !   alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+  !
+  !    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+  !
+  !    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+  !
+  !
+  !
+  !   alpha4 .         . alpha1    . alpha4
+  !    (i,j)             (i,j)       (i+1,j)
+  !
+  !         P .        U .          . P
+  !       (i,j)       (i,j)         (i+1,j)
+  !
+  !   alpha3 .         . alpha2    .alpha3
+  !    (i,j)              (i,j)     (i+1,j)
+  !
+  !         V .        Z .          . V
+  !       (i,j)
+  !
+  !   alpha4 .         . alpha1    .alpha4
+  !   (i,j+1)            (i,j+1)   (i+1,j+1)
+  !
+  !         P .        U .          . P
+  !      (i,j+1)                    (i+1,j+1)
+  !
+  !
+  !
+  !
+  !                   On  a :
+  !
+  !    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+  !             Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+  ! localise  au point  ... U (i,j) ...
+  !
+  !    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+  !             Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
+  ! localise  au point  ... V (i,j) ...
+  !
+  !  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+  !           Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+  ! localise  au point  ... Z (i,j) ...
+  !
+  !
+  !
+  !=======================================================================
+
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  REAL :: ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )
+
+  INTEGER :: l, ij
+  !
+
+  DO ij = 1, ip1jmp1
+   pext(ij) = ps(ij) * aire(ij)
+  ENDDO
+
+
+  DO     ij = 1, ip1jm - 1
+  psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + &
+        pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+  END DO
+
+
+  !    ....  correction pour     psexbarxy( iip1,j )  ........
+
+  !DIR$ IVDEP
+
+  DO ij = iip1, ip1jm, iip1
+  psexbarxy( ij ) = psexbarxy( ij - iim )
+  END DO
+
+
+  RETURN
+END SUBROUTINE psextbar
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.F	(revision 5104)
+++ 	(revision )
@@ -1,58 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE rotat (klevel, x, y, rot )
-c
-c     Auteur : P.Le Van 
-c**************************************************************
-c.  calcule le rotationnel
-c     a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ip1jm,klevel )
-      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-c
-c
-      DO  l = 1,klevel
-c
-        DO   ij = 1, ip1jm - 1
-         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
-     *                   x(ij +iip1, l )  -  x( ij,l )  
-        ENDDO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-        DO  ij = iip1, ip1jm, iip1
-         rot( ij,l ) = rot( ij -iim,l )
-        ENDDO
-c
-      END DO
-
-ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
-      
-        DO l = 1, klevel
-          DO ij = 1, ip1jm
-           rot(ij,l) = rot(ij,l) * unsairez(ij)
-          ENDDO
-        ENDDO
-c
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.f90	(revision 5105)
@@ -0,0 +1,58 @@
+
+! $Header$
+
+SUBROUTINE rotat (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  !
+  !
+  DO  l = 1,klevel
+  !
+    DO   ij = 1, ip1jm - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = iip1, ip1jm, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+
+  !cc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+
+    DO l = 1, klevel
+      DO ij = 1, ip1jm
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+  !
+  !
+  RETURN
+END SUBROUTINE rotat
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.F	(revision 5104)
+++ 	(revision )
@@ -1,49 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE rotat_nfil (klevel, x, y, rot )
-c
-c    Auteur :   P.Le Van 
-c**************************************************************
-c.          Calcule le rotationnel  non filtre   ,
-c      a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ip1jm,klevel )
-      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-c
-c
-      DO  l = 1,klevel
-c
-        DO   ij = 1, ip1jm - 1
-         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
-     *                   x(ij +iip1, l )  -  x( ij,l )  
-        ENDDO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-        DO  ij = iip1, ip1jm, iip1
-         rot( ij,l ) = rot( ij -iim,l )
-        ENDDO
-c
-      END DO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.f90	(revision 5105)
@@ -0,0 +1,49 @@
+
+! $Header$
+
+SUBROUTINE rotat_nfil (klevel, x, y, rot )
+  !
+  !    Auteur :   P.Le Van
+  !**************************************************************
+  !.          Calcule le rotationnel  non filtre   ,
+  !  a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  !
+  !
+  DO  l = 1,klevel
+  !
+    DO   ij = 1, ip1jm - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = iip1, ip1jm, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+
+  RETURN
+END SUBROUTINE rotat_nfil
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.F	(revision 5104)
+++ 	(revision )
@@ -1,59 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE rotatf (klevel, x, y, rot )
-c
-c     Auteur : P.Le Van 
-c**************************************************************
-c.  calcule le rotationnel
-c     a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c     Only difference with rotat: CALL to filtreg.
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ip1jm,klevel )
-      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-c
-c
-      DO  l = 1,klevel
-c
-        DO   ij = 1, ip1jm - 1
-         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
-     *                   x(ij +iip1, l )  -  x( ij,l )  
-        ENDDO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-        DO  ij = iip1, ip1jm, iip1
-         rot( ij,l ) = rot( ij -iim,l )
-        ENDDO
-c
-      END DO
-
-        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
-      
-        DO l = 1, klevel
-          DO ij = 1, ip1jm
-           rot(ij,l) = rot(ij,l) * unsairez(ij)
-          ENDDO
-        ENDDO
-c
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.f90	(revision 5105)
@@ -0,0 +1,59 @@
+
+! $Header$
+
+SUBROUTINE rotatf (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  ! Only difference with rotat: CALL to filtreg.
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  !
+  !
+  DO  l = 1,klevel
+  !
+    DO   ij = 1, ip1jm - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = iip1, ip1jm, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+
+    CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+
+    DO l = 1, klevel
+      DO ij = 1, ip1jm
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+  !
+  !
+  RETURN
+END SUBROUTINE rotatf
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.F	(revision 5104)
+++ 	(revision )
@@ -1,43 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE rotatst (klevel,x, y, rot )
-c
-c  P. Le Van
-c
-c    *****************************************************************
-c     .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y ..
-c         x  et  y etant des composantes  covariantes  .....
-c    *****************************************************************
-c        x  et y     sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      IMPLICIT NONE
-c
-      INTEGER klevel
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-
-      REAL rot( ip1jm,klevel )
-      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
-      INTEGER  l, ij
-c
-c
-      DO l = 1,klevel
-c
-      DO ij = 1, ip1jm - 1
-      rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   +
-     *                 x(ij +iip1, l )  -  x( ij,l )  )
-      END DO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-      DO ij = iip1, ip1jm, iip1
-      rot( ij,l ) = rot( ij -iim,l )
-      END DO
-c
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.f90	(revision 5105)
@@ -0,0 +1,43 @@
+
+! $Header$
+
+SUBROUTINE rotatst (klevel,x, y, rot )
+  !
+  !  P. Le Van
+  !
+  !    *****************************************************************
+  ! .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y ..
+  !     x  et  y etant des composantes  covariantes  .....
+  !    *****************************************************************
+  !    x  et y     sont des arguments d'entree pour le s-prog
+  !    rot          est  un argument  de sortie pour le s-prog
+  !
+  IMPLICIT NONE
+  !
+  INTEGER :: klevel
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  INTEGER :: l, ij
+  !
+  !
+  DO l = 1,klevel
+  !
+  DO ij = 1, ip1jm - 1
+  rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   + &
+        x(ij +iip1, l )  -  x( ij,l )  )
+  END DO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+  DO ij = iip1, ip1jm, iip1
+  rot( ij,l ) = rot( ij -iim,l )
+  END DO
+  !
+  END DO
+  RETURN
+END SUBROUTINE rotatst
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.F	(revision 5104)
+++ 	(revision )
@@ -1,202 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE sortvarc
-     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
-     $ vcov )
-
-      USE control_mod, ONLY: resetvarc 
-      USE comconst_mod, ONLY: dtvr, daysec, g, rad, omeg
-      USE logic_mod, ONLY: read_start
-      USE ener_mod, ONLY: etot,ptot,ztot,stot,ang,
-     &                    etot0,ptot0,ztot0,stot0,ang0,
-     &                    rmsdpdt,rmsv
-      IMPLICIT NONE
-
-
-c=======================================================================
-c
-c   Auteur:    P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   sortie des variables de controle
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INCLUDE "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER,INTENT(IN) :: itau
-      REAL,INTENT(IN) :: ucov(ip1jmp1,llm)
-      REAL,INTENT(IN) :: teta(ip1jmp1,llm)
-      REAL,INTENT(IN) :: masse(ip1jmp1,llm)
-      REAL,INTENT(IN) :: vcov(ip1jm,llm)
-      REAL,INTENT(IN) :: ps(ip1jmp1)
-      REAL,INTENT(IN) :: phis(ip1jmp1)
-      REAL,INTENT(IN) :: vorpot(ip1jm,llm)
-      REAL,INTENT(IN) :: phi(ip1jmp1,llm)
-      REAL,INTENT(IN) :: bern(ip1jmp1,llm)
-      REAL,INTENT(IN) :: dp(ip1jmp1)
-      REAL,INTENT(IN) :: time
-      REAL,INTENT(IN) :: pk(ip1jmp1,llm)
-
-c   Local:
-c   ------
-
-      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
-      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
-      REAL cosphi(ip1jm),omegcosp(ip1jm)
-      REAL dtvrs1j,rjour,heure,radsg,radomeg
-      REAL massebxy(ip1jm,llm)
-      INTEGER  l, ij, imjmp1
-
-      REAL       SSUM
-      LOGICAL,SAVE :: firstcal=.TRUE.
-      CHARACTER(LEN=*),PARAMETER :: modname="sortvarc"
-
-c-----------------------------------------------------------------------
-! Ehouarn: when no initialization fields from file, resetvarc should be
-!          set to false
-       if (firstcal) then
-         if (.not.read_start) then
-           resetvarc=.TRUE.
-         endif
-       endif
-
-       dtvrs1j   = dtvr/daysec
-       rjour     = REAL( INT( itau * dtvrs1j ))
-       heure     = ( itau*dtvrs1j-rjour ) * 24.
-       imjmp1    = iim * jjp1
-       IF(ABS(heure - 24.)<=0.0001 ) heure = 0.
-c
-       CALL massbarxy ( masse, massebxy )
-
-c   .....  Calcul  de  rmsdpdt  .....
-
-       ge(:)=dp(:)*dp(:)
-
-       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
-c
-       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
-
-       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
-       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
-
-c   .....  Calcul du moment  angulaire   .....
-
-       radsg    = rad /g
-       radomeg  = rad * omeg
-c
-       DO ij=iip2,ip1jm
-          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
-          omegcosp(ij) = radomeg   * cosphi(ij)
-       ENDDO
-
-c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
-
-       DO l=1,llm
-          DO ij = 1,ip1jm
-             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
-          ENDDO
-          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
-
-          DO ij = 1,ip1jmp1
-             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
-     s        bernf(ij,l)-phi(ij,l))
-          ENDDO
-          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
-
-          DO   ij   = 1, ip1jmp1
-             ge(ij) = masse(ij,l)*teta(ij,l)
-          ENDDO
-          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
-
-          DO ij=1,ip1jmp1
-             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
-          ENDDO
-          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
-
-          DO ij =iip2,ip1jm
-             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
-     *               cosphi(ij)
-          ENDDO
-          angl(l) = rad *
-     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
-      ENDDO
-
-          DO ij=1,ip1jmp1
-            ge(ij)= ps(ij)*aire(ij)
-          ENDDO
-      ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
-      etot  = SSUM(     llm, etotl, 1 )
-      ztot  = SSUM(     llm, ztotl, 1 )
-      stot  = SSUM(     llm, stotl, 1 )
-      rmsv  = SSUM(     llm, rmsvl, 1 )
-      ang   = SSUM(     llm,  angl, 1 )
-
-      IF (firstcal.and.resetvarc) then
-         WRITE(lunout,3500) itau, rjour, heure, time
-         WRITE(lunout,*) trim(modname),
-     &     ' WARNING!!! Recomputing initial values of : '
-         WRITE(lunout,*) 'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
-         WRITE(lunout,*) ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
-         etot0 = etot
-         ptot0 = ptot
-         ztot0 = ztot
-         stot0 = stot
-         ang0  = ang
-      END IF
-
-      ! compute relative changes in etot,... (except if 'reference' values
-      ! are zero, which can happen when using iniacademic)
-      if (etot0/=0) then
-        etot= etot/etot0
-      else
-        etot=1.
-      endif
-      rmsv= SQRT(rmsv/ptot)
-      if (ptot0/=0) then
-        ptot= ptot/ptot0
-      else
-        ptot=1.
-      endif
-      if (ztot0/=0) then
-        ztot= ztot/ztot0
-      else
-        ztot=1.
-      endif
-      if (stot0/=0) then
-        stot= stot/stot0
-      else
-        stot=1.
-      endif
-      if (ang0/=0) then
-        ang = ang /ang0
-      else
-        ang=1.
-      endif
-
-      firstcal = .FALSE.
-
-      WRITE(lunout,3500) itau, rjour, heure, time
-      WRITE(lunout,4000) ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
-
-3500   FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x 
-     *   ,'date',f14.4,4x,10("*"))
-4000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie'
-     * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB  '
-     .  ,f10.6,e13.6,5f10.3/
-     * )
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.f90	(revision 5105)
@@ -0,0 +1,202 @@
+
+! $Id$
+
+SUBROUTINE sortvarc &
+        (itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , &
+        vcov )
+
+  USE control_mod, ONLY: resetvarc
+  USE comconst_mod, ONLY: dtvr, daysec, g, rad, omeg
+  USE logic_mod, ONLY: read_start
+  USE ener_mod, ONLY: etot,ptot,ztot,stot,ang, &
+        etot0,ptot0,ztot0,stot0,ang0, &
+        rmsdpdt,rmsv
+  IMPLICIT NONE
+
+
+  !=======================================================================
+  !
+  !   Auteur:    P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   sortie des variables de controle
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER,INTENT(IN) :: itau
+  REAL,INTENT(IN) :: ucov(ip1jmp1,llm)
+  REAL,INTENT(IN) :: teta(ip1jmp1,llm)
+  REAL,INTENT(IN) :: masse(ip1jmp1,llm)
+  REAL,INTENT(IN) :: vcov(ip1jm,llm)
+  REAL,INTENT(IN) :: ps(ip1jmp1)
+  REAL,INTENT(IN) :: phis(ip1jmp1)
+  REAL,INTENT(IN) :: vorpot(ip1jm,llm)
+  REAL,INTENT(IN) :: phi(ip1jmp1,llm)
+  REAL,INTENT(IN) :: bern(ip1jmp1,llm)
+  REAL,INTENT(IN) :: dp(ip1jmp1)
+  REAL,INTENT(IN) :: time
+  REAL,INTENT(IN) :: pk(ip1jmp1,llm)
+
+  !   Local:
+  !   ------
+
+  REAL :: vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+  REAL :: etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+  REAL :: cosphi(ip1jm),omegcosp(ip1jm)
+  REAL :: dtvrs1j,rjour,heure,radsg,radomeg
+  REAL :: massebxy(ip1jm,llm)
+  INTEGER :: l, ij, imjmp1
+
+  REAL :: SSUM
+  LOGICAL,SAVE :: firstcal=.TRUE.
+  CHARACTER(LEN=*),PARAMETER :: modname="sortvarc"
+
+  !-----------------------------------------------------------------------
+  ! Ehouarn: when no initialization fields from file, resetvarc should be
+       ! set to false
+   if (firstcal) then
+     if (.not.read_start) then
+       resetvarc=.TRUE.
+     endif
+   endif
+
+   dtvrs1j   = dtvr/daysec
+   rjour     = REAL( INT( itau * dtvrs1j ))
+   heure     = ( itau*dtvrs1j-rjour ) * 24.
+   imjmp1    = iim * jjp1
+   IF(ABS(heure - 24.)<=0.0001 ) heure = 0.
+  !
+   CALL massbarxy ( masse, massebxy )
+
+  !   .....  Calcul  de  rmsdpdt  .....
+
+   ge(:)=dp(:)*dp(:)
+
+   rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+  !
+   rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1)
+
+   CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+   CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+  !   .....  Calcul du moment  angulaire   .....
+
+   radsg    = rad /g
+   radomeg  = rad * omeg
+  !
+   DO ij=iip2,ip1jm
+      cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+      omegcosp(ij) = radomeg   * cosphi(ij)
+   ENDDO
+
+  !  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+   DO l=1,llm
+      DO ij = 1,ip1jm
+         vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+      ENDDO
+      ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+      DO ij = 1,ip1jmp1
+         ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  + &
+               bernf(ij,l)-phi(ij,l))
+      ENDDO
+      etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+      DO   ij   = 1, ip1jmp1
+         ge(ij) = masse(ij,l)*teta(ij,l)
+      ENDDO
+      stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+      DO ij=1,ip1jmp1
+         ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+      ENDDO
+      rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+      DO ij =iip2,ip1jm
+         ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * &
+               cosphi(ij)
+      ENDDO
+      angl(l) = rad * &
+            (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+  ENDDO
+
+      DO ij=1,ip1jmp1
+        ge(ij)= ps(ij)*aire(ij)
+      ENDDO
+  ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+  etot  = SSUM(     llm, etotl, 1 )
+  ztot  = SSUM(     llm, ztotl, 1 )
+  stot  = SSUM(     llm, stotl, 1 )
+  rmsv  = SSUM(     llm, rmsvl, 1 )
+  ang   = SSUM(     llm,  angl, 1 )
+
+  IF (firstcal.and.resetvarc) then
+     WRITE(lunout,3500) itau, rjour, heure, time
+     WRITE(lunout,*) trim(modname), &
+           ' WARNING!!! Recomputing initial values of : '
+     WRITE(lunout,*) 'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
+     WRITE(lunout,*) ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+     etot0 = etot
+     ptot0 = ptot
+     ztot0 = ztot
+     stot0 = stot
+     ang0  = ang
+  END IF
+
+  ! ! compute relative changes in etot,... (except if 'reference' values
+  ! ! are zero, which can happen when using iniacademic)
+  if (etot0/=0) then
+    etot= etot/etot0
+  else
+    etot=1.
+  endif
+  rmsv= SQRT(rmsv/ptot)
+  if (ptot0/=0) then
+    ptot= ptot/ptot0
+  else
+    ptot=1.
+  endif
+  if (ztot0/=0) then
+    ztot= ztot/ztot0
+  else
+    ztot=1.
+  endif
+  if (stot0/=0) then
+    stot= stot/stot0
+  else
+    stot=1.
+  endif
+  if (ang0/=0) then
+    ang = ang /ang0
+  else
+    ang=1.
+  endif
+
+  firstcal = .FALSE.
+
+  WRITE(lunout,3500) itau, rjour, heure, time
+  WRITE(lunout,4000) ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+
+3500   FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x &
+             ,'date',f14.4,4x,10("*"))
+4000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie' &
+             ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB  ' &
+             ,f10.6,e13.6,5f10.3/ &
+             )
+END SUBROUTINE sortvarc
+
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.F	(revision 5104)
+++ 	(revision )
@@ -1,116 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
-c
-c     Auteur : P. Le Van  
-c    ---------
-c  ....  Cette routine teste la periodicite en longitude des champs   ucov,
-c                           teta, q , p et phis                 .......... 
-c
-      USE infotrac, ONLY: nqtot
-c
-c     IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-c
-c    ......  Arguments   ......
-c
-      REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) ,
-     ,      q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1)
-c
-c   .....  Variables  locales  .....
-c
-      INTEGER ij,l,nq
-c
-      DO l = 1, llm
-         DO ij = 1, ip1jmp1, iip1
-          IF( ucov(ij,l)/=ucov(ij+iim,l) )  THEN
-          PRINT *,'STOP dans test_period car ---  UCOV  ---  n est pas',  
-     ,  ' periodique en longitude ! '
-          PRINT *,' l,  ij = ', l, ij, ij+iim
-          STOP
-          ENDIF
-          IF( teta(ij,l)/=teta(ij+iim,l) )  THEN
-          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
-     ,   ' periodique en longitude ! '
-          PRINT *,' l,  ij = ', l, ij, ij+iim
-     ,      , teta(ij,l),   teta(ij+iim,l)
-          STOP
-          ENDIF
-         ENDDO
-
-         do ij=1,iim
-          if (teta(ij,l)/=teta(1,l)
-     s     .or.teta(ip1jm+ij,l)/=teta(ip1jm+1,l) ) then
-          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
-     ,  ' constant aux poles ! '
-          PRINT*,'teta(',1 ,',',l,')=',teta(1 ,l)
-          PRINT*,'teta(',ij,',',l,')=',teta(ij,l)
-          PRINT*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l)
-          PRINT*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l)
-          stop
-          endif
-         enddo
-      ENDDO
-
-c
-      DO l = 1, llm
-         DO ij = 1, ip1jm, iip1
-          IF( vcov(ij,l)/=vcov(ij+iim,l) )  THEN
-          PRINT *,'STOP dans test_period car ---  VCOV  ---  n est pas',  
-     ,   ' periodique en longitude !'
-          PRINT *,' l,  ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l)
-          vcov(ij+iim,l)=vcov(ij,l)
-c         STOP
-          ENDIF
-         ENDDO
-      ENDDO
-      
-c
-      DO nq =1, nqtot
-        DO l =1, llm
-          DO ij = 1, ip1jmp1, iip1
-          IF( q(ij,l,nq)/=q(ij+iim,l,nq) )  THEN
-          PRINT *,'STOP dans test_period car ---  Q  ---  n est pas ',  
-     ,   'periodique en longitude !'
-          PRINT *,' nq , l,  ij = ', nq, l, ij, ij+iim
-          STOP
-          ENDIF
-          ENDDO
-        ENDDO
-      ENDDO
-c
-       DO l = 1, llm
-         DO ij = 1, ip1jmp1, iip1
-          IF( p(ij,l)/=p(ij+iim,l) )  THEN
-          PRINT *,'STOP dans test_period car ---  P  ---  n est pas',  
-     ,    ' periodique en longitude !'
-          PRINT *,' l ij = ',l, ij, ij+iim
-          STOP
-          ENDIF
-          IF( phis(ij)/=phis(ij+iim) )  THEN
-          PRINT *,'STOP dans test_period car ---  PHIS  ---  n est pas',  
-     ,   ' periodique en longitude !  l, IJ = ', l, ij,ij+iim
-          PRINT *,' ij = ', ij, ij+iim
-          STOP
-          ENDIF
-         ENDDO
-         do ij=1,iim
-          if (p(ij,l)/=p(1,l)
-     s     .or.p(ip1jm+ij,l)/=p(ip1jm+1,l) ) then
-          PRINT *,'STOP dans test_period car ---  P     ---  n est pas',  
-     ,  ' constant aux poles ! '
-          PRINT*,'p(',1 ,',',l,')=',p(1 ,l)
-          PRINT*,'p(',ij,',',l,')=',p(ij,l)
-          PRINT*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l)
-          PRINT*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l)
-          stop
-          endif
-         enddo
-       ENDDO
-c
-c
-         RETURN
-         END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.f90	(revision 5105)
@@ -0,0 +1,116 @@
+
+! $Header$
+
+SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
+  !
+  ! Auteur : P. Le Van
+  !    ---------
+  !  ....  Cette routine teste la periodicite en longitude des champs   ucov,
+  !                       teta, q , p et phis                 ..........
+  !
+  USE infotrac, ONLY: nqtot
+  !
+  ! IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  !
+  !    ......  Arguments   ......
+  !
+  REAL :: ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) , &
+        q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1)
+  !
+  !   .....  Variables  locales  .....
+  !
+  INTEGER :: ij,l,nq
+  !
+  DO l = 1, llm
+     DO ij = 1, ip1jmp1, iip1
+      IF( ucov(ij,l)/=ucov(ij+iim,l) )  THEN
+      PRINT *,'STOP dans test_period car ---  UCOV  ---  n est pas', &
+            ' periodique en longitude ! '
+      PRINT *,' l,  ij = ', l, ij, ij+iim
+      STOP
+      ENDIF
+      IF( teta(ij,l)/=teta(ij+iim,l) )  THEN
+      PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas', &
+            ' periodique en longitude ! '
+      PRINT *,' l,  ij = ', l, ij, ij+iim &
+            , teta(ij,l),   teta(ij+iim,l)
+      STOP
+      ENDIF
+     ENDDO
+
+     do ij=1,iim
+      if (teta(ij,l)/=teta(1,l) &
+            .or.teta(ip1jm+ij,l)/=teta(ip1jm+1,l) ) then
+      PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas', &
+            ' constant aux poles ! '
+      PRINT*,'teta(',1 ,',',l,')=',teta(1 ,l)
+      PRINT*,'teta(',ij,',',l,')=',teta(ij,l)
+      PRINT*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l)
+      PRINT*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l)
+      stop
+      endif
+     enddo
+  ENDDO
+
+  !
+  DO l = 1, llm
+     DO ij = 1, ip1jm, iip1
+      IF( vcov(ij,l)/=vcov(ij+iim,l) )  THEN
+      PRINT *,'STOP dans test_period car ---  VCOV  ---  n est pas', &
+            ' periodique en longitude !'
+      PRINT *,' l,  ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l)
+      vcov(ij+iim,l)=vcov(ij,l)
+      ! STOP
+      ENDIF
+     ENDDO
+  ENDDO
+
+  !
+  DO nq =1, nqtot
+    DO l =1, llm
+      DO ij = 1, ip1jmp1, iip1
+      IF( q(ij,l,nq)/=q(ij+iim,l,nq) )  THEN
+      PRINT *,'STOP dans test_period car ---  Q  ---  n est pas ', &
+            'periodique en longitude !'
+      PRINT *,' nq , l,  ij = ', nq, l, ij, ij+iim
+      STOP
+      ENDIF
+      ENDDO
+    ENDDO
+  ENDDO
+  !
+   DO l = 1, llm
+     DO ij = 1, ip1jmp1, iip1
+      IF( p(ij,l)/=p(ij+iim,l) )  THEN
+      PRINT *,'STOP dans test_period car ---  P  ---  n est pas', &
+            ' periodique en longitude !'
+      PRINT *,' l ij = ',l, ij, ij+iim
+      STOP
+      ENDIF
+      IF( phis(ij)/=phis(ij+iim) )  THEN
+      PRINT *,'STOP dans test_period car ---  PHIS  ---  n est pas', &
+            ' periodique en longitude !  l, IJ = ', l, ij,ij+iim
+      PRINT *,' ij = ', ij, ij+iim
+      STOP
+      ENDIF
+     ENDDO
+     do ij=1,iim
+      if (p(ij,l)/=p(1,l) &
+            .or.p(ip1jm+ij,l)/=p(ip1jm+1,l) ) then
+      PRINT *,'STOP dans test_period car ---  P     ---  n est pas', &
+            ' constant aux poles ! '
+      PRINT*,'p(',1 ,',',l,')=',p(1 ,l)
+      PRINT*,'p(',ij,',',l,')=',p(ij,l)
+      PRINT*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l)
+      PRINT*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l)
+      stop
+      endif
+     enddo
+   ENDDO
+  !
+  !
+     RETURN
+END SUBROUTINE test_period
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.F	(revision 5104)
+++ 	(revision )
@@ -1,62 +1,0 @@
-
-! $Id$
-
-          SUBROUTINE traceurpole(q,masse)
-
-          implicit none
-      
-      include "dimensions.h"
-      include "paramet.h"
-      include "comdissip.h"
-      include "comgeom2.h"
-      include "description.h"
-
-
-c   Arguments
-       integer iq
-       real masse(iip1,jjp1,llm)
-       real q(iip1,jjp1,llm)
-       
-
-c   Locals
-      integer i,j,l
-      real sommemassen(llm)
-      real sommemqn(llm)
-      real sommemasses(llm)
-      real sommemqs(llm)
-      real qpolen(llm),qpoles(llm)
-
-    
-c On impose une seule valeur au pôle Sud j=jjm+1=jjp1
-      sommemasses=0
-      sommemqs=0
-          do l=1,llm
-             do i=1,iip1          
-                 sommemasses(l)=sommemasses(l)+masse(i,jjp1,l)
-                 sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l)
-             enddo         
-          qpoles(l)=sommemqs(l)/sommemasses(l)
-          enddo
-
-c On impose une seule valeur du traceur au pôle Nord j=1
-      sommemassen=0
-      sommemqn=0  
-         do l=1,llm
-           do i=1,iip1              
-               sommemassen(l)=sommemassen(l)+masse(i,1,l)
-               sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l)
-           enddo
-           qpolen(l)=sommemqn(l)/sommemassen(l) 
-         enddo
-    
-c On force le traceur à prendre cette valeur aux pôles
-        do l=1,llm
-            do i=1,iip1
-               q(i,1,l)=qpolen(l)
-               q(i,jjp1,l)=qpoles(l)
-             enddo
-        enddo
-
-      
-      return
-      end           
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.f90	(revision 5105)
@@ -0,0 +1,62 @@
+
+! $Id$
+
+    SUBROUTINE traceurpole(q,masse)
+
+      implicit none
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissip.h"
+  include "comgeom2.h"
+  include "description.h"
+
+
+  !   Arguments
+   integer :: iq
+   real :: masse(iip1,jjp1,llm)
+   real :: q(iip1,jjp1,llm)
+
+
+  !   Locals
+  integer :: i,j,l
+  real :: sommemassen(llm)
+  real :: sommemqn(llm)
+  real :: sommemasses(llm)
+  real :: sommemqs(llm)
+  real :: qpolen(llm),qpoles(llm)
+
+
+  ! On impose une seule valeur au pôle Sud j=jjm+1=jjp1
+  sommemasses=0
+  sommemqs=0
+      do l=1,llm
+         do i=1,iip1
+             sommemasses(l)=sommemasses(l)+masse(i,jjp1,l)
+             sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l)
+         enddo
+      qpoles(l)=sommemqs(l)/sommemasses(l)
+      enddo
+
+  ! On impose une seule valeur du traceur au pôle Nord j=1
+  sommemassen=0
+  sommemqn=0
+     do l=1,llm
+       do i=1,iip1
+           sommemassen(l)=sommemassen(l)+masse(i,1,l)
+           sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l)
+       enddo
+       qpolen(l)=sommemqn(l)/sommemassen(l)
+     enddo
+
+  ! On force le traceur à prendre cette valeur aux pôles
+    do l=1,llm
+        do i=1,iip1
+           q(i,1,l)=qpolen(l)
+           q(i,jjp1,l)=qpoles(l)
+         enddo
+    enddo
+
+
+  return
+end subroutine traceurpole
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/write_grads_dyn.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/write_grads_dyn.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/write_grads_dyn.h	(revision 5105)
@@ -2,30 +2,30 @@
 ! $Header$
 
-      if (callinigrads) then
+if (callinigrads) then
 
-         string10='dyn'
-         CALL inigrads(1,iip1
-     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
-     s  ,llm,presnivs,1.
-     s  ,dtvr*iperiod,string10,'dyn_zon ')
+   string10='dyn'
+   CALL inigrads(1,iip1 &
+         ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi &
+         ,llm,presnivs,1. &
+         ,dtvr*iperiod,string10,'dyn_zon ')
 
-        callinigrads=.FALSE.
+  callinigrads=.FALSE.
 
 
-      endif
+endif
 
-      string10='ps'
-      CALL wrgrads(1,1,ps,string10,string10)
+string10='ps'
+CALL wrgrads(1,1,ps,string10,string10)
 
-      string10='u'
-      CALL wrgrads(1,llm,unat,string10,string10)
-      string10='v'
-      CALL wrgrads(1,llm,vnat,string10,string10)
-      string10='teta'
-      CALL wrgrads(1,llm,teta,string10,string10)
-      do iq=1,nqtot
-         string10='q'
-         write(string10(2:2),'(i1)') iq
-         CALL wrgrads(1,llm,q(:,:,iq),string10,string10)
-      enddo
+string10='u'
+CALL wrgrads(1,llm,unat,string10,string10)
+string10='v'
+CALL wrgrads(1,llm,vnat,string10,string10)
+string10='teta'
+CALL wrgrads(1,llm,teta,string10,string10)
+do iq=1,nqtot
+   string10='q'
+   write(string10(2:2),'(i1)') iq
+   CALL wrgrads(1,llm,q(:,:,iq),string10,string10)
+enddo
 
Index: DZ6/branches/Amaury_dev/libf/dyn3d_common/writehist.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writehist.F	(revision 5104)
+++ 	(revision )
@@ -1,123 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
-
-      USE ioipsl
-      USE infotrac, ONLY: nqtot
-      use com_io_dyn_mod, ONLY: histid,histvid,histuid
-      USE temps_mod, ONLY: itau_dyn
-      
-      implicit none
-
-C
-C   Ecriture du fichier histoire au format IOIPSL
-C
-C   Appels succesifs des routines: histwrite
-C
-C   Entree:
-C      time: temps de l'ecriture
-C      vcov: vents v covariants
-C      ucov: vents u covariants
-C      teta: temperature potentielle
-C      phi : geopotentiel instantane
-C      q   : traceurs
-C      masse: masse
-C      ps   :pression au sol
-C      phis : geopotentiel au sol
-C      
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C
-C   Arguments
-C
-
-      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
-      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm)                   
-      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
-      REAL phis(ip1jmp1)                  
-      REAL q(ip1jmp1,llm,nqtot)
-      integer time
-
-
-! This routine needs IOIPSL to work
-C   Variables locales
-C
-      integer iq, ii, ll
-      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
-      logical ok_sync
-      integer itau_w
-      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
-
-C
-C  Initialisations
-C
-      ndexu = 0
-      ndexv = 0
-      ndex2d = 0
-      ok_sync =.TRUE.
-      itau_w = itau_dyn + time
-!  Passage aux composantes naturelles du vent
-      CALL covnat(llm, ucov, vcov, unat, vnat)
-C
-C  Appels a histwrite pour l'ecriture des variables a sauvegarder
-C
-C  Vents U
-C
-      CALL histwrite(histuid, 'u', itau_w, unat,
-     .               iip1*jjp1*llm, ndexu)
-C
-C  Vents V
-C
-      CALL histwrite(histvid, 'v', itau_w, vnat,
-     .               iip1*jjm*llm, ndexv)
-
-C
-C  Temperature potentielle
-C
-      CALL histwrite(histid, 'teta', itau_w, teta,
-     .                iip1*jjp1*llm, ndexu)
-C
-C  Geopotentiel
-C
-      CALL histwrite(histid, 'phi', itau_w, phi,
-     .                iip1*jjp1*llm, ndexu)
-C
-C  Traceurs
-C
-!        DO iq=1,nqtot
-!          CALL histwrite(histid, tracers(iq)%longName, itau_w,
-!     .                   q(:,:,iq), iip1*jjp1*llm, ndexu)
-!        enddo
-!C
-C  Masse
-C
-      CALL histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
-C
-C  Pression au sol
-C
-      CALL histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
-C
-C  Geopotentiel au sol
-C
-!      CALL histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
-C
-C  Fin
-C
-      if (ok_sync) then
-        CALL histsync(histid)
-        CALL histsync(histvid)
-        CALL histsync(histuid)
-      endif
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writehist.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writehist.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writehist.f90	(revision 5105)
@@ -0,0 +1,123 @@
+
+! $Id$
+
+SUBROUTINE writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
+
+  USE ioipsl
+  USE infotrac, ONLY: nqtot
+  use com_io_dyn_mod, ONLY: histid,histvid,histuid
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm)
+  REAL :: teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+  REAL :: ps(ip1jmp1),masse(ip1jmp1,llm)
+  REAL :: phis(ip1jmp1)
+  REAL :: q(ip1jmp1,llm,nqtot)
+  integer :: time
+
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+  !
+  integer :: iq, ii, ll
+  integer :: ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+  logical :: ok_sync
+  integer :: itau_w
+  REAL :: vnat(ip1jm,llm),unat(ip1jmp1,llm)
+
+  !
+  !  Initialisations
+  !
+  ndexu = 0
+  ndexv = 0
+  ndex2d = 0
+  ok_sync =.TRUE.
+  itau_w = itau_dyn + time
+  !  Passage aux composantes naturelles du vent
+  CALL covnat(llm, ucov, vcov, unat, vnat)
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+  CALL histwrite(histuid, 'u', itau_w, unat, &
+        iip1*jjp1*llm, ndexu)
+  !
+  !  Vents V
+  !
+  CALL histwrite(histvid, 'v', itau_w, vnat, &
+        iip1*jjm*llm, ndexv)
+
+  !
+  !  Temperature potentielle
+  !
+  CALL histwrite(histid, 'teta', itau_w, teta, &
+        iip1*jjp1*llm, ndexu)
+  !
+  !  Geopotentiel
+  !
+  CALL histwrite(histid, 'phi', itau_w, phi, &
+        iip1*jjp1*llm, ndexu)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      CALL histwrite(histid, tracers(iq)%longName, itau_w,
+  ! .                   q(:,:,iq), iip1*jjp1*llm, ndexu)
+  !    enddo
+  !C
+  !  Masse
+  !
+  CALL histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
+  !
+  !  Pression au sol
+  !
+  CALL histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+  !
+  !  Geopotentiel au sol
+  !
+  !  CALL histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+  !
+  !  Fin
+  !
+  if (ok_sync) then
+    CALL histsync(histid)
+    CALL histsync(histvid)
+    CALL histsync(histuid)
+  endif
+  return
+end subroutine writehist
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/abort_gcm.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/abort_gcm.F	(revision 5104)
+++ 	(revision )
@@ -1,52 +1,0 @@
-
-! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
-
-c
-c
-      SUBROUTINE abort_gcm(modname, message, ierr)
-     
-      USE IOIPSL
-      USE parallel_lmdz
-      INCLUDE "iniprint.h"
- 
-C
-C Stops the simulation cleanly, closing files and printing various
-C comments
-C
-C  Input: modname = name of calling program
-C         message = stuff to print
-C         ierr    = severity of situation ( = 0 normal )
-
-      character(len=*), intent(in):: modname
-      integer ierr, ierror_mpi
-      character(len=*), intent(in):: message
-
-      write(lunout,*) 'in abort_gcm'
-c$OMP MASTER
-      CALL histclo
-      CALL restclo
-      if (MPI_rank == 0) then
-         CALL getin_dump
-      endif
-c$OMP END MASTER
-c     CALL histclo(2)
-c     CALL histclo(3)
-c     CALL histclo(4)
-c     CALL histclo(5)
-      write(lunout,*) 'Stopping in ', modname
-      write(lunout,*) 'Reason = ',message
-      if (ierr == 0) then
-        write(lunout,*) 'Everything is cool'
-      else
-        write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
-
-        if (using_mpi) THEN
-C$OMP CRITICAL (MPI_ABORT_GCM)
-          CALL MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
-C$OMP END CRITICAL (MPI_ABORT_GCM)
-        else
-         stop 1
-        endif          
-      
-      endif
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/abort_gcm.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/abort_gcm.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/abort_gcm.f90	(revision 5105)
@@ -0,0 +1,52 @@
+
+! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
+
+!
+!
+SUBROUTINE abort_gcm(modname, message, ierr)
+
+  USE IOIPSL
+  USE parallel_lmdz
+  INCLUDE "iniprint.h"
+
+  !
+  ! Stops the simulation cleanly, closing files and printing various
+  ! comments
+  !
+  !  Input: modname = name of calling program
+  !     message = stuff to print
+  !     ierr    = severity of situation ( = 0 normal )
+
+  character(len=*), intent(in):: modname
+  integer :: ierr, ierror_mpi
+  character(len=*), intent(in):: message
+
+  write(lunout,*) 'in abort_gcm'
+!$OMP MASTER
+  CALL histclo
+  CALL restclo
+  if (MPI_rank == 0) then
+     CALL getin_dump
+  endif
+!$OMP END MASTER
+  ! CALL histclo(2)
+  ! CALL histclo(3)
+  ! CALL histclo(4)
+  ! CALL histclo(5)
+  write(lunout,*) 'Stopping in ', modname
+  write(lunout,*) 'Reason = ',message
+  if (ierr == 0) then
+    write(lunout,*) 'Everything is cool'
+  else
+    write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
+
+    if (using_mpi) THEN
+!$OMP CRITICAL (MPI_ABORT_GCM)
+      CALL MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
+!$OMP END CRITICAL (MPI_ABORT_GCM)
+    else
+     stop 1
+    endif
+
+  endif
+END SUBROUTINE abort_gcm
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/addfi_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/addfi_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,263 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE addfi_loc(pdt, leapf, forward,
-     S          pucov, pvcov, pteta, pq   , pps ,
-     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
-      USE parallel_lmdz
-      USE infotrac, ONLY: nqtot
-      USE control_mod, ONLY: planet_type
-      IMPLICIT NONE
-c
-c=======================================================================
-c
-c    Addition of the physical tendencies
-c
-c    Interface :
-c    -----------
-c
-c      Input :
-c      -------
-c      pdt                    time step of integration
-c      leapf                  logical
-c      forward                logical
-c      pucov(ip1jmp1,llm)     first component of the covariant velocity
-c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
-c      pteta(ip1jmp1,llm)     potential temperature
-c      pts(ip1jmp1,llm)       surface temperature
-c      pdufi(ip1jmp1,llm)     |
-c      pdvfi(ip1jm,llm)       |   respective
-c      pdhfi(ip1jmp1)         |      tendencies
-c      pdtsfi(ip1jmp1)        |
-c
-c      Output :
-c      --------
-c      pucov
-c      pvcov
-c      ph
-c      pts
-c
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c
-c    0.  Declarations :
-c    ------------------
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c    Arguments :
-c    -----------
-c
-      REAL,INTENT(IN) :: pdt ! time step for the integration (s)
-c
-      REAL,INTENT(INOUT) :: pvcov(ijb_v:ije_v,llm) ! covariant meridional wind
-      REAL,INTENT(INOUT) :: pucov(ijb_u:ije_u,llm) ! covariant zonal wind
-      REAL,INTENT(INOUT) :: pteta(ijb_u:ije_u,llm) ! potential temperature
-      REAL,INTENT(INOUT) :: pq(ijb_u:ije_u,llm,nqtot) ! tracers
-      REAL,INTENT(INOUT) :: pps(ijb_u:ije_u) ! surface pressure (Pa)
-c respective tendencies (.../s) to add
-      REAL,INTENT(IN) :: pdvfi(ijb_v:ije_v,llm)
-      REAL,INTENT(IN) :: pdufi(ijb_u:ije_u,llm)
-      REAL,INTENT(IN) :: pdqfi(ijb_u:ije_u,llm,nqtot)
-      REAL,INTENT(IN) :: pdhfi(ijb_u:ije_u,llm)
-      REAL,INTENT(IN) :: pdpfi(ijb_u:ije_u)
-c
-      LOGICAL,INTENT(IN) :: leapf,forward ! not used
-c
-c
-c    Local variables :
-c    -----------------
-c
-      REAL xpn(iim),xps(iim),tpn,tps
-      INTEGER j,k,iq,ij
-      REAL,PARAMETER :: qtestw = 1.0e-15
-      REAL,PARAMETER :: qtestt = 1.0e-40
-
-      REAL SSUM
-      EXTERNAL SSUM
-      
-      INTEGER :: ijb,ije
-c
-c-----------------------------------------------------------------------
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO k = 1,llm
-         DO j = ijb,ije
-            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      if (pole_nord) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO  k    = 1, llm
-         DO  ij   = 1, iim
-           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
-         ENDDO
-         tpn      = SSUM(iim,xpn,1)/ apoln
-
-         DO ij   = 1, iip1
-           pteta(   ij   ,k)  = tpn
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-      endif
-
-      if (pole_sud) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO  k    = 1, llm
-         DO  ij   = 1, iim
-           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
-         ENDDO
-         tps      = SSUM(iim,xps,1)/ apols
-
-         DO ij   = 1, iip1
-           pteta(ij+ip1jm,k)  = tps
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-      endif
-c
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO k = 1,llm
-         DO j = ijb,ije
-            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      if (pole_nord) ijb=ij_begin
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO k = 1,llm
-         DO j = ijb,ije
-            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c
-      if (pole_sud)  ije=ij_end
-c$OMP MASTER
-      DO j = ijb,ije
-         pps(j) = pps(j) + pdpfi(j) * pdt
-      ENDDO
-c$OMP END MASTER
- 
-      if (planet_type=="earth") then
-      ! earth case, special treatment for first 2 tracers (water)
-      DO iq = 1, 2
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1,llm
-            DO j = ijb,ije
-               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
-               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
-            ENDDO
-         ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-      DO iq = 3, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1,llm
-            DO j = ijb,ije
-               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
-               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
-            ENDDO
-         ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-      else
-      ! general case, treat all tracers equally)
-       DO iq = 1, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1,llm
-            DO j = ijb,ije
-               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
-               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
-            ENDDO
-         ENDDO
-c$OMP END DO NOWAIT
-       ENDDO
-      endif ! of if (planet_type=="earth")
-
-c$OMP MASTER
-      if (pole_nord) then
-      
-        DO  ij   = 1, iim
-          xpn(ij) = aire(   ij   ) * pps(  ij     )
-        ENDDO
-
-        tpn      = SSUM(iim,xpn,1)/apoln
-
-        DO ij   = 1, iip1
-          pps (   ij     )  = tpn
-        ENDDO
-      
-      endif
-
-      if (pole_sud) then
-      
-        DO  ij   = 1, iim
-          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
-        ENDDO
-
-        tps      = SSUM(iim,xps,1)/apols
-
-        DO ij   = 1, iip1
-          pps ( ij+ip1jm )  = tps
-        ENDDO
-      
-      endif
-c$OMP END MASTER
-
-      if (pole_nord) then
-        DO iq = 1, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO  k    = 1, llm
-            DO  ij   = 1, iim
-              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
-            ENDDO
-            tpn      = SSUM(iim,xpn,1)/apoln
-  
-            DO ij   = 1, iip1
-              pq (   ij   ,k,iq)  = tpn
-            ENDDO
-          ENDDO
-c$OMP END DO NOWAIT	  
-        ENDDO
-      endif
-      
-      if (pole_sud) then
-        DO iq = 1, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO  k    = 1, llm
-            DO  ij   = 1, iim
-              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
-            ENDDO
-            tps      = SSUM(iim,xps,1)/apols
-  
-            DO ij   = 1, iip1
-              pq (ij+ip1jm,k,iq)  = tps
-            ENDDO
-          ENDDO
-c$OMP END DO NOWAIT	  
-        ENDDO
-      endif
-      
-      
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/addfi_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/addfi_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/addfi_loc.f90	(revision 5105)
@@ -0,0 +1,263 @@
+
+! $Id$
+
+SUBROUTINE addfi_loc(pdt, leapf, forward, &
+        pucov, pvcov, pteta, pq   , pps , &
+        pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+  USE parallel_lmdz
+  USE infotrac, ONLY: nqtot
+  USE control_mod, ONLY: planet_type
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !    Addition of the physical tendencies
+  !
+  !    Interface :
+  !    -----------
+  !
+  !  Input :
+  !  -------
+  !  pdt                    time step of integration
+  !  leapf                  logical
+  !  forward                logical
+  !  pucov(ip1jmp1,llm)     first component of the covariant velocity
+  !  pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+  !  pteta(ip1jmp1,llm)     potential temperature
+  !  pts(ip1jmp1,llm)       surface temperature
+  !  pdufi(ip1jmp1,llm)     |
+  !  pdvfi(ip1jm,llm)       |   respective
+  !  pdhfi(ip1jmp1)         |      tendencies
+  !  pdtsfi(ip1jmp1)        |
+  !
+  !  Output :
+  !  --------
+  !  pucov
+  !  pvcov
+  !  ph
+  !  pts
+  !
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    0.  Declarations :
+  !    ------------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !    Arguments :
+  !    -----------
+  !
+  REAL,INTENT(IN) :: pdt ! time step for the integration (s)
+  !
+  REAL,INTENT(INOUT) :: pvcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(INOUT) :: pucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(INOUT) :: pteta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(INOUT) :: pq(ijb_u:ije_u,llm,nqtot) ! tracers
+  REAL,INTENT(INOUT) :: pps(ijb_u:ije_u) ! surface pressure (Pa)
+  ! respective tendencies (.../s) to add
+  REAL,INTENT(IN) :: pdvfi(ijb_v:ije_v,llm)
+  REAL,INTENT(IN) :: pdufi(ijb_u:ije_u,llm)
+  REAL,INTENT(IN) :: pdqfi(ijb_u:ije_u,llm,nqtot)
+  REAL,INTENT(IN) :: pdhfi(ijb_u:ije_u,llm)
+  REAL,INTENT(IN) :: pdpfi(ijb_u:ije_u)
+  !
+  LOGICAL,INTENT(IN) :: leapf,forward ! not used
+  !
+  !
+  !    Local variables :
+  !    -----------------
+  !
+  REAL :: xpn(iim),xps(iim),tpn,tps
+  INTEGER :: j,k,iq,ij
+  REAL,PARAMETER :: qtestw = 1.0e-15
+  REAL,PARAMETER :: qtestt = 1.0e-40
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+
+  INTEGER :: ijb,ije
+  !
+  !-----------------------------------------------------------------------
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  k    = 1, llm
+     DO  ij   = 1, iim
+       xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+     ENDDO
+     tpn      = SSUM(iim,xpn,1)/ apoln
+
+     DO ij   = 1, iip1
+       pteta(   ij   ,k)  = tpn
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  k    = 1, llm
+     DO  ij   = 1, iim
+       xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+     ENDDO
+     tps      = SSUM(iim,xps,1)/ apols
+
+     DO ij   = 1, iip1
+       pteta(ij+ip1jm,k)  = tps
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  endif
+  !
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_nord) ijb=ij_begin
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+  if (pole_sud)  ije=ij_end
+!$OMP MASTER
+  DO j = ijb,ije
+     pps(j) = pps(j) + pdpfi(j) * pdt
+  ENDDO
+!$OMP END MASTER
+
+  if (planet_type=="earth") then
+  ! ! earth case, special treatment for first 2 tracers (water)
+  DO iq = 1, 2
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  DO iq = 3, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  else
+  ! ! general case, treat all tracers equally)
+   DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+   ENDDO
+  endif ! of if (planet_type=="earth")
+
+!$OMP MASTER
+  if (pole_nord) then
+
+    DO  ij   = 1, iim
+      xpn(ij) = aire(   ij   ) * pps(  ij     )
+    ENDDO
+
+    tpn      = SSUM(iim,xpn,1)/apoln
+
+    DO ij   = 1, iip1
+      pps (   ij     )  = tpn
+    ENDDO
+
+  endif
+
+  if (pole_sud) then
+
+    DO  ij   = 1, iim
+      xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+    ENDDO
+
+    tps      = SSUM(iim,xps,1)/apols
+
+    DO ij   = 1, iip1
+      pps ( ij+ip1jm )  = tps
+    ENDDO
+
+  endif
+!$OMP END MASTER
+
+  if (pole_nord) then
+    DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  k    = 1, llm
+        DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+        ENDDO
+        tpn      = SSUM(iim,xpn,1)/apoln
+
+        DO ij   = 1, iip1
+          pq (   ij   ,k,iq)  = tpn
+        ENDDO
+      ENDDO
+!$OMP END DO NOWAIT	
+    ENDDO
+  endif
+
+  if (pole_sud) then
+    DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  k    = 1, llm
+        DO  ij   = 1, iim
+          xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+        ENDDO
+        tps      = SSUM(iim,xps,1)/apols
+
+        DO ij   = 1, iip1
+          pq (ij+ip1jm,k,iq)  = tps
+        ENDDO
+      ENDDO
+!$OMP END DO NOWAIT	
+    ENDDO
+  endif
+
+
+
+END SUBROUTINE addfi_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/advect_new_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/advect_new_loc.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/advect_new_loc.f90	(revision 5105)
@@ -290,4 +290,4 @@
   !$OMP END DO NOWAIT
 
-  RETURN
+
 END SUBROUTINE advect_new_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,76 +1,0 @@
-      SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:   P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c     calcul de la fonction de Bernouilli aux niveaux s  .....
-c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
-c          bern       est un  argument de sortie pour le s-pg  ......
-c
-c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
-c                              energ.cinet.)
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c   Decalrations:
-c   -------------
-c
-      include "dimensions.h"
-      include "paramet.h"
-c
-c   Arguments:
-c   ----------
-c
-      INTEGER nlay,ngrid
-      REAL pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay)
-      REAL pbern(ijb_u:ije_u,nlay)
-c
-c   Local:
-c   ------
-c
-      INTEGER   ij,l,ijb,ije,jjb,jje
-c
-c-----------------------------------------------------------------------
-c   calcul de Bernouilli:
-c   ---------------------
-c
-      ijb=ij_begin
-      ije=ij_end+iip1
-      if (pole_sud) ije=ij_end
-
-      jjb=jj_begin
-      jje=jj_end+1
-      if (pole_sud) jje=jj_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)                
-      DO l=1,llm
-    
-        DO ij = ijb,ije
-          pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
-      END DO
-       
-       ENDDO
-c$OMP END DO NOWAIT
-c
-c-----------------------------------------------------------------------
-c   filtre:
-c   -------
-c
-
-        
-        CALL filtreg_p( pbern,jjb_u,jje_u,jjb,jje, jjp1, llm, 
-     &                  2,1, .TRUE., 1 )
-c
-c-----------------------------------------------------------------------
-      
-      
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.f90	(revision 5105)
@@ -0,0 +1,76 @@
+SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  ! calcul de la fonction de Bernouilli aux niveaux s  .....
+  ! phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+  !      bern       est un  argument de sortie pour le s-pg  ......
+  !
+  !    fonction de Bernouilli = bern = filtre de( geopotentiel +
+  !                          energ.cinet.)
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !   Decalrations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !   Arguments:
+  !   ----------
+  !
+  INTEGER :: nlay,ngrid
+  REAL :: pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay)
+  REAL :: pbern(ijb_u:ije_u,nlay)
+  !
+  !   Local:
+  !   ------
+  !
+  INTEGER :: ij,l,ijb,ije,jjb,jje
+  !
+  !-----------------------------------------------------------------------
+  !   calcul de Bernouilli:
+  !   ---------------------
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_sud) ije=ij_end
+
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+
+    DO ij = ijb,ije
+      pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
+  END DO
+
+   ENDDO
+!$OMP END DO NOWAIT
+  !
+  !-----------------------------------------------------------------------
+  !   filtre:
+  !   -------
+  !
+
+
+    CALL filtreg_p( pbern,jjb_u,jje_u,jjb,jje, jjp1, llm, &
+          2,1, .TRUE., 1 )
+  !
+  !-----------------------------------------------------------------------
+
+
+
+END SUBROUTINE bernoui_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,843 +1,0 @@
-
-! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
-
-      SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum,
-     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
-
-c   AFAIRE
-c   Prevoir en champ nq+1 le diagnostique de l'energie
-c   en faisant Qzon=Cv T + L * ...
-c             vQ..A=Cp T + L * ...
-
-      USE IOIPSL
-      USE parallel_lmdz
-      USE mod_hallo
-      use misc_mod
-      USE write_field_loc
-      USE comconst_mod, ONLY: cpp, pi
-      USE comvert_mod, ONLY: presnivs
-      USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-      
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-      include "iniprint.h"
-
-c====================================================================
-c
-c   Sous-programme consacre à des diagnostics dynamiques de base
-c
-c 
-c   De facon generale, les moyennes des scalaires Q sont ponderees par
-c   la masse.
-c
-c   Les flux de masse sont eux simplement moyennes.
-c
-c====================================================================
-
-c   Arguments :
-c   ===========
-
-      integer ntrac
-      real dt_app,dt_cum
-      real ps(iip1,jjb_u:jje_u)
-      real masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
-      real flux_u(iip1,jjb_u:jje_u,llm)
-      real flux_v(iip1,jjb_v:jje_v,llm)
-      real teta(iip1,jjb_u:jje_u,llm)
-      real phi(iip1,jjb_u:jje_u,llm)
-      real ucov(iip1,jjb_u:jje_u,llm)
-      real vcov(iip1,jjb_v:jje_v,llm)
-      real trac(iip1,jjb_u:jje_u,llm,ntrac)
-
-c   Local :
-c   =======
-
-      integer,SAVE :: icum,ncum
-!$OMP THREADPRIVATE(icum,ncum)
-      LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)      
-      
-      real zz,zqy
-      REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
-
-      INTEGER,PARAMETER :: nQ=7
-
-
-cym      character*6 nom(nQ)
-cym      character*6 unites(nQ)
-      character(len=6),save :: nom(nQ)
-      character(len=6),save :: unites(nQ)
-
-      character(len=10) file
-      integer ifile
-      parameter (ifile=4)
-
-      integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
-      INTEGER,PARAMETER :: iovap=6,iun=7
-      integer,PARAMETER :: i_sortie=1
-
-      real,SAVE :: time=0.
-      integer,SAVE :: itau=0.
-!$OMP THREADPRIVATE(time,itau)
-
-      real ww
-
-c   variables dynamiques intermédiaires
-      REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
-
-c   champ contenant les scalaires advectés.
-      real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
-    
-c   champs cumulés
-      real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
-      real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
-      real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
-
- 
-c   champs de tansport en moyenne zonale
-      integer ntr,itr
-      parameter (ntr=5)
-
-cym      character*10 znom(ntr,nQ)
-cym      character*20 znoml(ntr,nQ)
-cym      character*10 zunites(ntr,nQ)
-      character*10,save :: znom(ntr,nQ)
-      character*20,save :: znoml(ntr,nQ)
-      character*10,save :: zunites(ntr,nQ)
-
-      INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
-
-      character*3 ctrs(ntr)
-      data ctrs/'  ','TOT','MMC','TRS','STN'/
-
-      real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
-      real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
-      real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
-
-      real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
-
-      integer i,j,l,iQ
-
-
-c   Initialisation du fichier contenant les moyennes zonales.
-c   ---------------------------------------------------------
-
-      character*10 infile
-
-      integer, save :: fileid
-      integer thoriid, zvertiid
-
-      INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
-
-C   Variables locales
-C
-      integer tau0
-      real zjulian
-      character*3 str
-      character*10 ctrac
-      integer ii,jj
-      integer zan, dayref
-C
-      real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
-      integer :: jjb,jje,jjn,ijb,ije
-      type(Request),SAVE :: Req
-!$OMP THREADPRIVATE(Req)
-
-! definition du domaine d'ecriture pour le rebuild
-
-      INTEGER,DIMENSION(1) :: ddid
-      INTEGER,DIMENSION(1) :: dsg
-      INTEGER,DIMENSION(1) :: dsl
-      INTEGER,DIMENSION(1) :: dpf
-      INTEGER,DIMENSION(1) :: dpl
-      INTEGER,DIMENSION(1) :: dhs
-      INTEGER,DIMENSION(1) :: dhe 
-      
-      INTEGER :: bilan_dyn_domain_id
-
-c=====================================================================
-c   Initialisation
-c=====================================================================
-      if (adjust) return
-      
-      time=time+dt_app
-      itau=itau+1
-
-      if (first) then
-!$OMP BARRIER
-!$OMP MASTER
-      ALLOCATE(zfactv(jjb_v:jje_v,llm))
-      ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(w(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(bern(iip1,jjb_u:jje_u,llm))      
-      ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))      
-      ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
-      ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
-      ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
-      ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
-      ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
-      ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
-      ALLOCATE(zmasse(jjb_v:jje_v,llm))
-      ALLOCATE(zamasse(jjb_v:jje_v))
-      ALLOCATE(zv(jjb_v:jje_v,llm))
-      ALLOCATE(psi(jjb_v:jje_v,llm+1))
-      ALLOCATE(ndex3d(jjb_v:jje_v*llm))
-      ndex3d=0
-      ALLOCATE(rlong(1))
-      ALLOCATE(rlatg(jjm))
-      
-!$OMP END MASTER
-!$OMP BARRIER
-        icum=0
-c       initialisation des fichiers
-        first=.FALSE.
-c   ncum est la frequence de stokage en pas de temps
-        ncum=dt_cum/dt_app
-        if (abs(ncum*dt_app-dt_cum)>1.e-5*dt_app) then
-           WRITE(lunout,*)
-     .            'Pb : le pas de cumule doit etre multiple du pas'
-           WRITE(lunout,*)'dt_app=',dt_app
-           WRITE(lunout,*)'dt_cum=',dt_cum
-           CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
-        endif
-
-!$OMP MASTER
-        nom(itemp)='T'
-        nom(igeop)='gz'
-        nom(iecin)='K'
-        nom(iang)='ang'
-        nom(iu)='u'
-        nom(iovap)='ovap'
-        nom(iun)='un'
-
-        unites(itemp)='K'
-        unites(igeop)='m2/s2'
-        unites(iecin)='m2/s2'
-        unites(iang)='ang'
-        unites(iu)='m/s'
-        unites(iovap)='kg/kg'
-        unites(iun)='un'
-
-
-c   Initialisation du fichier contenant les moyennes zonales.
-c   ---------------------------------------------------------
-
-      infile='dynzon'
-
-      zan = annee_ref
-      dayref = day_ref
-      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-      tau0 = itau_dyn
-      
-      rlong=0.
-      rlatg=rlatv*180./pi
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-      IF (pole_sud) THEN
-        jjn=jj_nb-1
-        jje=jj_end-1
-      ENDIF
-
-      ddid=(/ 2 /)
-      dsg=(/ jjm /)
-      dsl=(/ jjn /)
-      dpf=(/ jjb /)
-      dpl=(/ jje /)
-      dhs=(/ 0 /)
-      dhe=(/ 0 /)
-
-      CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
-     .                 'box',bilan_dyn_domain_id)
-       
-      CALL histbeg(trim(infile),
-     .             1, rlong, jjn, rlatg(jjb:jje),
-     .             1, 1, 1, jjn,
-     .             tau0, zjulian, dt_cum, thoriid, fileid,
-     .             bilan_dyn_domain_id)
-
-C
-C  Appel a histvert pour la grille verticale
-C
-      CALL histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
-     .              llm, presnivs, zvertiid)
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-      do iQ=1,nQ
-         do itr=1,ntr
-            if(itr==1) then
-               znom(itr,iQ)=nom(iQ)
-               znoml(itr,iQ)=nom(iQ)
-               zunites(itr,iQ)=unites(iQ)
-            else
-               znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
-               znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
-               zunites(itr,iQ)='m/s * '//unites(iQ)
-            endif
-         enddo
-      enddo
-
-c   Declarations des champs avec dimension verticale
-c      PRINT*,'1HISTDEF'
-      do iQ=1,nQ
-         do itr=1,ntr
-      IF (prt_level > 5)
-     . WRITE(lunout,*)'var ',itr,iQ
-     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
-            CALL histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
-     .        zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
-     .        32,'ave(X)',dt_cum,dt_cum)
-         enddo
-c   Declarations pour les fonctions de courant
-c      PRINT*,'2HISTDEF'
-          CALL histdef(fileid,'psi'//nom(iQ)
-     .      ,'stream fn. '//znoml(itot,iQ),
-     .      zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
-     .      32,'ave(X)',dt_cum,dt_cum)
-      enddo
-
-
-c   Declarations pour les champs de transport d'air
-c      PRINT*,'3HISTDEF'
-      CALL histdef(fileid, 'masse', 'masse',
-     .             'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', dt_cum, dt_cum)
-      CALL histdef(fileid, 'v', 'v',
-     .             'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', dt_cum, dt_cum)
-c   Declarations pour les fonctions de courant
-c      PRINT*,'4HISTDEF'
-          CALL histdef(fileid,'psi','stream fn. MMC ','mega t/s',
-     .      1,jjn,thoriid,llm,1,llm,zvertiid,
-     .      32,'ave(X)',dt_cum,dt_cum)
-
-
-c   Declaration des champs 1D de transport en latitude
-c      PRINT*,'5HISTDEF'
-      do iQ=1,nQ
-         do itr=2,ntr
-            CALL histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
-     .        zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99,
-     .        32,'ave(X)',dt_cum,dt_cum)
-         enddo
-      enddo
-
-
-c      PRINT*,'8HISTDEF'
-               CALL histend(fileid)
-
-!$OMP END MASTER
-      endif
-
-
-c=====================================================================
-c   Calcul des champs dynamiques
-c   ----------------------------
-
-      jjb=jj_begin
-      jje=jj_end
-    
-c   énergie cinétique
-!      ucont(:,jjb:jje,:)=0
-
-      CALL Register_Hallo_u(ucov,llm,1,1,1,1,Req)
-      CALL Register_Hallo_v(vcov,llm,1,1,1,1,Req)
-      CALL SendRequest(Req)
-c$OMP BARRIER
-      CALL WaitRequest(Req)
-
-      CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
-      CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
-
-c   moment cinétique
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do l=1,llm
-         ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
-         unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
-      enddo
-!$OMP END DO NOWAIT
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
-        Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
-        Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
-        Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
-        Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
-        Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
-        Q(:,jjb:jje,l,iun)=1.
-      ENDDO
-!$OMP END DO NOWAIT
-
-c=====================================================================
-c   Cumul
-c=====================================================================
-c
-      if(icum==0) then
-         jjb=jj_begin
-         jje=jj_end
-
-!$OMP MASTER
-         ps_cum(:,jjb:jje)=0.
-!$OMP END MASTER
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          masse_cum(:,jjb:jje,l)=0.
-          flux_u_cum(:,jjb:jje,l)=0.
-          Q_cum(:,jjb:jje,l,:)=0.
-          flux_uQ_cum(:,jjb:jje,l,:)=0.
-          if (pole_sud) jje=jj_end-1
-          flux_v_cum(:,jjb:jje,l)=0.
-          flux_vQ_cum(:,jjb:jje,l,:)=0.
-        ENDDO
-!$OMP END DO NOWAIT
-      endif
-
-      IF (prt_level > 5)
-     . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
-      icum=icum+1
-
-c   accumulation des flux de masse horizontaux
-      jjb=jj_begin
-      jje=jj_end
-
-!$OMP MASTER
-      ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
-!$OMP END MASTER
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
-        flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)
-     .                         +flux_u(:,jjb:jje,l)
-      ENDDO
-!$OMP END DO NOWAIT
-      
-      if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)
-     .                          +flux_v(:,jjb:jje,l)
-      ENDDO
-!$OMP END DO NOWAIT
-      
-      jjb=jj_begin
-      jje=jj_end
-
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ)
-     .                       +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
-        ENDDO
-!$OMP END DO NOWAIT
-      enddo
-
-c=====================================================================
-c  FLUX ET TENDANCES
-c=====================================================================
-
-c   Flux longitudinal
-c   -----------------
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            do j=jjb,jje
-               do i=1,iim
-                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
-     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
-               enddo
-               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
-            enddo
-         enddo
-!$OMP END DO NOWAIT
-      enddo
-
-c    flux méridien
-c    -------------
-      do iQ=1,nQ
-        CALL Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
-      enddo
-      CALL SendRequest(Req)
-!$OMP BARRIER      
-      CALL WaitRequest(Req)
-      
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            do j=jjb,jje
-               do i=1,iip1
-                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
-     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
-               enddo
-            enddo
-         enddo
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-      enddo
-
-c    tendances
-c    ---------
-
-c   convergence horizontale
-      CALL Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
-      CALL Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
-      CALL SendRequest(Req)
-!$OMP BARRIER      
-      CALL WaitRequest(Req)
-
-      CALL  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
-
-c   calcul de la vitesse verticale
-      CALL Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
-      CALL Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
-      CALL SendRequest(Req)
-!$OMP BARRIER      
-      CALL WaitRequest(Req)
-
-      CALL convmas_loc(flux_u_cum,flux_v_cum,convm)
-      CALL vitvert_loc(convm,w)
-!$OMP BARRIER
-
-
-      jjb=jj_begin
-      jje=jj_end
-
-!      do iQ=1,nQ
-!         do l=1,llm-1
-!            do j=jjb,jje
-!               do i=1,iip1
-!                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-!                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-!                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-!               enddo
-!            enddo
-!          enddo
-!       enddo
-       
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            IF (l<llm) THEN
-              do j=jjb,jje
-                 do i=1,iip1
-                    ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-                    dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-                    dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-                 enddo
-              enddo
-            ENDIF
-            IF (l>2) THEN
-              do j=jjb,jje
-                do i=1,iip1
-                  ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
-                  dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
-                enddo
-              enddo
-            ENDIF
-         enddo
-!$OMP ENDDO NOWAIT 
-      enddo
-      IF (prt_level > 5)
-     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
-c=====================================================================
-c   PAS DE TEMPS D'ECRITURE
-c=====================================================================
-      if (icum==ncum) then
-c=====================================================================
-
-      IF (prt_level > 5)
-     . WRITE(lunout,*)'Pas d ecriture'
-
-      jjb=jj_begin
-      jje=jj_end
-
-c   Normalisation
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-          Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) 
-     .                                /masse_cum(:,jjb:jje,l)
-        enddo
-!$OMP ENDDO NOWAIT 
-      enddo   
-
-      zz=1./REAL(ncum)
-
-!$OMP MASTER
-        ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
-!$OMP END MASTER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
-        flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
-        flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
-        dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
-      ENDDO
-!$OMP ENDDO NOWAIT 
-         
-      IF (pole_sud) jje=jj_end-1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
-        flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
-      ENDDO
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-          
-      jjb=jj_begin
-      jje=jj_end
-
-
-c   A retravailler eventuellement
-c   division de dQ par la masse pour revenir aux bonnes grandeurs
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-           dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
-        ENDDO
-!$OMP ENDDO NOWAIT 
-      enddo
-
-c=====================================================================
-c   Transport méridien
-c=====================================================================
-
-c   cumul zonal des masses des mailles
-c   ----------------------------------
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          zv(jjb:jje,l)=0.
-          zmasse(jjb:jje,l)=0.
-        ENDDO
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-
-      CALL Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
-      do iQ=1,nQ
-        CALL Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
-      enddo
-
-      CALL SendRequest(Req)
-!$OMP BARRIER
-      CALL WaitRequest(Req)
-
-      CALL massbar_loc(masse_cum,massebx,masseby)
-      
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do l=1,llm
-         do j=jjb,jje
-            do i=1,iim
-               zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
-               zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
-            enddo
-            zfactv(j,l)=cv(1,j)/zmasse(j,l)
-         enddo
-      enddo
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-
-c     PRINT*,'3OK'
-c   --------------------------------------------------------------
-c   calcul de la moyenne zonale du transport :
-c   ------------------------------------------
-c
-c                                     --
-c TOT : la circulation totale       [ vq ]
-c
-c                                      -     -
-c MMC : mean meridional circulation [ v ] [ q ]
-c
-c                                     ----      --       - -
-c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
-c
-c                                     - * - *       - -       -     -
-c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
-c
-c                                              - -
-c    on utilise aussi l'intermediaire TMP :  [ v q ]
-c
-c    la variable zfactv transforme un transport meridien cumule
-c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
-c
-c   --------------------------------------------------------------
-
-
-c   ----------------------------------------
-c   Transport dans le plan latitude-altitude
-c   ----------------------------------------
-
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-      zvQ=0.
-      psiQ=0.
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            zvQtmp(:,l)=0.
-            do j=jjb,jje
-c              PRINT*,'j,l,iQ=',j,l,iQ
-c   Calcul des moyennes zonales du transort total et de zvQtmp
-               do i=1,iim
-                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
-     s                            +flux_vQ_cum(i,j,l,iQ)
-                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
-     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
-                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
-     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
-                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
-               enddo
-c              PRINT*,'aOK'
-c   Decomposition
-               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
-               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
-               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
-               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
-               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
-               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
-            enddo
-         enddo
-!$OMP ENDDO NOWAIT 
-c   fonction de courant meridienne pour la quantite Q
-!$OMP BARRIER
-!$OMP MASTER
-         do l=llm,1,-1
-            do j=jjb,jje
-               psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
-            enddo
-         enddo
-!$OMP END MASTER
-!$OMP BARRIER
-      enddo
-
-c   fonction de courant pour la circulation meridienne moyenne
-!$OMP BARRIER
-!$OMP MASTER
-      psi(jjb:jje,:)=0.
-      do l=llm,1,-1
-         do j=jjb,jje
-            psi(j,l)=psi(j,l+1)+zv(j,l)
-            zv(j,l)=zv(j,l)*zfactv(j,l)
-         enddo
-      enddo
-!$OMP END MASTER
-!$OMP BARRIER
-
-c     PRINT*,'4OK'
-c   sorties proprement dites
-!$OMP MASTER      
-      if (i_sortie==1) then
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-      if (pole_sud) jje=jj_end-1
-      if (pole_sud) jjn=jj_nb-1
-      do iQ=1,nQ
-         do itr=1,ntr
-            CALL histwrite(fileid,znom(itr,iQ),itau,
-     s                     zvQ(jjb:jje,:,itr,iQ)
-     s                     ,jjn*llm,ndex3d)
-         enddo
-         CALL histwrite(fileid,'psi'//nom(iQ),
-     s                  itau,psiQ(jjb:jje,1:llm,iQ)
-     s                  ,jjn*llm,ndex3d)
-      enddo
-
-      CALL histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm)
-     s   ,jjn*llm,ndex3d)
-      CALL histwrite(fileid,'v',itau,zv(jjb:jje,1:llm)
-     s   ,jjn*llm,ndex3d)
-      psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
-      CALL histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm),
-     s               jjn*llm,ndex3d)
-
-      endif
-
- 
-c   -----------------
-c   Moyenne verticale
-c   -----------------
-
-      zamasse(jjb:jje)=0.
-      do l=1,llm
-         zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
-      enddo
-     
-      zavQ(jjb:jje,:,:)=0.
-      do iQ=1,nQ
-         do itr=2,ntr
-            do l=1,llm
-               zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)
-     s                             +zvQ(jjb:jje,l,itr,iQ)
-     s                             *zmasse(jjb:jje,l)
-            enddo
-            zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
-            CALL histwrite(fileid,'a'//znom(itr,iQ),itau,
-     s                     zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
-         enddo
-      enddo
-!$OMP END MASTER
-c     on doit pouvoir tracer systematiquement la fonction de courant.
-
-c=====================================================================
-c/////////////////////////////////////////////////////////////////////
-      icum=0                  !///////////////////////////////////////
-      endif ! icum.eq.ncum    !///////////////////////////////////////
-c/////////////////////////////////////////////////////////////////////
-c=====================================================================
-!$OMP MASTER
-      CALL histsync(fileid)
-!$OMP END MASTER
-
-
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.f90	(revision 5105)
@@ -0,0 +1,843 @@
+
+! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
+
+SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, &
+        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+  !   AFAIRE
+  !   Prevoir en champ nq+1 le diagnostique de l'energie
+  !   en faisant Qzon=Cv T + L * ...
+  !             vQ..A=Cp T + L * ...
+
+  USE IOIPSL
+  USE parallel_lmdz
+  USE mod_hallo
+  use misc_mod
+  USE write_field_loc
+  USE comconst_mod, ONLY: cpp, pi
+  USE comvert_mod, ONLY: presnivs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+
+  !====================================================================
+  !
+  !   Sous-programme consacre à des diagnostics dynamiques de base
+  !
+  !
+  !   De facon generale, les moyennes des scalaires Q sont ponderees par
+  !   la masse.
+  !
+  !   Les flux de masse sont eux simplement moyennes.
+  !
+  !====================================================================
+
+  !   Arguments :
+  !   ===========
+
+  integer :: ntrac
+  real :: dt_app,dt_cum
+  real :: ps(iip1,jjb_u:jje_u)
+  real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
+  real :: flux_u(iip1,jjb_u:jje_u,llm)
+  real :: flux_v(iip1,jjb_v:jje_v,llm)
+  real :: teta(iip1,jjb_u:jje_u,llm)
+  real :: phi(iip1,jjb_u:jje_u,llm)
+  real :: ucov(iip1,jjb_u:jje_u,llm)
+  real :: vcov(iip1,jjb_v:jje_v,llm)
+  real :: trac(iip1,jjb_u:jje_u,llm,ntrac)
+
+  !   Local :
+  !   =======
+
+  integer,SAVE :: icum,ncum
+!$OMP THREADPRIVATE(icum,ncum)
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  real :: zz,zqy
+  REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
+
+  INTEGER,PARAMETER :: nQ=7
+
+
+  !ym      character*6 nom(nQ)
+  !ym      character*6 unites(nQ)
+  character(len=6),save :: nom(nQ)
+  character(len=6),save :: unites(nQ)
+
+  character(len=10) file
+  integer :: ifile
+  parameter (ifile=4)
+
+  integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
+  INTEGER,PARAMETER :: iovap=6,iun=7
+  integer,PARAMETER :: i_sortie=1
+
+  real,SAVE :: time=0.
+  integer,SAVE :: itau=0.
+!$OMP THREADPRIVATE(time,itau)
+
+  real :: ww
+
+  !   variables dynamiques intermédiaires
+  REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
+
+  !   champ contenant les scalaires advectés.
+  real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
+
+  !   champs cumulés
+  real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
+  real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
+
+
+  !   champs de tansport en moyenne zonale
+  integer :: ntr,itr
+  parameter (ntr=5)
+
+  !ym      character*10 znom(ntr,nQ)
+  !ym      character*20 znoml(ntr,nQ)
+  !ym      character*10 zunites(ntr,nQ)
+  character*10,save :: znom(ntr,nQ)
+  character*20,save :: znoml(ntr,nQ)
+  character*10,save :: zunites(ntr,nQ)
+
+  INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
+
+  character(len=3) :: ctrs(ntr)
+  data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+  real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
+  real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
+  real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
+
+  real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
+
+  integer :: i,j,l,iQ
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  character(len=10) :: infile
+
+  integer, save :: fileid
+  integer :: thoriid, zvertiid
+
+  INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
+
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: ii,jj
+  integer :: zan, dayref
+  !
+  real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
+  integer :: jjb,jje,jjn,ijb,ije
+  type(Request),SAVE :: Req
+!$OMP THREADPRIVATE(Req)
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(1) :: ddid
+  INTEGER,DIMENSION(1) :: dsg
+  INTEGER,DIMENSION(1) :: dsl
+  INTEGER,DIMENSION(1) :: dpf
+  INTEGER,DIMENSION(1) :: dpl
+  INTEGER,DIMENSION(1) :: dhs
+  INTEGER,DIMENSION(1) :: dhe
+
+  INTEGER :: bilan_dyn_domain_id
+
+  !=====================================================================
+  !   Initialisation
+  !=====================================================================
+  if (adjust) return
+
+  time=time+dt_app
+  itau=itau+1
+
+  if (first) then
+!$OMP BARRIER
+!$OMP MASTER
+  ALLOCATE(zfactv(jjb_v:jje_v,llm))
+  ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(w(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(bern(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
+  ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
+  ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
+  ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
+  ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
+  ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
+  ALLOCATE(zmasse(jjb_v:jje_v,llm))
+  ALLOCATE(zamasse(jjb_v:jje_v))
+  ALLOCATE(zv(jjb_v:jje_v,llm))
+  ALLOCATE(psi(jjb_v:jje_v,llm+1))
+  ALLOCATE(ndex3d(jjb_v:jje_v*llm))
+  ndex3d=0
+  ALLOCATE(rlong(1))
+  ALLOCATE(rlatg(jjm))
+
+!$OMP END MASTER
+!$OMP BARRIER
+    icum=0
+    ! initialisation des fichiers
+    first=.FALSE.
+  !   ncum est la frequence de stokage en pas de temps
+    ncum=dt_cum/dt_app
+    if (abs(ncum*dt_app-dt_cum)>1.e-5*dt_app) then
+       WRITE(lunout,*) &
+             'Pb : le pas de cumule doit etre multiple du pas'
+       WRITE(lunout,*)'dt_app=',dt_app
+       WRITE(lunout,*)'dt_cum=',dt_cum
+       CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
+    endif
+
+!$OMP MASTER
+    nom(itemp)='T'
+    nom(igeop)='gz'
+    nom(iecin)='K'
+    nom(iang)='ang'
+    nom(iu)='u'
+    nom(iovap)='ovap'
+    nom(iun)='un'
+
+    unites(itemp)='K'
+    unites(igeop)='m2/s2'
+    unites(iecin)='m2/s2'
+    unites(iang)='ang'
+    unites(iu)='m/s'
+    unites(iovap)='kg/kg'
+    unites(iun)='un'
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  infile='dynzon'
+
+  zan = annee_ref
+  dayref = day_ref
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  rlong=0.
+  rlatg=rlatv*180./pi
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) THEN
+    jjn=jj_nb-1
+    jje=jj_end-1
+  ENDIF
+
+  ddid=(/ 2 /)
+  dsg=(/ jjm /)
+  dsl=(/ jjn /)
+  dpf=(/ jjb /)
+  dpl=(/ jje /)
+  dhs=(/ 0 /)
+  dhe=(/ 0 /)
+
+  CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',bilan_dyn_domain_id)
+
+  CALL histbeg(trim(infile), &
+        1, rlong, jjn, rlatg(jjb:jje), &
+        1, 1, 1, jjn, &
+        tau0, zjulian, dt_cum, thoriid, fileid, &
+        bilan_dyn_domain_id)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  CALL histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
+        llm, presnivs, zvertiid)
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  do iQ=1,nQ
+     do itr=1,ntr
+        if(itr==1) then
+           znom(itr,iQ)=nom(iQ)
+           znoml(itr,iQ)=nom(iQ)
+           zunites(itr,iQ)=unites(iQ)
+        else
+           znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+           znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+           zunites(itr,iQ)='m/s * '//unites(iQ)
+        endif
+     enddo
+  enddo
+
+  !   Declarations des champs avec dimension verticale
+   ! PRINT*,'1HISTDEF'
+  do iQ=1,nQ
+     do itr=1,ntr
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'var ',itr,iQ &
+        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+        CALL histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  !   Declarations pour les fonctions de courant
+   ! PRINT*,'2HISTDEF'
+      CALL histdef(fileid,'psi'//nom(iQ) &
+            ,'stream fn. '//znoml(itot,iQ), &
+            zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+  enddo
+
+
+  !   Declarations pour les champs de transport d'air
+   ! PRINT*,'3HISTDEF'
+  CALL histdef(fileid, 'masse', 'masse', &
+        'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  CALL histdef(fileid, 'v', 'v', &
+        'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  !   Declarations pour les fonctions de courant
+   ! PRINT*,'4HISTDEF'
+      CALL histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
+            1,jjn,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+
+
+  !   Declaration des champs 1D de transport en latitude
+   ! PRINT*,'5HISTDEF'
+  do iQ=1,nQ
+     do itr=2,ntr
+        CALL histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  enddo
+
+
+   ! PRINT*,'8HISTDEF'
+           CALL histend(fileid)
+
+!$OMP END MASTER
+  endif
+
+
+  !=====================================================================
+  !   Calcul des champs dynamiques
+  !   ----------------------------
+
+  jjb=jj_begin
+  jje=jj_end
+
+  !   énergie cinétique
+   ! ucont(:,jjb:jje,:)=0
+
+  CALL Register_Hallo_u(ucov,llm,1,1,1,1,Req)
+  CALL Register_Hallo_v(vcov,llm,1,1,1,1,Req)
+  CALL SendRequest(Req)
+!$OMP BARRIER
+  CALL WaitRequest(Req)
+
+  CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+  CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+
+  !   moment cinétique
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
+     unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
+  enddo
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
+    Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
+    Q(:,jjb:jje,l,iun)=1.
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !=====================================================================
+  !   Cumul
+  !=====================================================================
+  !
+  if(icum==0) then
+     jjb=jj_begin
+     jje=jj_end
+
+!$OMP MASTER
+     ps_cum(:,jjb:jje)=0.
+!$OMP END MASTER
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      masse_cum(:,jjb:jje,l)=0.
+      flux_u_cum(:,jjb:jje,l)=0.
+      Q_cum(:,jjb:jje,l,:)=0.
+      flux_uQ_cum(:,jjb:jje,l,:)=0.
+      if (pole_sud) jje=jj_end-1
+      flux_v_cum(:,jjb:jje,l)=0.
+      flux_vQ_cum(:,jjb:jje,l,:)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+  icum=icum+1
+
+  !   accumulation des flux de masse horizontaux
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP MASTER
+  ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
+!$OMP END MASTER
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) &
+          +flux_u(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) &
+         +flux_v(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  jjb=jj_begin
+  jje=jj_end
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
+    ENDDO
+!$OMP END DO NOWAIT
+  enddo
+
+  !=====================================================================
+  !  FLUX ET TENDANCES
+  !=====================================================================
+
+  !   Flux longitudinal
+  !   -----------------
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iim
+              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
+                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+           enddo
+           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+        enddo
+     enddo
+!$OMP END DO NOWAIT
+  enddo
+
+  !    flux méridien
+  !    -------------
+  do iQ=1,nQ
+    CALL Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+  CALL SendRequest(Req)
+!$OMP BARRIER
+  CALL WaitRequest(Req)
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iip1
+              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
+                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+           enddo
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  enddo
+
+  !    tendances
+  !    ---------
+
+  !   convergence horizontale
+  CALL Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
+  CALL Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
+  CALL SendRequest(Req)
+!$OMP BARRIER
+  CALL WaitRequest(Req)
+
+  CALL  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+  !   calcul de la vitesse verticale
+  CALL Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
+  CALL Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
+  CALL SendRequest(Req)
+!$OMP BARRIER
+  CALL WaitRequest(Req)
+
+  CALL convmas_loc(flux_u_cum,flux_v_cum,convm)
+  CALL vitvert_loc(convm,w)
+!$OMP BARRIER
+
+
+  jjb=jj_begin
+  jje=jj_end
+
+   ! do iQ=1,nQ
+   !    do l=1,llm-1
+   !       do j=jjb,jje
+   !          do i=1,iip1
+   !             ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+   !             dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+   !             dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+   !          enddo
+   !       enddo
+   !     enddo
+   !  enddo
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        IF (l<llm) THEN
+          do j=jjb,jje
+             do i=1,iip1
+                ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+             enddo
+          enddo
+        ENDIF
+        IF (l>2) THEN
+          do j=jjb,jje
+            do i=1,iip1
+              ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
+              dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
+            enddo
+          enddo
+        ENDIF
+     enddo
+!$OMP ENDDO NOWAIT
+  enddo
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+  !=====================================================================
+  !   PAS DE TEMPS D'ECRITURE
+  !=====================================================================
+  if (icum==ncum) then
+  !=====================================================================
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Pas d ecriture'
+
+  jjb=jj_begin
+  jje=jj_end
+
+  !   Normalisation
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            /masse_cum(:,jjb:jje,l)
+    enddo
+!$OMP ENDDO NOWAIT
+  enddo
+
+  zz=1./REAL(ncum)
+
+!$OMP MASTER
+    ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
+!$OMP END MASTER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
+    flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
+    dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
+    flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  jjb=jj_begin
+  jje=jj_end
+
+
+  !   A retravailler eventuellement
+  !   division de dQ par la masse pour revenir aux bonnes grandeurs
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
+    ENDDO
+!$OMP ENDDO NOWAIT
+  enddo
+
+  !=====================================================================
+  !   Transport méridien
+  !=====================================================================
+
+  !   cumul zonal des masses des mailles
+  !   ----------------------------------
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      zv(jjb:jje,l)=0.
+      zmasse(jjb:jje,l)=0.
+    ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  CALL Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
+  do iQ=1,nQ
+    CALL Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+
+  CALL SendRequest(Req)
+!$OMP BARRIER
+  CALL WaitRequest(Req)
+
+  CALL massbar_loc(masse_cum,massebx,masseby)
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        do i=1,iim
+           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+        enddo
+        zfactv(j,l)=cv(1,j)/zmasse(j,l)
+     enddo
+  enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  ! PRINT*,'3OK'
+  !   --------------------------------------------------------------
+  !   calcul de la moyenne zonale du transport :
+  !   ------------------------------------------
+  !
+  !                                 --
+  ! TOT : la circulation totale       [ vq ]
+  !
+  !                                  -     -
+  ! MMC : mean meridional circulation [ v ] [ q ]
+  !
+  !                                 ----      --       - -
+  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+  !
+  !                                 - * - *       - -       -     -
+  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+  !
+  !                                          - -
+  !    on utilise aussi l'intermediaire TMP :  [ v q ]
+  !
+  !    la variable zfactv transforme un transport meridien cumule
+  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+  !
+  !   --------------------------------------------------------------
+
+
+  !   ----------------------------------------
+  !   Transport dans le plan latitude-altitude
+  !   ----------------------------------------
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  zvQ=0.
+  psiQ=0.
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        zvQtmp(:,l)=0.
+        do j=jjb,jje
+           ! PRINT*,'j,l,iQ=',j,l,iQ
+  !   Calcul des moyennes zonales du transort total et de zvQtmp
+           do i=1,iim
+              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
+                    +flux_vQ_cum(i,j,l,iQ)
+              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
+                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
+                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+           enddo
+           ! PRINT*,'aOK'
+  !   Decomposition
+           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+  !   fonction de courant meridienne pour la quantite Q
+!$OMP BARRIER
+!$OMP MASTER
+     do l=llm,1,-1
+        do j=jjb,jje
+           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+        enddo
+     enddo
+!$OMP END MASTER
+!$OMP BARRIER
+  enddo
+
+  !   fonction de courant pour la circulation meridienne moyenne
+!$OMP BARRIER
+!$OMP MASTER
+  psi(jjb:jje,:)=0.
+  do l=llm,1,-1
+     do j=jjb,jje
+        psi(j,l)=psi(j,l+1)+zv(j,l)
+        zv(j,l)=zv(j,l)*zfactv(j,l)
+     enddo
+  enddo
+!$OMP END MASTER
+!$OMP BARRIER
+
+  ! PRINT*,'4OK'
+  !   sorties proprement dites
+!$OMP MASTER
+  if (i_sortie==1) then
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+  do iQ=1,nQ
+     do itr=1,ntr
+        CALL histwrite(fileid,znom(itr,iQ),itau, &
+              zvQ(jjb:jje,:,itr,iQ) &
+              ,jjn*llm,ndex3d)
+     enddo
+     CALL histwrite(fileid,'psi'//nom(iQ), &
+           itau,psiQ(jjb:jje,1:llm,iQ) &
+           ,jjn*llm,ndex3d)
+  enddo
+
+  CALL histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  CALL histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
+  CALL histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), &
+        jjn*llm,ndex3d)
+
+  endif
+
+
+  !   -----------------
+  !   Moyenne verticale
+  !   -----------------
+
+  zamasse(jjb:jje)=0.
+  do l=1,llm
+     zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
+  enddo
+
+  zavQ(jjb:jje,:,:)=0.
+  do iQ=1,nQ
+     do itr=2,ntr
+        do l=1,llm
+           zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) &
+                 +zvQ(jjb:jje,l,itr,iQ) &
+                 *zmasse(jjb:jje,l)
+        enddo
+        zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
+        CALL histwrite(fileid,'a'//znom(itr,iQ),itau, &
+              zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
+     enddo
+  enddo
+!$OMP END MASTER
+  ! on doit pouvoir tracer systematiquement la fonction de courant.
+
+  !=====================================================================
+  !/////////////////////////////////////////////////////////////////////
+  icum=0                  !///////////////////////////////////////
+  endif ! icum.eq.ncum    !///////////////////////////////////////
+  !/////////////////////////////////////////////////////////////////////
+  !=====================================================================
+!$OMP MASTER
+  CALL histsync(fileid)
+!$OMP END MASTER
+
+
+
+end subroutine bilan_dyn_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/caldyn_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/caldyn_loc.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/caldyn_loc.f90	(revision 5105)
@@ -179,4 +179,4 @@
   ! Ehouarn: NB: output of control variables not implemented...
 
-  RETURN
+
 END SUBROUTINE caldyn_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/conf_gcm.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/conf_gcm.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/conf_gcm.F90	(revision 5105)
@@ -2,5 +2,5 @@
 ! $Id$
 
-SUBROUTINE conf_gcm( tapedef, etatinit )conf_gcm
+SUBROUTINE conf_gcm( tapedef, etatinit )
 
   USE control_mod
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/convflu_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convflu_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,84 +1,0 @@
-      SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl )
-c
-c  P. Le Van
-c
-c
-c    *******************************************************************
-c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
-c      composantes xflu et yflu ,variables extensives .  ......
-c    *******************************************************************
-c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
-c      convfl                est  un argument de sortie pour le s-pg .
-c
-c     njxflu  est le nombre de lignes de latitude de xflu, 
-c     ( = jjm ou jjp1 )
-c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      REAL       xflu,yflu,convfl,convpn,convps
-      INTEGER    l,ij,nbniv
-      DIMENSION  xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) ,
-     *         convfl( ijb_u:ije_u,nbniv )
-c
-      INTEGER ijb,ije
-      EXTERNAL   SSUM
-      REAL       SSUM
-c
-c
-      INCLUDE "comgeom.h"
-c
-     
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
-      DO l = 1,nbniv
-c
-        ijb=ij_begin
-        ije=ij_end+iip1
-      
-        IF (pole_nord) ijb=ij_begin+iip1
-        IF (pole_sud)  ije=ij_end-iip1
-        
-        DO ij = ijb , ije - 1
-          convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   +
-     *                     yflu(ij +1,l ) - yflu( ij -iim,l )
-      END DO
-c
-c
-
-c     ....  correction pour  convfl( 1,j,l)  ......
-c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
-c
-CDIR$ IVDEP
-        DO ij = ijb,ije,iip1
-          convfl( ij,l ) = convfl( ij + iim,l )
-      END DO
-c
-c     ......  calcul aux poles  .......
-c
-        IF (pole_nord) THEN
-      
-          convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
-        
-          DO ij = 1,iip1
-            convfl(ij,l) = convpn * aire(ij) / apoln
-          ENDDO
-        
-        ENDIF
-      
-        IF (pole_sud) THEN
-        
-          convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
-        
-          DO ij = 1,iip1
-            convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
-          ENDDO
-        
-        ENDIF
-      
-      END DO
-c$OMP END DO NOWAIT   
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convflu_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convflu_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convflu_loc.f90	(revision 5105)
@@ -0,0 +1,84 @@
+SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl )
+  !
+  !  P. Le Van
+  !
+  !
+  !    *******************************************************************
+  !  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+  !  composantes xflu et yflu ,variables extensives .  ......
+  !    *******************************************************************
+  !  xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+  !  convfl                est  un argument de sortie pour le s-pg .
+  !
+  ! njxflu  est le nombre de lignes de latitude de xflu,
+  ! ( = jjm ou jjp1 )
+  ! nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  REAL :: xflu,yflu,convfl,convpn,convps
+  INTEGER :: l,ij,nbniv
+  DIMENSION  xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) , &
+        convfl( ijb_u:ije_u,nbniv )
+  !
+  INTEGER :: ijb,ije
+  EXTERNAL   SSUM
+  REAL :: SSUM
+  !
+  !
+  INCLUDE "comgeom.h"
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,nbniv
+  !
+    ijb=ij_begin
+    ije=ij_end+iip1
+
+    IF (pole_nord) ijb=ij_begin+iip1
+    IF (pole_sud)  ije=ij_end-iip1
+
+    DO ij = ijb , ije - 1
+      convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   + &
+            yflu(ij +1,l ) - yflu( ij -iim,l )
+  END DO
+  !
+  !
+
+  ! ....  correction pour  convfl( 1,j,l)  ......
+  ! ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+  !
+  !DIR$ IVDEP
+    DO ij = ijb,ije,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+  END DO
+  !
+  ! ......  calcul aux poles  .......
+  !
+    IF (pole_nord) THEN
+
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+
+      DO ij = 1,iip1
+        convfl(ij,l) = convpn * aire(ij) / apoln
+      ENDDO
+
+    ENDIF
+
+    IF (pole_sud) THEN
+
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+
+      DO ij = 1,iip1
+        convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
+      ENDDO
+
+    ENDIF
+
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE convflu_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,59 +1,0 @@
-      SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
-      USE parallel_lmdz
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c  *********************************************************************
-c    calcul des compos. contravariantes a partir des comp.covariantes
-c  ********************************************************************
-c
-c=======================================================================
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      INTEGER klevel
-      REAL ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
-      REAL ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      INTEGER ijbu,ijbv,ijeu,ijev
-
-      
-      ijbu=ij_begin-iip1
-      ijbv=ij_begin-iip1
-      ijeu=ij_end+iip1
-      ijev=ij_end+iip1
-      
-      if (pole_nord) then 
-        ijbu=ij_begin+iip1
-        ijbv=ij_begin
-      endif
-      
-      if (pole_sud) then
-        ijeu=ij_end-iip1
-        ijev=ij_end-iip1
-      endif
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO l = 1,klevel
-
-      DO ij = ijb_u,ije_u
-      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
-      END DO
-
-      DO ij = ijb_v,ije_v
-      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
-      END DO
-
-      END DO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.f90	(revision 5105)
@@ -0,0 +1,59 @@
+SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
+  USE parallel_lmdz
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !  *********************************************************************
+  !    calcul des compos. contravariantes a partir des comp.covariantes
+  !  ********************************************************************
+  !
+  !=======================================================================
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  INTEGER :: klevel
+  REAL :: ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+  REAL :: ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijbu,ijbv,ijeu,ijev
+
+
+  ijbu=ij_begin-iip1
+  ijbv=ij_begin-iip1
+  ijeu=ij_end+iip1
+  ijev=ij_end+iip1
+
+  if (pole_nord) then
+    ijbu=ij_begin+iip1
+    ijbv=ij_begin
+  endif
+
+  if (pole_sud) then
+    ijeu=ij_end-iip1
+    ijev=ij_end-iip1
+  endif
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+
+  DO ij = ijb_u,ije_u
+  ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+  END DO
+
+  DO ij = ijb_v,ije_v
+  vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+  END DO
+
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE covcont_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/covnat_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covnat_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,84 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
-      USE parallel_lmdz
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  F Hourdin Phu LeVan
-c   -------
-c
-c   Objet:
-c   ------
-c
-c  *********************************************************************
-c    calcul des compos. naturelles a partir des comp.covariantes
-c  ********************************************************************
-c
-c=======================================================================
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      INTEGER klevel
-      REAL ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
-      REAL unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      INTEGER :: ijb,ije
-      
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-      if (pole_nord) then
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l = 1,klevel
-           DO ij = 1, iip1
-              unat (ij,l) =0.
-           END DO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-
-      if (pole_sud) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l = 1,klevel
-           DO ij = ip1jm+1, ip1jmp1  
-            unat (ij,l) =0.
-           END DO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l = 1,klevel
-         DO ij = ijb, ije
-            unat( ij,l ) = ucov( ij,l ) / cu(ij)
-         ENDDO
-      END DO
-!$OMP ENDDO NOWAIT
-
-      ijb=ij_begin-iip1
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-     
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l = 1,klevel
-         DO ij = ijb,ije
-            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
-         ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-      
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covnat_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covnat_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covnat_loc.f90	(revision 5105)
@@ -0,0 +1,84 @@
+
+! $Header$
+
+SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
+  USE parallel_lmdz
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  F Hourdin Phu LeVan
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !  *********************************************************************
+  !    calcul des compos. naturelles a partir des comp.covariantes
+  !  ********************************************************************
+  !
+  !=======================================================================
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  INTEGER :: klevel
+  REAL :: ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+  REAL :: unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+
+
+  ijb=ij_begin
+  ije=ij_end
+
+  if (pole_nord) then
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1,klevel
+       DO ij = 1, iip1
+          unat (ij,l) =0.
+       END DO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1,klevel
+       DO ij = ip1jm+1, ip1jmp1
+        unat (ij,l) =0.
+       END DO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+     DO ij = ijb, ije
+        unat( ij,l ) = ucov( ij,l ) / cu(ij)
+     ENDDO
+  END DO
+!$OMP ENDDO NOWAIT
+
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+     DO ij = ijb,ije
+        vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+
+END SUBROUTINE covnat_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dissip_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dissip_loc.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dissip_loc.f90	(revision 5105)
@@ -226,4 +226,4 @@
   !$OMP END DO NOWAIT
 
-  RETURN
+
 END SUBROUTINE dissip_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,98 +1,0 @@
-      SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam,
-     *                       unsapolnga,unsapolsga,  x, y,  div )
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
-      REAL div( ijb_u:ije_u,klevel )
-      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
-      REAL unsapolnga,unsapolsga
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-      INTEGER   l,ij
-c    ...................................................................
-c
-      EXTERNAL  SSUM
-      REAL      SSUM
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if(pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l = 1,klevel
-c
-        DO  ij = ijb, ije - 1
-         div( ij + 1, l )     = (  
-     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
-     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
-     *         unsairegam( ij+1 )
-        ENDDO
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-        DO  ij = ijb,ije,iip1
-         div( ij,l ) = div( ij + iim,l )
-        ENDDO
-c
-c     ....  calcul  aux poles  .....
-c
-       if (pole_nord) then
-          DO  ij  = 1,iim
-           aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
-          ENDDO
-          sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
-c  
-          DO  ij = 1,iip1
-           div(     ij    , l ) = - sumypn 
-          ENDDO
-       endif
-        
-        if (pole_sud) then
-          DO  ij  = 1,iim
-           aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
-          ENDDO
-          sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
-c  
-          DO  ij = 1,iip1
-           div( ij + ip1jm, l ) =   sumyps 
-          ENDDO
-       endif
-      END DO
-c$OMP END DO NOWAIT
-c
-
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.f90	(revision 5105)
@@ -0,0 +1,98 @@
+SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam, &
+        unsapolnga,unsapolsga,  x, y,  div )
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
+  REAL :: div( ijb_u:ije_u,klevel )
+  REAL :: cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+  REAL :: unsapolnga,unsapolsga
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: l,ij
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = ( &
+           cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + &
+           cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* &
+           unsairegam( ij+1 )
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+   if (pole_nord) then
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+   endif
+
+    if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+   endif
+  END DO
+!$OMP END DO NOWAIT
+  !
+
+
+END SUBROUTINE diverg_gam_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.F	(revision 5104)
+++ 	(revision )
@@ -1,106 +1,0 @@
-      SUBROUTINE diverg_p(klevel,x,y,div)
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
-      INTEGER   l,ij
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-      INTEGER ijb,ije
-c    ...................................................................
-c
-      EXTERNAL  SSUM
-      REAL      SSUM
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if(pole_sud)  ije=ij_end-iip1
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l = 1,klevel
-c
-        DO  ij = ijb, ije - 1
-         div( ij + 1, l )     =  
-     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
-     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
-        ENDDO
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-        DO  ij = ijb,ije,iip1
-         div( ij,l ) = div( ij + iim,l )
-        ENDDO
-c
-c     ....  calcul  aux poles  .....
-c
-        if (pole_nord) then
-          DO  ij  = 1,iim
-           aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
-          ENDDO
-          sumypn = SSUM ( iim,aiy1,1 ) / apoln
-c
-          DO  ij = 1,iip1
-           div(     ij    , l ) = - sumypn
-          ENDDO
-        endif
-         
-       if (pole_sud) then
-          DO  ij  = 1,iim
-           aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
-          ENDDO
-          sumyps = SSUM ( iim,aiy2,1 ) / apols
-c
-          DO  ij = 1,iip1
-           div( ij + ip1jm, l ) =   sumyps
-          ENDDO
-        endif
-
-
-      END DO
-c$OMP END DO NOWAIT
-c
-
-ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
-      
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l = 1, klevel
-           DO ij = ijb,ije
-            div(ij,l) = div(ij,l) * unsaire(ij) 
-          ENDDO
-        ENDDO
-c$OMP END DO NOWAIT
-c
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.f90	(revision 5105)
@@ -0,0 +1,106 @@
+SUBROUTINE diverg_p(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: ijb,ije
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    if (pole_nord) then
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) / apoln
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+    endif
+
+   if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+    endif
+
+
+  END DO
+!$OMP END DO NOWAIT
+  !
+
+  !cc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+       DO ij = ijb,ije
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+
+END SUBROUTINE diverg_p
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,118 +1,0 @@
-      SUBROUTINE divergf_loc(klevel,x,y,div)
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
-      REAL div( ijb_u:ije_u,klevel )
-      INTEGER   l,ij
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-c    ...................................................................
-c
-      EXTERNAL  SSUM
-      REAL      SSUM
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if(pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l = 1,klevel
-c
-        DO  ij = ijb, ije - 1
-         div( ij + 1, l )     =  
-     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
-     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
-        ENDDO
-
-c
-c     ....  correction pour  div( 1,j,l)  ......
-c     ....   div(1,j,l)= div(iip1,j,l) ....
-c
-CDIR$ IVDEP
-        DO  ij = ijb,ije,iip1
-         div( ij,l ) = div( ij + iim,l )
-        ENDDO
-c
-c     ....  calcul  aux poles  .....
-c
-        if (pole_nord) then
-        
-          DO  ij  = 1,iim
-           aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
-          ENDDO
-          sumypn = SSUM ( iim,aiy1,1 ) / apoln
-
-c
-          DO  ij = 1,iip1
-           div(     ij    , l ) = - sumypn
-          ENDDO
-          
-        endif
-        
-        if (pole_sud) then
-        
-          DO  ij  = 1,iim
-           aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
-          ENDDO
-          sumyps = SSUM ( iim,aiy2,1 ) / apols
-c
-          DO  ij = 1,iip1
-           div( ij + ip1jm, l ) =   sumyps
-          ENDDO
-          
-        endif
-        
-      END DO
-c$OMP END DO NOWAIT
-
-c
-        jjb=jj_begin
-        jje=jj_end
-        if (pole_sud) jje=jj_end-1
-        
-        CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1,
-     &                   klevel, 2, 2, .TRUE., 1 )
-      
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l = 1, klevel
-           DO ij = ijb,ije
-            div(ij,l) = div(ij,l) * unsaire(ij) 
-          ENDDO
-        ENDDO
-c$OMP END DO NOWAIT
-c
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.f90	(revision 5105)
@@ -0,0 +1,118 @@
+SUBROUTINE divergf_loc(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
+  REAL :: div( ijb_u:ije_u,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    if (pole_nord) then
+
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) / apoln
+
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+
+    endif
+
+    if (pole_sud) then
+
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+
+    endif
+
+  END DO
+!$OMP END DO NOWAIT
+
+  !
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+
+    CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1, &
+          klevel, 2, 2, .TRUE., 1 )
+
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+       DO ij = ijb,ije
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+
+END SUBROUTINE divergf_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/divgrad2_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divgrad2_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,121 +1,0 @@
-      SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
-c
-c     P. Le Van
-c
-c   ***************************************************************
-c
-c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
-c   ****************************************************************
-c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
-c         divgra     est  un argument  de sortie pour le s-prg
-c
-      USE parallel_lmdz
-      USE times
-      USE mod_hallo
-      USE divgrad2_mod
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom2.h"
-      INCLUDE "comdissipn.h"
-
-c    .......    variables en arguments   .......
-c
-      INTEGER klevel
-      REAL h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel )
-      REAL divgra_out( ijb_u:ije_u,klevel)
-c    .......    variables  locales    ..........
-c
-      REAL     signe, nudivgrs, sqrtps( ijb_u:ije_u,llm )
-      INTEGER  l,ij,iter,lh
-c    ...................................................................
-      Type(Request),SAVE :: request_dissip
-!$OMP THREADPRIVATE(request_dissip)
-      INTEGER ijb,ije
-
-c
-c
-      signe    = (-1.)**lh
-      nudivgrs = signe * cdivh
-
-c      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
-      ijb=ij_begin
-      ije=ij_end
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1, klevel
-        divgra(ijb:ije,l)=h(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-c
-c$OMP BARRIER
-       CALL Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      CALL laplacien_loc( klevel, divgra, divgra )
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
-      DO l = 1, klevel
-       DO ij = ijb, ije
-        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
-      DO l = 1, klevel
-        DO ij = ijb, ije
-         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-   
-c    ........    Iteration de l'operateur  laplacien_gam    ........
-c
-      DO  iter = 1, lh - 2
-c$OMP BARRIER
-       CALL Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-
-c$OMP BARRIER
-
-
-       CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
-     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
-      ENDDO
-c
-c    ...............................................................
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
-      DO l = 1, klevel
-        DO ij = ijb, ije
-          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-c
-c$OMP BARRIER
-       CALL Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      CALL laplacien_loc ( klevel, divgra, divgra )
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l  = 1,klevel
-      DO ij = ijb,ije
-      divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
-      ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divgrad2_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divgrad2_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divgrad2_loc.f90	(revision 5105)
@@ -0,0 +1,121 @@
+SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
+  !
+  ! P. Le Van
+  !
+  !   ***************************************************************
+  !
+  ! .....   calcul de  (div( grad ))   de (  pext * h ) .....
+  !   ****************************************************************
+  !   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+  !     divgra     est  un argument  de sortie pour le s-prg
+  !
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE divgrad2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom2.h"
+  INCLUDE "comdissipn.h"
+
+  !    .......    variables en arguments   .......
+  !
+  INTEGER :: klevel
+  REAL :: h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel )
+  REAL :: divgra_out( ijb_u:ije_u,klevel)
+  !    .......    variables  locales    ..........
+  !
+  REAL :: signe, nudivgrs, sqrtps( ijb_u:ije_u,llm )
+  INTEGER :: l,ij,iter,lh
+  !    ...................................................................
+  Type(Request),SAVE :: request_dissip
+!$OMP THREADPRIVATE(request_dissip)
+  INTEGER :: ijb,ije
+
+  !
+  !
+  signe    = (-1.)**lh
+  nudivgrs = signe * cdivh
+
+   ! CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    divgra(ijb:ije,l)=h(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+!$OMP BARRIER
+   CALL Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL laplacien_loc( klevel, divgra, divgra )
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+   DO ij = ijb, ije
+    sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+     divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !    ........    Iteration de l'operateur  laplacien_gam    ........
+  !
+  DO  iter = 1, lh - 2
+!$OMP BARRIER
+   CALL Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+
+!$OMP BARRIER
+
+
+   CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2, &
+         unsapolnga2, unsapolsga2,  divgra, divgra )
+  ENDDO
+  !
+  !    ...............................................................
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+      divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+!$OMP BARRIER
+   CALL Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL laplacien_loc ( klevel, divgra, divgra )
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l  = 1,klevel
+  DO ij = ijb,ije
+  divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+  ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+
+END SUBROUTINE divgrad2_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,90 +1,0 @@
-      SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
-      USE parallel_lmdz
-      USE write_field_p
-      USE mod_filtreg_p
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
-c
-c   ********************************************************************
-c   ... calcul du terme de convergence horizontale du flux d'enthalpie
-c        potentielle   ......
-c   ********************************************************************
-c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
-c     dteta 	          sont des arguments de sortie pour le s-pg ....
-c
-c=======================================================================
-
-
-      include "dimensions.h"
-      include "paramet.h"
-
-      REAL teta( ijb_u:ije_u,llm )
-      REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
-      REAL dteta( ijb_u:ije_u,llm )
-      INTEGER   l,ij
-
-      REAL hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm )
-
-c
-      INTEGER ijb,ije,jjb,jje
-
-      
-      jjb=jj_begin
-      jje=jj_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO l = 1,llm
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb, ije - 1
-        hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
-      END DO
-
-c    .... correction pour  hbxu(iip1,j,l)  .....
-c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
-
-CDIR$ IVDEP
-      DO ij = ijb+iip1-1, ije, iip1
-        hbxu( ij, l ) = hbxu( ij - iim, l )
-      END DO
-
-      ijb=ij_begin-iip1
-      if (pole_nord) ijb=ij_begin
-      
-      DO ij = ijb,ije
-        hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
-      END DO
-
-       if (.not. pole_sud) then
-	  hbxu(ije+1:ije+iip1,l) = 0
-	  hbyv(ije+1:ije+iip1,l) = 0
-	endif
-	
-      END DO
-c$OMP END DO NOWAIT
-       
-	
-        CALL  convflu_loc ( hbxu, hbyv, llm, dteta )
-
-
-c    stockage dans  dh de la convergence horizont. filtree' du  flux
-c                  ....                           ...........
-c           d'enthalpie potentielle .
-      
-      
-      CALL filtreg_p( dteta,jjb_u,jje_u,jjb,jje,jjp1, llm, 
-     &                2, 2, .TRUE., 1)
-      
-      
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.f90	(revision 5105)
@@ -0,0 +1,90 @@
+SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
+  USE parallel_lmdz
+  USE write_field_p
+  USE mod_filtreg_p
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+  !
+  !   ********************************************************************
+  !   ... calcul du terme de convergence horizontale du flux d'enthalpie
+  !    potentielle   ......
+  !   ********************************************************************
+  !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+  ! dteta 	          sont des arguments de sortie pour le s-pg ....
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  REAL :: teta( ijb_u:ije_u,llm )
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: dteta( ijb_u:ije_u,llm )
+  INTEGER :: l,ij
+
+  REAL :: hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm )
+
+  !
+  INTEGER :: ijb,ije,jjb,jje
+
+
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+
+  ijb=ij_begin
+  ije=ij_end
+
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb, ije - 1
+    hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
+  END DO
+
+  !    .... correction pour  hbxu(iip1,j,l)  .....
+  !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+    hbxu( ij, l ) = hbxu( ij - iim, l )
+  END DO
+
+  ijb=ij_begin-iip1
+  if (pole_nord) ijb=ij_begin
+
+  DO ij = ijb,ije
+    hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
+  END DO
+
+   if (.not. pole_sud) then
+      hbxu(ije+1:ije+iip1,l) = 0
+      hbyv(ije+1:ije+iip1,l) = 0
+    endif
+
+  END DO
+!$OMP END DO NOWAIT
+
+
+    CALL  convflu_loc ( hbxu, hbyv, llm, dteta )
+
+
+  !    stockage dans  dh de la convergence horizont. filtree' du  flux
+               ! ....                           ...........
+        ! d'enthalpie potentielle .
+
+
+  CALL filtreg_p( dteta,jjb_u,jje_u,jjb,jje,jjp1, llm, &
+        2, 2, .TRUE., 1)
+
+
+
+END SUBROUTINE dteta1_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,65 +1,0 @@
-      SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c-----------------------------------------------------------------------
-c
-c   Auteur:   P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c   calcul du terme de  rotation
-c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
-c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
-c   du  et dv              sont des arguments de sortie pour le s-pg ..
-c
-c-----------------------------------------------------------------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-
-      REAL vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) ,
-     *     pbarv( ijb_v:ije_v,llm )
-      REAL du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm )
-      INTEGER  l,ij,ijb,ije
-c
-c
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l = 1,llm
-c
-      ijb=ij_begin
-      ije=ij_end
-      
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb, ije-1
-      du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) *
-     *                    (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) +
-     *                        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
-      END DO
-   
- 
-c
-      if (pole_nord) ijb=ij_begin
-      
-      DO ij = ijb, ije-1
-      dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) *
-     *                        (   pbaru(ij, l)  +  pbaru(ij+1   , l) +
-     *                       pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
-      END DO
-c
-c    .... correction  pour  dv( 1,j,l )  .....
-c    ....   dv(1,j,l)= dv(iip1,j,l) ....
-c
-CDIR$ IVDEP
-      DO ij = ijb, ije, iip1
-      dv( ij,l ) = dv( ij + iim, l )
-      END DO
-c
-      END DO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.f90	(revision 5105)
@@ -0,0 +1,65 @@
+SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !-----------------------------------------------------------------------
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !   calcul du terme de  rotation
+  !   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
+  !   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
+  !   du  et dv              sont des arguments de sortie pour le s-pg ..
+  !
+  !-----------------------------------------------------------------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+
+  REAL :: vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) , &
+        pbarv( ijb_v:ije_v,llm )
+  REAL :: du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm )
+  INTEGER :: l,ij,ijb,ije
+  !
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb, ije-1
+  du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) * &
+        (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) + &
+        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
+  END DO
+
+
+  !
+  if (pole_nord) ijb=ij_begin
+
+  DO ij = ijb, ije-1
+  dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) * &
+        (   pbaru(ij, l)  +  pbaru(ij+1   , l) + &
+        pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
+  END DO
+  !
+  !    .... correction  pour  dv( 1,j,l )  .....
+  !    ....   dv(1,j,l)= dv(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+  DO ij = ijb, ije, iip1
+  dv( ij,l ) = dv( ij + iim, l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE dudv1_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,69 +1,0 @@
-      SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   *****************************************************************
-c   ..... calcul du terme de pression (gradient de p/densite )   et
-c          du terme de ( -gradient de la fonction de Bernouilli ) ...
-c   *****************************************************************
-c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
-c
-c
-c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
-c    du et dv          sont des arguments de sortie pour le s-pg  ....
-c
-c=======================================================================
-c
-      include "dimensions.h"
-      include "paramet.h"
-
-      REAL teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm )
-      REAL bern( ijb_u:ije_u,llm )
-      REAL du( ijb_u:ije_u,llm ),  dv( ijb_v:ije_v,llm )
-      INTEGER  l,ij,ijb,ije
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1,llm
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ijb+iip1
-      if (pole_sud)  ije=ije-iip1
-
-      DO ij  = ijb, ije - 1
-       du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) *
-     * ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
-      END DO
-c
-c
-c    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
-c    ...          du(iip1,j,l) = du(1,j,l)                 ...
-c
-CDIR$ IVDEP
-      DO ij = ijb+iip1-1, ije, iip1
-      du( ij,l ) = du( ij - iim,l )
-      END DO
-c
-c
-      if (pole_nord) ijb=ijb-iip1
-
-      DO ij  = ijb,ije
-      dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) *
-     *                             ( pkf(ij+iip1,l) - pkf(  ij,l  ) )
-     *                           +   bern( ij+iip1,l ) - bern( ij  ,l )
-      END DO
-c
-      END DO
-c$OMP END DO NOWAIT 
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.f90	(revision 5105)
@@ -0,0 +1,69 @@
+SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   *****************************************************************
+  !   ..... calcul du terme de pression (gradient de p/densite )   et
+  !      du terme de ( -gradient de la fonction de Bernouilli ) ...
+  !   *****************************************************************
+  !      Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+  !
+  !
+  !    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+  !    du et dv          sont des arguments de sortie pour le s-pg  ....
+  !
+  !=======================================================================
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+  REAL :: teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm )
+  REAL :: bern( ijb_u:ije_u,llm )
+  REAL :: du( ijb_u:ije_u,llm ),  dv( ijb_v:ije_v,llm )
+  INTEGER :: l,ij,ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+
+  DO ij  = ijb, ije - 1
+   du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * &
+         ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
+  END DO
+  !
+  !
+  !    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
+  !    ...          du(iip1,j,l) = du(1,j,l)                 ...
+  !
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+  du( ij,l ) = du( ij - iim,l )
+  END DO
+  !
+  !
+  if (pole_nord) ijb=ijb-iip1
+
+  DO ij  = ijb,ije
+  dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * &
+        ( pkf(ij+iip1,l) - pkf(  ij,l  ) ) &
+        +   bern( ij+iip1,l ) - bern( ij  ,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  !
+
+END SUBROUTINE dudv2_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/filtreg_p.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/filtreg_p.F	(revision 5104)
+++ 	(revision )
@@ -1,431 +1,0 @@
-
-
-      SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, 
-     &     ifiltre, iaire, griscal ,iter)
-      USE parallel_lmdz, ONLY: OMP_CHUNK
-      USE mod_filtre_fft
-      USE timer_filtre
-      
-      USE filtreg_mod
-      
-      IMPLICIT NONE
-      
-c=======================================================================
-c
-c   Auteur: P. Le Van        07/10/97
-c   ------
-c
-c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
-c                     pour l'operateur  Filtre    .
-c   ------
-c
-c   Arguments:
-c   ----------
-c
-c      
-c      ibeg..iend            lattitude a filtrer
-c      nlat                  nombre de latitudes du champ
-c      nbniv                 nombre de niveaux verticaux a filtrer
-c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
-c                            en sortie : champ filtre
-c      ifiltre               +1  Transformee directe
-c                            -1  Transformee inverse
-c                            +2  Filtre directe
-c                            -2  Filtre inverse
-c
-c      iaire                 1   si champ intensif
-c                            2   si champ extensif (pondere par les aires)
-c
-c      iter                  1   filtre simple
-c
-c=======================================================================
-c
-c
-c                      Variable Intensive
-c                ifiltre = 1     filtre directe
-c                ifiltre =-1     filtre inverse
-c
-c                      Variable Extensive
-c                ifiltre = 2     filtre directe
-c                ifiltre =-2     filtre inverse
-c
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "coefils.h"
-c
-      INTEGER ibeg,iend,nlat,nbniv,ifiltre,iter
-      INTEGER i,j,l,k
-      INTEGER iim2,immjm
-      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
-      
-      REAL  champ( iip1,nlat,nbniv)
-      
-      LOGICAL    griscal
-      INTEGER    hemisph, iaire
-      
-      REAL :: champ_fft(iip1,nlat,nbniv)
-      REAL :: champ_in(iip1,nlat,nbniv)
-      
-      LOGICAL,SAVE     :: first=.TRUE.
-c$OMP THREADPRIVATE(first) 
-
-      REAL, DIMENSION(iip1,nlat,nbniv) :: champ_loc
-      INTEGER :: ll_nb, nbniv_loc
-      REAL, SAVE :: sdd12(iim,4)
-c$OMP THREADPRIVATE(sdd12) 
-
-      INTEGER, PARAMETER :: type_sddu=1
-      INTEGER, PARAMETER :: type_sddv=2
-      INTEGER, PARAMETER :: type_unsddu=3
-      INTEGER, PARAMETER :: type_unsddv=4
-
-      INTEGER :: sdd1_type, sdd2_type
-
-      IF (first) THEN
-         sdd12(1:iim,type_sddu) = sddu(1:iim)
-         sdd12(1:iim,type_sddv) = sddv(1:iim)
-         sdd12(1:iim,type_unsddu) = unsddu(1:iim)
-         sdd12(1:iim,type_unsddv) = unsddv(1:iim)
-
-         CALL Init_timer
-         first=.FALSE.
-      ENDIF
-
-c$OMP MASTER      
-      CALL start_timer
-c$OMP END MASTER
-
-c-------------------------------------------------------c
-
-      IF(ifiltre==1.or.ifiltre==-1)
-     & CALL abort_gcm("fitreg_p","Pas de transformee simple 
-     &dans cette version",1)
-      
-      IF( iter== 2 )  THEN
-         PRINT *,' Pas d iteration du filtre dans cette version !'
-     &        , ' Utiliser old_filtreg et repasser !'
-         CALL abort_gcm("fitreg_p","stopped",1)
-      ENDIF
-
-      IF( ifiltre== -2 .AND..NOT.griscal )     THEN
-         PRINT *,' Cette routine ne calcule le filtre inverse que '
-     &        , ' sur la grille des scalaires !'
-         CALL abort_gcm("fitreg_p","stopped",1)
-      ENDIF
-
-      IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
-         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
-     &        , ' corriger et repasser !'
-         CALL abort_gcm("fitreg_p","stopped",1)
-       ENDIF
-c
-
-      iim2   = iim * iim
-      immjm  = iim * jjm
-c
-c
-      IF( griscal )   THEN
-         IF( nlat. NE. jjp1 )  THEN
-            CALL abort_gcm("fitreg_p","nlat. NE. jjp1",1)
-         ELSE
-c     
-            IF( iaire==1 )  THEN
-               sdd1_type = type_sddv
-               sdd2_type = type_unsddv
-            ELSE
-               sdd1_type = type_unsddv
-               sdd2_type = type_sddv
-            ENDIF
-c
-            jdfil1 = 2
-            jffil1 = jfiltnu
-            jdfil2 = jfiltsu
-            jffil2 = jjm
-         ENDIF
-      ELSE
-         IF( nlat/=jjm )  THEN
-            CALL abort_gcm("fitreg_p","nlat. NE. jjm",1)
-         ELSE
-c
-            IF( iaire==1 )  THEN
-               sdd1_type = type_sddu
-               sdd2_type = type_unsddu
-            ELSE
-               sdd1_type = type_unsddu
-               sdd2_type = type_sddu
-            ENDIF
-c     
-            jdfil1 = 1
-            jffil1 = jfiltnv
-            jdfil2 = jfiltsv
-            jffil2 = jjm
-         ENDIF
-      ENDIF
-c      
-      DO hemisph = 1, 2
-c     
-         IF ( hemisph==1 )  THEN
-cym
-            jdfil = max(jdfil1,ibeg)
-            jffil = min(jffil1,iend)
-         ELSE
-cym
-            jdfil = max(jdfil2,ibeg)
-            jffil = min(jffil2,iend)
-         ENDIF
-
-
-cccccccccccccccccccccccccccccccccccccccccccc
-c Utilisation du filtre classique
-cccccccccccccccccccccccccccccccccccccccccccc
-
-         IF (.NOT. use_filtre_fft) THEN
-      
-c     !---------------------------------!
-c     ! Agregation des niveau verticaux !
-c     ! uniquement necessaire pour une  !
-c     ! execution OpenMP                !
-c     !---------------------------------!
-            ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l = 1, nbniv
-               ll_nb = ll_nb+1
-               DO j = jdfil,jffil
-                  DO i = 1, iim
-                     champ_loc(i,j,ll_nb) = 
-     &                    champ(i,j,l) * sdd12(i,sdd1_type)
-                  ENDDO
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-
-            nbniv_loc = ll_nb
-
-            IF( hemisph==1 )      THEN
-               
-               IF( ifiltre==-2 )   THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matrinvn(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*nlat, 0.0,
-     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
-#else
-                     champ_fft(:iim,j-jdfil+1,:)
-     &                    =matmul(matrinvn(:,:,j),champ_loc(:iim,j,:))
-#endif
-                  ENDDO
-                  
-               ELSE IF ( griscal )     THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matriceun(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*nlat, 0.0,
-     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
-#else
-                     champ_fft(:iim,j-jdfil+1,:)
-     &                    =matmul(matriceun(:,:,j),champ_loc(:iim,j,:))
-#endif
-                  ENDDO
-                  
-               ELSE 
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matricevn(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
-     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
-#else
-                     champ_fft(:iim,j-jdfil+1,:)
-     &                    =matmul(matricevn(:,:,j),champ_loc(:iim,j,:))
-#endif
-                  ENDDO
-                  
-               ENDIF
-               
-            ELSE
-               
-               IF( ifiltre==-2 )   THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matrinvs(1,1,j-jfiltsu+1), iim, 
-     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
-     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
-#else
-                     champ_fft(:iim,j-jdfil+1,:)
-     &                    =matmul(matrinvs(:,:,j-jfiltsu+1),
-     &                            champ_loc(:iim,j,:))
-#endif
-                  ENDDO
-                  
-               ELSE IF ( griscal )     THEN
-                  
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matriceus(1,1,j-jfiltsu+1), iim, 
-     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
-     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
-#else
-                     champ_fft(:iim,j-jdfil+1,:)
-     &                    =matmul(matriceus(:,:,j-jfiltsu+1),
-     &                            champ_loc(:iim,j,:))
-#endif
-                  ENDDO
-                  
-               ELSE 
-                  
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matricevs(1,1,j-jfiltsv+1), iim, 
-     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
-     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
-#else
-                     champ_fft(:iim,j-jdfil+1,:)
-     &                    =matmul(matricevs(:,:,j-jfiltsv+1),
-     &                            champ_loc(:iim,j,:))
-#endif
-                  ENDDO
-                  
-               ENDIF
-               
-            ENDIF
-!     c     
-            IF( ifiltre==2 )  THEN
-               
-c     !-------------------------------------!
-c     ! Dés-agregation des niveau verticaux !
-c     ! uniquement necessaire pour une      !
-c     ! execution OpenMP                    !
-c     !-------------------------------------!
-               ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-               DO l = 1, nbniv
-                  ll_nb = ll_nb + 1
-                  DO j = jdfil,jffil
-                     DO i = 1, iim
-                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
-     &                       + champ_fft(i,j-jdfil+1,ll_nb))
-     &                       * sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT
-               
-            ELSE
-               
-               ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-               DO l = 1, nbniv_loc
-                  ll_nb = ll_nb + 1
-                  DO j = jdfil,jffil
-                     DO i = 1, iim
-                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
-     &                       - champ_fft(i,j-jdfil+1,ll_nb))
-     &                       * sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT
-               
-            ENDIF
-            
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l = 1, nbniv
-               DO j = jdfil,jffil
-                  champ( iip1,j,l ) = champ( 1,j,l )
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-            
-ccccccccccccccccccccccccccccccccccccccccccccc
-c Utilisation du filtre FFT
-ccccccccccccccccccccccccccccccccccccccccccccc
-        
-         ELSE
-       
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l=1,nbniv
-               DO j=jdfil,jffil
-                  DO  i = 1, iim
-                     champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
-                     champ_fft( i,j,l) = champ(i,j,l)
-                  ENDDO
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-
-            IF (jdfil<=jffil) THEN
-               IF( ifiltre == -2 )   THEN
-                  CALL Filtre_inv_fft(champ_fft,nlat,jdfil,jffil,nbniv) 
-               ELSE IF ( griscal )     THEN
-                  CALL Filtre_u_fft(champ_fft,nlat,jdfil,jffil,nbniv)
-               ELSE
-                  CALL Filtre_v_fft(champ_fft,nlat,jdfil,jffil,nbniv)
-               ENDIF
-            ENDIF
-
-
-            IF( ifiltre== 2 )  THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
-               DO l=1,nbniv
-                  DO j=jdfil,jffil
-                     DO  i = 1, iim
-                        champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l))
-     &                       *sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT	  
-            ELSE
-        
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
-               DO l=1,nbniv
-                  DO j=jdfil,jffil
-                     DO  i = 1, iim
-                        champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l))
-     &                       *sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT          
-            ENDIF
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-            DO l=1,nbniv
-               DO j=jdfil,jffil
-!            champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
-                  champ( iip1,j,l ) = champ( 1,j,l )
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT          	
-         ENDIF 
-c Fin de la zone de filtrage
-
-	
-      ENDDO
-
-!      DO j=1,nlat
-
-!          PRINT *,"check FFT ----> Delta(",j,")=",
-!     &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
-!     &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) 
-!      ENDDO
-      
-!          PRINT *,"check FFT ----> Delta(",j,")=",
-!     &            sum(champ-champ_fft)/sum(champ)
-
-c
- 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
-     &     filtrer, sur la grille des scalaires'/)
- 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
-     &     ltrer, sur la grille de V ou de Z'/)
-c$OMP MASTER      
-      CALL stop_timer
-c$OMP END MASTER
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/filtreg_p.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/filtreg_p.F90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/filtreg_p.F90	(revision 5105)
@@ -0,0 +1,427 @@
+
+
+SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, &
+        ifiltre, iaire, griscal ,iter)
+  USE parallel_lmdz, ONLY: OMP_CHUNK
+  USE mod_filtre_fft
+  USE timer_filtre
+
+  USE filtreg_mod
+
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur: P. Le Van        07/10/97
+  !   ------
+  !
+  !   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+  !                 pour l'operateur  Filtre    .
+  !   ------
+  !
+  !   Arguments:
+  !   ----------
+  !
+  !
+  !  ibeg..iend            lattitude a filtrer
+  !  nlat                  nombre de latitudes du champ
+  !  nbniv                 nombre de niveaux verticaux a filtrer
+  !  champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+  !                        en sortie : champ filtre
+  !  ifiltre               +1  Transformee directe
+  !                        -1  Transformee inverse
+  !                        +2  Filtre directe
+  !                        -2  Filtre inverse
+  !
+  !  iaire                 1   si champ intensif
+  !                        2   si champ extensif (pondere par les aires)
+  !
+  !  iter                  1   filtre simple
+  !
+  !=======================================================================
+  !
+  !
+  !                  Variable Intensive
+  !            ifiltre = 1     filtre directe
+  !            ifiltre =-1     filtre inverse
+  !
+  !                  Variable Extensive
+  !            ifiltre = 2     filtre directe
+  !            ifiltre =-2     filtre inverse
+  !
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "coefils.h"
+  !
+  INTEGER :: ibeg,iend,nlat,nbniv,ifiltre,iter
+  INTEGER :: i,j,l,k
+  INTEGER :: iim2,immjm
+  INTEGER :: jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+  REAL :: champ( iip1,nlat,nbniv)
+
+  LOGICAL :: griscal
+  INTEGER :: hemisph, iaire
+
+  REAL :: champ_fft(iip1,nlat,nbniv)
+  REAL :: champ_in(iip1,nlat,nbniv)
+
+  LOGICAL,SAVE     :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  REAL, DIMENSION(iip1,nlat,nbniv) :: champ_loc
+  INTEGER :: ll_nb, nbniv_loc
+  REAL, SAVE :: sdd12(iim,4)
+!$OMP THREADPRIVATE(sdd12)
+
+  INTEGER, PARAMETER :: type_sddu=1
+  INTEGER, PARAMETER :: type_sddv=2
+  INTEGER, PARAMETER :: type_unsddu=3
+  INTEGER, PARAMETER :: type_unsddv=4
+
+  INTEGER :: sdd1_type, sdd2_type
+
+  IF (first) THEN
+     sdd12(1:iim,type_sddu) = sddu(1:iim)
+     sdd12(1:iim,type_sddv) = sddv(1:iim)
+     sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+     sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+
+     CALL Init_timer
+     first=.FALSE.
+  ENDIF
+
+!$OMP MASTER
+  CALL start_timer
+!$OMP END MASTER
+
+  !-------------------------------------------------------c
+
+  IF(ifiltre==1.or.ifiltre==-1) &
+        CALL abort_gcm("fitreg_p","Pas de transformee simple&
+        &dans cette version",1)
+
+  IF( iter== 2 )  THEN
+     PRINT *,' Pas d iteration du filtre dans cette version !'&
+           &        , ' Utiliser old_filtreg et repasser !'
+     CALL abort_gcm("fitreg_p","stopped",1)
+  ENDIF
+
+  IF( ifiltre== -2 .AND..NOT.griscal )     THEN
+     PRINT *,' Cette routine ne calcule le filtre inverse que ' &
+           , ' sur la grille des scalaires !'
+     CALL abort_gcm("fitreg_p","stopped",1)
+  ENDIF
+
+  IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
+     PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
+           , ' corriger et repasser !'
+     CALL abort_gcm("fitreg_p","stopped",1)
+   ENDIF
+  !
+
+  iim2   = iim * iim
+  immjm  = iim * jjm
+  !
+  !
+  IF( griscal )   THEN
+     IF( nlat /= jjp1 )  THEN
+        CALL abort_gcm("fitreg_p","nlat. NE. jjp1",1)
+     ELSE
+  !
+        IF( iaire==1 )  THEN
+           sdd1_type = type_sddv
+           sdd2_type = type_unsddv
+        ELSE
+           sdd1_type = type_unsddv
+           sdd2_type = type_sddv
+        ENDIF
+  !
+        jdfil1 = 2
+        jffil1 = jfiltnu
+        jdfil2 = jfiltsu
+        jffil2 = jjm
+     ENDIF
+  ELSE
+     IF( nlat/=jjm )  THEN
+        CALL abort_gcm("fitreg_p","nlat. NE. jjm",1)
+     ELSE
+  !
+        IF( iaire==1 )  THEN
+           sdd1_type = type_sddu
+           sdd2_type = type_unsddu
+        ELSE
+           sdd1_type = type_unsddu
+           sdd2_type = type_sddu
+        ENDIF
+  !
+        jdfil1 = 1
+        jffil1 = jfiltnv
+        jdfil2 = jfiltsv
+        jffil2 = jjm
+     ENDIF
+  ENDIF
+  !
+  DO hemisph = 1, 2
+  !
+     IF ( hemisph==1 )  THEN
+  !ym
+        jdfil = max(jdfil1,ibeg)
+        jffil = min(jffil1,iend)
+     ELSE
+  !ym
+        jdfil = max(jdfil2,ibeg)
+        jffil = min(jffil2,iend)
+     ENDIF
+
+
+  !ccccccccccccccccccccccccccccccccccccccccccc
+  ! Utilisation du filtre classique
+  !ccccccccccccccccccccccccccccccccccccccccccc
+
+     IF (.NOT. use_filtre_fft) THEN
+
+  ! !---------------------------------!
+  ! ! Agregation des niveau verticaux !
+  ! ! uniquement necessaire pour une  !
+  ! ! execution OpenMP                !
+  ! !---------------------------------!
+        ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, nbniv
+           ll_nb = ll_nb+1
+           DO j = jdfil,jffil
+              DO i = 1, iim
+                 champ_loc(i,j,ll_nb) = &
+                       champ(i,j,l) * sdd12(i,sdd1_type)
+              ENDDO
+           ENDDO
+        ENDDO
+!$OMP END DO NOWAIT
+
+        nbniv_loc = ll_nb
+
+        IF( hemisph==1 )      THEN
+
+           IF( ifiltre==-2 )   THEN
+              DO j = jdfil,jffil
+#ifdef BLAS
+                 CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                       matrinvn(1,1,j), iim, &
+                       champ_loc(1,j,1), iip1*nlat, 0.0, &
+                       champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                 champ_fft(:iim,j-jdfil+1,:) &
+                       =matmul(matrinvn(:,:,j),champ_loc(:iim,j,:))
+#endif
+              ENDDO
+
+           ELSE IF ( griscal )     THEN
+              DO j = jdfil,jffil
+#ifdef BLAS
+                 CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                       matriceun(1,1,j), iim, &
+                       champ_loc(1,j,1), iip1*nlat, 0.0, &
+                       champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                 champ_fft(:iim,j-jdfil+1,:) &
+                       =matmul(matriceun(:,:,j),champ_loc(:iim,j,:))
+#endif
+              ENDDO
+
+           ELSE
+              DO j = jdfil,jffil
+#ifdef BLAS
+                 CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                       matricevn(1,1,j), iim, &
+                       champ_loc(1,j,1), iip1*nlat, 0.0, &
+                       champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                 champ_fft(:iim,j-jdfil+1,:) &
+                       =matmul(matricevn(:,:,j),champ_loc(:iim,j,:))
+#endif
+              ENDDO
+
+           ENDIF
+
+        ELSE
+
+           IF( ifiltre==-2 )   THEN
+              DO j = jdfil,jffil
+#ifdef BLAS
+                 CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                       matrinvs(1,1,j-jfiltsu+1), iim, &
+                       champ_loc(1,j,1), iip1*nlat, 0.0, &
+                       champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                 champ_fft(:iim,j-jdfil+1,:) &
+                       =matmul(matrinvs(:,:,j-jfiltsu+1), &
+                       champ_loc(:iim,j,:))
+#endif
+              ENDDO
+
+           ELSE IF ( griscal )     THEN
+
+              DO j = jdfil,jffil
+#ifdef BLAS
+                 CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                       matriceus(1,1,j-jfiltsu+1), iim, &
+                       champ_loc(1,j,1), iip1*nlat, 0.0, &
+                       champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                 champ_fft(:iim,j-jdfil+1,:) &
+                       =matmul(matriceus(:,:,j-jfiltsu+1), &
+                       champ_loc(:iim,j,:))
+#endif
+              ENDDO
+
+           ELSE
+
+              DO j = jdfil,jffil
+#ifdef BLAS
+                 CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                       matricevs(1,1,j-jfiltsv+1), iim, &
+                       champ_loc(1,j,1), iip1*nlat, 0.0, &
+                       champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                 champ_fft(:iim,j-jdfil+1,:) &
+                       =matmul(matricevs(:,:,j-jfiltsv+1), &
+                       champ_loc(:iim,j,:))
+#endif
+              ENDDO
+
+           ENDIF
+
+        ENDIF
+  ! c
+        IF( ifiltre==2 )  THEN
+
+  ! !-------------------------------------!
+  ! ! Dés-agregation des niveau verticaux !
+  ! ! uniquement necessaire pour une      !
+  ! ! execution OpenMP                    !
+  ! !-------------------------------------!
+           ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+           DO l = 1, nbniv
+              ll_nb = ll_nb + 1
+              DO j = jdfil,jffil
+                 DO i = 1, iim
+                    champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                          + champ_fft(i,j-jdfil+1,ll_nb)) &
+                          * sdd12(i,sdd2_type)
+                 ENDDO
+              ENDDO
+           ENDDO
+!$OMP END DO NOWAIT
+
+        ELSE
+
+           ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+           DO l = 1, nbniv_loc
+              ll_nb = ll_nb + 1
+              DO j = jdfil,jffil
+                 DO i = 1, iim
+                    champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                          - champ_fft(i,j-jdfil+1,ll_nb)) &
+                          * sdd12(i,sdd2_type)
+                 ENDDO
+              ENDDO
+           ENDDO
+!$OMP END DO NOWAIT
+
+        ENDIF
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, nbniv
+           DO j = jdfil,jffil
+              champ( iip1,j,l ) = champ( 1,j,l )
+           ENDDO
+        ENDDO
+!$OMP END DO NOWAIT
+
+  !cccccccccccccccccccccccccccccccccccccccccccc
+  ! Utilisation du filtre FFT
+  !cccccccccccccccccccccccccccccccccccccccccccc
+
+     ELSE
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,nbniv
+           DO j=jdfil,jffil
+              DO  i = 1, iim
+                 champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
+                 champ_fft( i,j,l) = champ(i,j,l)
+              ENDDO
+           ENDDO
+        ENDDO
+!$OMP END DO NOWAIT
+
+        IF (jdfil<=jffil) THEN
+           IF( ifiltre == -2 )   THEN
+              CALL Filtre_inv_fft(champ_fft,nlat,jdfil,jffil,nbniv)
+           ELSE IF ( griscal )     THEN
+              CALL Filtre_u_fft(champ_fft,nlat,jdfil,jffil,nbniv)
+           ELSE
+              CALL Filtre_v_fft(champ_fft,nlat,jdfil,jffil,nbniv)
+           ENDIF
+        ENDIF
+
+
+        IF( ifiltre== 2 )  THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+           DO l=1,nbniv
+              DO j=jdfil,jffil
+                 DO  i = 1, iim
+                    champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) &
+                          *sdd12(i,sdd2_type)
+                 ENDDO
+              ENDDO
+           ENDDO
+!$OMP END DO NOWAIT	
+        ELSE
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+           DO l=1,nbniv
+              DO j=jdfil,jffil
+                 DO  i = 1, iim
+                    champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) &
+                          *sdd12(i,sdd2_type)
+                 ENDDO
+              ENDDO
+           ENDDO
+!$OMP END DO NOWAIT
+        ENDIF
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,nbniv
+           DO j=jdfil,jffil
+         ! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
+              champ( iip1,j,l ) = champ( 1,j,l )
+           ENDDO
+        ENDDO
+!$OMP END DO NOWAIT          	
+     ENDIF
+  ! Fin de la zone de filtrage
+
+
+  ENDDO
+
+   ! DO j=1,nlat
+
+   !     PRINT *,"check FFT ----> Delta(",j,")=",
+  ! &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
+  ! &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:))
+  !  ENDDO
+
+  !      PRINT *,"check FFT ----> Delta(",j,")=",
+  ! &            sum(champ-champ_fft)/sum(champ)
+
+  !
+!$OMP MASTER
+  CALL stop_timer
+!$OMP END MASTER
+
+END SUBROUTINE filtreg_p
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/friction_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/friction_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,198 +1,0 @@
-
-! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
-
-c=======================================================================
-      SUBROUTINE friction_loc(ucov,vcov,pdt)
-      USE parallel_lmdz
-      USE control_mod
-      USE IOIPSL
-      USE comconst_mod, ONLY: pi
-      IMPLICIT NONE
-
-!=======================================================================
-
-!   Friction for the Newtonian case:
-!   --------------------------------
-!    2 possibilities (depending on flag 'friction_type'
-!     friction_type=0 : A friction that is only applied to the lowermost
-!                       atmospheric layer
-!     friction_type=1 : Friction applied on all atmospheric layer (but
-!       (default)       with stronger magnitude near the surface; see
-!                       iniacademic.F)
-!=======================================================================
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-      include "iniprint.h"
-      include "academic.h"
-
-! arguments:
-      REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
-      REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
-      REAL,INTENT(in) :: pdt ! time step
-
-! local variables:
-
-      REAL modv(iip1,jjb_u:jje_u),zco,zsi
-      REAL vpn,vps,upoln,upols,vpols,vpoln
-      REAL u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
-      INTEGER  i,j,l
-      REAL,PARAMETER :: cfric=1.e-5
-      LOGICAL,SAVE :: firstcall=.TRUE.
-      INTEGER,SAVE :: friction_type=1
-      CHARACTER(len=20) :: modname="friction_p"
-      CHARACTER(len=80) :: abort_message
-!$OMP THREADPRIVATE(firstcall,friction_type)
-      integer :: jjb,jje
-
-!$OMP SINGLE
-      IF (firstcall) THEN
-        ! set friction type
-        CALL getin("friction_type",friction_type)
-        if ((friction_type<0).or.(friction_type>1)) then
-          abort_message="wrong friction type"
-          write(lunout,*)'Friction: wrong friction type',friction_type
-          CALL abort_gcm(modname,abort_message,42)
-        endif
-        firstcall=.FALSE.
-      ENDIF
-!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
-
-      if (friction_type==0) then ! friction on first layer only
-!$OMP SINGLE
-c   calcul des composantes au carre du vent naturel
-      jjb=jj_begin
-      jje=jj_end+1
-      if (pole_sud) jje=jj_end
-      
-      do j=jjb,jje
-         do i=1,iip1
-            u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
-         enddo
-      enddo
-      
-      jjb=jj_begin-1
-      jje=jj_end+1
-      if (pole_nord) jjb=jj_begin
-      if (pole_sud) jje=jj_end-1
-      
-      do j=jjb,jje
-         do i=1,iip1
-            v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
-         enddo
-      enddo
-
-c   calcul du module de V en dehors des poles
-      jjb=jj_begin
-      jje=jj_end+1
-      if (pole_nord) jjb=jj_begin+1
-      if (pole_sud) jje=jj_end-1
-      
-      do j=jjb,jje
-         do i=2,iip1
-            modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
-         enddo
-         modv(1,j)=modv(iip1,j)
-      enddo
-
-c   les deux composantes du vent au pole sont obtenues comme
-c   premiers modes de fourier de v pres du pole
-      if (pole_nord) then
-      
-        upoln=0.
-        vpoln=0.
-     
-        do i=2,iip1
-           zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           vpn=vcov(i,1,1)/cv(i,1)
-           upoln=upoln+zco*vpn
-           vpoln=vpoln+zsi*vpn
-        enddo
-        vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
-        do i=1,iip1
-c          modv(i,1)=vpn
-           modv(i,1)=modv(i,2)
-        enddo
-
-      endif
-      
-      if (pole_sud) then
-      
-        upols=0.
-        vpols=0.
-        do i=2,iip1
-           zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           vps=vcov(i,jjm,1)/cv(i,jjm)
-           upols=upols+zco*vps
-           vpols=vpols+zsi*vps
-        enddo
-        vps=sqrt(upols*upols+vpols*vpols)/pi
-        do i=1,iip1
-c        modv(i,jjp1)=vps
-         modv(i,jjp1)=modv(i,jjm)
-        enddo
-      
-      endif
-      
-c   calcul du frottement au sol.
-
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_nord) jjb=jj_begin+1
-      if (pole_sud) jje=jj_end-1
-
-      do j=jjb,jje
-         do i=1,iim
-            ucov(i,j,1)=ucov(i,j,1)
-     s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
-         enddo
-         ucov(iip1,j,1)=ucov(1,j,1)
-      enddo
-      
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-      do j=jjb,jje
-         do i=1,iip1
-            vcov(i,j,1)=vcov(i,j,1)
-     s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
-         enddo
-         vcov(iip1,j,1)=vcov(1,j,1)
-      enddo
-!$OMP END SINGLE
-      endif ! of if (friction_type.eq.0)
-
-      if (friction_type==1) then
-       ! for ucov() 
-        jjb=jj_begin
-        jje=jj_end
-        if (pole_nord) jjb=jj_begin+1
-        if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-          ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)*
-     &                                  (1.-pdt*kfrict(l))
-        enddo
-!$OMP END DO NOWAIT
-        
-       ! for vcoc()
-        jjb=jj_begin
-        jje=jj_end
-        if (pole_sud) jje=jj_end-1
-        
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-          vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)*
-     &                                  (1.-pdt*kfrict(l))
-        enddo
-!$OMP END DO
-      endif ! of if (friction_type.eq.1)
-
-      RETURN
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/friction_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/friction_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/friction_loc.f90	(revision 5105)
@@ -0,0 +1,198 @@
+
+! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
+
+!=======================================================================
+SUBROUTINE friction_loc(ucov,vcov,pdt)
+  USE parallel_lmdz
+  USE control_mod
+  USE IOIPSL
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+
+  !=======================================================================
+
+  !   Friction for the Newtonian case:
+  !   --------------------------------
+  !    2 possibilities (depending on flag 'friction_type'
+  ! friction_type=0 : A friction that is only applied to the lowermost
+  !                   atmospheric layer
+  ! friction_type=1 : Friction applied on all atmospheric layer (but
+  !   (default)       with stronger magnitude near the surface; see
+  !                   iniacademic.F)
+  !=======================================================================
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+  include "academic.h"
+
+  ! arguments:
+  REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
+  REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
+  REAL,INTENT(in) :: pdt ! time step
+
+  ! local variables:
+
+  REAL :: modv(iip1,jjb_u:jje_u),zco,zsi
+  REAL :: vpn,vps,upoln,upols,vpols,vpoln
+  REAL :: u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
+  INTEGER :: i,j,l
+  REAL,PARAMETER :: cfric=1.e-5
+  LOGICAL,SAVE :: firstcall=.TRUE.
+  INTEGER,SAVE :: friction_type=1
+  CHARACTER(len=20) :: modname="friction_p"
+  CHARACTER(len=80) :: abort_message
+!$OMP THREADPRIVATE(firstcall,friction_type)
+  integer :: jjb,jje
+
+!$OMP SINGLE
+  IF (firstcall) THEN
+    ! ! set friction type
+    CALL getin("friction_type",friction_type)
+    if ((friction_type<0).or.(friction_type>1)) then
+      abort_message="wrong friction type"
+      write(lunout,*)'Friction: wrong friction type',friction_type
+      CALL abort_gcm(modname,abort_message,42)
+    endif
+    firstcall=.FALSE.
+  ENDIF
+!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
+
+  if (friction_type==0) then ! friction on first layer only
+!$OMP SINGLE
+  !   calcul des composantes au carre du vent naturel
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+
+  do j=jjb,jje
+     do i=1,iip1
+        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+     enddo
+  enddo
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iip1
+        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+     enddo
+  enddo
+
+  !   calcul du module de V en dehors des poles
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=2,iip1
+        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+     enddo
+     modv(1,j)=modv(iip1,j)
+  enddo
+
+  !   les deux composantes du vent au pole sont obtenues comme
+  !   premiers modes de fourier de v pres du pole
+  if (pole_nord) then
+
+    upoln=0.
+    vpoln=0.
+
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vpn=vcov(i,1,1)/cv(i,1)
+       upoln=upoln+zco*vpn
+       vpoln=vpoln+zsi*vpn
+    enddo
+    vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+    do i=1,iip1
+       ! modv(i,1)=vpn
+       modv(i,1)=modv(i,2)
+    enddo
+
+  endif
+
+  if (pole_sud) then
+
+    upols=0.
+    vpols=0.
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vps=vcov(i,jjm,1)/cv(i,jjm)
+       upols=upols+zco*vps
+       vpols=vpols+zsi*vps
+    enddo
+    vps=sqrt(upols*upols+vpols*vpols)/pi
+    do i=1,iip1
+     ! modv(i,jjp1)=vps
+     modv(i,jjp1)=modv(i,jjm)
+    enddo
+
+  endif
+
+  !   calcul du frottement au sol.
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iim
+        ucov(i,j,1)=ucov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+     enddo
+     ucov(iip1,j,1)=ucov(1,j,1)
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iip1
+        vcov(i,j,1)=vcov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+     enddo
+     vcov(iip1,j,1)=vcov(1,j,1)
+  enddo
+!$OMP END SINGLE
+  endif ! of if (friction_type.eq.0)
+
+  if (friction_type==1) then
+   ! ! for ucov()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_nord) jjb=jj_begin+1
+    if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
+!$OMP END DO NOWAIT
+
+   ! ! for vcoc()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
+!$OMP END DO
+  endif ! of if (friction_type.eq.1)
+
+
+END SUBROUTINE friction_loc
+
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/geopot_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/geopot_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,65 +1,0 @@
-      SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
-      USE parallel_lmdz
-      IMPLICIT NONE
-      
-      
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c    *******************************************************************
-c    ....   calcul du geopotentiel aux milieux des couches    .....
-c    *******************************************************************
-c
-c     ....   l'integration se fait de bas en haut  ....
-c
-c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
-c              phi               est un  argum. de sortie pour le s-pg .
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      include "dimensions.h"
-      include "paramet.h"
-
-c   Arguments:
-c   ----------
-      INTEGER ngrid
-      REAL teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u),
-     *     pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm)
-
-
-c   Local:
-c   ------
-      
-      INTEGER  l, ij,ijb,ije
-
-
-c-----------------------------------------------------------------------
-c     calcul de phi au niveau 1 pres du sol  .....
-      ijb=ij_begin
-      ije=ij_end+iip1
-      
-      IF (pole_sud)  ije=ij_end
-
-      DO  ij  = ijb, ije
-      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
-      ENDDO
-
-c     calcul de phi aux niveaux superieurs  .......
-
-      DO  l = 2,llm
-        DO  ij    = ijb,ije
-        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
-     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
-        ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/geopot_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/geopot_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/geopot_loc.f90	(revision 5105)
@@ -0,0 +1,65 @@
+SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
+  USE parallel_lmdz
+  IMPLICIT NONE
+
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !    *******************************************************************
+  !    ....   calcul du geopotentiel aux milieux des couches    .....
+  !    *******************************************************************
+  !
+  ! ....   l'integration se fait de bas en haut  ....
+  !
+  ! .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+  !          phi               est un  argum. de sortie pour le s-pg .
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  !   Arguments:
+  !   ----------
+  INTEGER :: ngrid
+  REAL :: teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u), &
+        pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm)
+
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l, ij,ijb,ije
+
+
+  !-----------------------------------------------------------------------
+  ! calcul de phi au niveau 1 pres du sol  .....
+  ijb=ij_begin
+  ije=ij_end+iip1
+
+  IF (pole_sud)  ije=ij_end
+
+  DO  ij  = ijb, ije
+  phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+  ENDDO
+
+  ! calcul de phi aux niveaux superieurs  .......
+
+  DO  l = 2,llm
+    DO  ij    = ijb,ije
+    phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) &
+          *   (  pk(ij,l-1) -  pk(ij,l)    )
+    ENDDO
+  ENDDO
+
+
+END SUBROUTINE geopot_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/gr_u_scal_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_u_scal_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,75 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal)
-c%W%    %G%
-c=======================================================================
-c
-c   Author:    Frederic Hourdin      original: 11/11/92
-c   -------
-c
-c   Subject:
-c   ------
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      USE parallel_lmdz
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER nx
-      REAL x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx)
-
-c   Local:
-c   ------
-
-      INTEGER l,ij
-      INTEGER :: ijb,ije
-
-c-----------------------------------------------------------------------
-      ijb=ij_begin
-      ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l=1,nx
-         DO ij=ijb+1,ije
-            x_scal(ij,l)=
-     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
-     s      /(aireu(ij)+aireu(ij-1))
-         ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-
-      ijb=ij_begin
-      ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l=1,nx
-         DO ij=ijb,ije-iip1+1,iip1
-	   x_scal(ij,l)=x_scal(ij+iip1-1,l)
-	 ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-      RETURN
-      
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_u_scal_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_u_scal_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_u_scal_loc.f90	(revision 5105)
@@ -0,0 +1,75 @@
+
+! $Header$
+
+SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: nx
+  REAL :: x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx)
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb+1,ije
+        x_scal(ij,l)= &
+              (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) &
+              /(aireu(ij)+aireu(ij-1))
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb,ije-iip1+1,iip1
+       x_scal(ij,l)=x_scal(ij+iip1-1,l)
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+
+END SUBROUTINE gr_u_scal_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/gr_v_scal_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_v_scal_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,85 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal)
-c%W%    %G%
-c=======================================================================
-c
-c   Author:    Frederic Hourdin      original: 11/11/92
-c   -------
-c
-c   Subject:
-c   ------
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      USE parallel_lmdz
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER nx
-      REAL x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx)
-
-c   Local:
-c   ------
-
-      INTEGER l,ij
-      INTEGER :: ijb,ije
-c-----------------------------------------------------------------------
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l=1,nx
-         DO ij=ijb,ije
-            x_scal(ij,l)=
-     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
-     s      /(airev(ij-iip1)+airev(ij))
-         ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-      
-      if (pole_nord) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l=1,nx
-           DO ij=1,iip1
-              x_scal(ij,l)=0.
-           ENDDO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-    
-      if (pole_sud) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l=1,nx
-           DO ij=ip1jm+1,ip1jmp1
-              x_scal(ij,l)=0.
-           ENDDO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_v_scal_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_v_scal_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_v_scal_loc.f90	(revision 5105)
@@ -0,0 +1,85 @@
+
+! $Header$
+
+SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: nx
+  REAL :: x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx)
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb,ije
+        x_scal(ij,l)= &
+              (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
+              /(airev(ij-iip1)+airev(ij))
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nx
+       DO ij=1,iip1
+          x_scal(ij,l)=0.
+       ENDDO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nx
+       DO ij=ip1jm+1,ip1jmp1
+          x_scal(ij,l)=0.
+       ENDDO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+
+END SUBROUTINE gr_v_scal_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,53 +1,0 @@
-      SUBROUTINE  grad_loc(klevel, pg,pgx,pgy )
-c
-c      P. Le Van
-c
-c    ******************************************************************
-c     .. calcul des composantes covariantes en x et y du gradient de g
-c
-c    ******************************************************************
-c             pg        est un   argument  d'entree pour le s-prog
-c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INTEGER klevel
-      REAL  pg( ijb_u:ije_u,klevel )
-      REAL pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel )
-      INTEGER  l,ij
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1,klevel
-c
-      ijb=ij_begin
-      ije=ij_end
-      DO ij = ijb, ije - 1
-        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
-      END DO
-c
-c    .... correction pour  pgx(ip1,j,l)  ....
-c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
-CDIR$ IVDEP
-      DO ij = ijb+iip1-1, ije, iip1
-        pgx( ij,l ) = pgx( ij -iim,l )
-      END DO
-c
-      ijb=ij_begin-iip1
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb,ije
-        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
-      END DO
-c
-      END DO
-c$OMP END DO NOWAIT
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.f90	(revision 5105)
@@ -0,0 +1,53 @@
+SUBROUTINE  grad_loc(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ijb_u:ije_u,klevel )
+  REAL :: pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  DO ij = ijb, ije - 1
+    pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+    pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+    pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+
+END SUBROUTINE grad_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.F	(revision 5104)
+++ 	(revision )
@@ -1,53 +1,0 @@
-      SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
-c
-c      P. Le Van
-c
-c    ******************************************************************
-c     .. calcul des composantes covariantes en x et y du gradient de g
-c
-c    ******************************************************************
-c             pg        est un   argument  d'entree pour le s-prog
-c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INTEGER klevel
-      REAL  pg( ip1jmp1,klevel )
-      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
-      INTEGER  l,ij
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1,klevel
-c
-      ijb=ij_begin
-      ije=ij_end
-      DO ij = ijb, ije - 1
-        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
-      END DO
-c
-c    .... correction pour  pgx(ip1,j,l)  ....
-c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
-CDIR$ IVDEP
-      DO ij = ijb+iip1-1, ije, iip1
-        pgx( ij,l ) = pgx( ij -iim,l )
-      END DO
-c
-      ijb=ij_begin-iip1
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb,ije
-        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
-      END DO
-c
-      END DO
-c$OMP END DO NOWAIT
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.f90	(revision 5105)
@@ -0,0 +1,53 @@
+SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ip1jmp1,klevel )
+  REAL :: pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  DO ij = ijb, ije - 1
+    pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+    pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+    pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+
+END SUBROUTINE grad_p
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,149 +1,0 @@
-      SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out )
-c
-c     P. Le Van
-c
-c   **********************************************************
-c                                ld
-c       calcul  de  (grad (div) )   du vect. v ....
-c
-c     xcov et ycov etant les composant.covariantes de v
-c   **********************************************************
-c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
-c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
-c
-c
-      USE parallel_lmdz
-      USE times
-      USE Write_field_p
-      USE mod_hallo
-      USE mod_filtreg_p
-      USE gradiv2_mod
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INCLUDE "comdissipn.h"
-c
-c     ........    variables en arguments      ........
-
-      INTEGER klevel
-      REAL  xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
-      REAL gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel)
-c
-c     ........       variables locales       .........
-c
-      REAL      :: tmp_div2(ijb_u:ije_u,llm)
-      REAL signe, nugrads
-      INTEGER l,ij,iter,ld
-      INTEGER :: ijb,ije,jjb,jje
-      Type(Request),SAVE  :: request_dissip
-!$OMP THREADPRIVATE(request_dissip)      
-c    ........................................................
-c
-c
-c      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
-c      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO   l = 1, klevel
-        gdx(ijb:ije,l)=xcov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT      
-      
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO   l = 1, klevel
-        gdy(ijb:ije,l)=ycov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-c$OMP BARRIER
-       CALL Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-c
-c
-      signe   = (-1.)**ld
-      nugrads = signe * cdivu
-c
-
-
-      CALL    divergf_loc( klevel, gdx,   gdy , div )
-c      CALL write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
-
-      IF( ld>1 )   THEN
-c$OMP BARRIER
-       CALL Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-	CALL laplacien_loc( klevel, div,  div     )
-
-c    ......  Iteration de l'operateur laplacien_gam   .......
-c         CALL write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
-
-        DO iter = 1, ld -2
-c$OMP BARRIER
-       CALL Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-
-c$OMP BARRIER
-
-         CALL laplacien_gam_loc(klevel,cuvscvgam1,cvuscugam1,
-     &                          unsair_gam1,unsapolnga1, unsapolsga1,
-     &                          div, div       )
-        ENDDO
-c        CALL write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
-      ENDIF
-
-       jjb=jj_begin
-       jje=jj_end
-       
-       CALL filtreg_p( div   ,jjb_u,jje_u,jjb,jje, jjp1, 
-     &                 klevel, 2, 1, .TRUE., 1 )
-c       CALL exchange_Hallo(div,ip1jmp1,llm,0,1)
-c$OMP BARRIER
-       CALL Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-
-c$OMP BARRIER
-
-
-       CALL  grad_loc( klevel,  div,   gdx,  gdy )
-
-c
-      ijb=ij_begin
-      ije=ij_end
-         
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       DO   l = 1, klevel
-         
-         if (pole_sud) ije=ij_end
-         DO  ij = ijb, ije
-          gdx_out( ij,l ) = gdx( ij,l ) * nugrads
-         ENDDO
-         
-         if (pole_sud) ije=ij_end-iip1
-         DO  ij = ijb, ije
-          gdy_out( ij,l ) = gdy( ij,l ) * nugrads
-         ENDDO
-       
-       ENDDO
-c$OMP END DO NOWAIT
-c
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.f90	(revision 5105)
@@ -0,0 +1,149 @@
+SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+  !
+  ! P. Le Van
+  !
+  !   **********************************************************
+  !                            ld
+  !   calcul  de  (grad (div) )   du vect. v ....
+  !
+  ! xcov et ycov etant les composant.covariantes de v
+  !   **********************************************************
+  ! xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+  !  gdx   et  gdy       sont des arguments de sortie pour le s-prog
+  !
+  !
+  USE parallel_lmdz
+  USE times
+  USE Write_field_p
+  USE mod_hallo
+  USE mod_filtreg_p
+  USE gradiv2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "comdissipn.h"
+  !
+  ! ........    variables en arguments      ........
+
+  INTEGER :: klevel
+  REAL :: xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+  REAL :: gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel)
+  !
+  ! ........       variables locales       .........
+  !
+  REAL      :: tmp_div2(ijb_u:ije_u,llm)
+  REAL :: signe, nugrads
+  INTEGER :: l,ij,iter,ld
+  INTEGER :: ijb,ije,jjb,jje
+  Type(Request),SAVE  :: request_dissip
+!$OMP THREADPRIVATE(request_dissip)
+  !    ........................................................
+  !
+  !
+  !  CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+  !  CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1, klevel
+    gdx(ijb:ije,l)=xcov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1, klevel
+    gdy(ijb:ije,l)=ycov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP BARRIER
+   CALL Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+  !
+  !
+  signe   = (-1.)**ld
+  nugrads = signe * cdivu
+  !
+
+
+  CALL    divergf_loc( klevel, gdx,   gdy , div )
+   ! CALL write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
+
+  IF( ld>1 )   THEN
+!$OMP BARRIER
+   CALL Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+    CALL laplacien_loc( klevel, div,  div     )
+
+  !    ......  Iteration de l'operateur laplacien_gam   .......
+      ! CALL write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
+
+    DO iter = 1, ld -2
+!$OMP BARRIER
+   CALL Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+
+!$OMP BARRIER
+
+     CALL laplacien_gam_loc(klevel,cuvscvgam1,cvuscugam1, &
+           unsair_gam1,unsapolnga1, unsapolsga1, &
+           div, div       )
+    ENDDO
+     ! CALL write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
+  ENDIF
+
+   jjb=jj_begin
+   jje=jj_end
+
+   CALL filtreg_p( div   ,jjb_u,jje_u,jjb,jje, jjp1, &
+         klevel, 2, 1, .TRUE., 1 )
+    ! CALL exchange_Hallo(div,ip1jmp1,llm,0,1)
+!$OMP BARRIER
+   CALL Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+
+!$OMP BARRIER
+
+
+   CALL  grad_loc( klevel,  div,   gdx,  gdy )
+
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO   l = 1, klevel
+
+     if (pole_sud) ije=ij_end
+     DO  ij = ijb, ije
+      gdx_out( ij,l ) = gdx( ij,l ) * nugrads
+     ENDDO
+
+     if (pole_sud) ije=ij_end-iip1
+     DO  ij = ijb, ije
+      gdy_out( ij,l ) = gdy( ij,l ) * nugrads
+     ENDDO
+
+   ENDDO
+!$OMP END DO NOWAIT
+  !
+
+END SUBROUTINE gradiv2_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupe_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupe_loc.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupe_loc.f90	(revision 5105)
@@ -123,5 +123,5 @@
   CALL vitvert_loc(zconvmm, wm)
 
-  return
+
 END SUBROUTINE  groupe_loc
 
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/groupeun_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupeun_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,201 +1,0 @@
-      SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
-      USE parallel_lmdz
-      USE Write_Field_p
-      USE comconst_mod, ONLY: ngroup
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-      INTEGER jjmax,llmax,sb,se,jjb,jje
-      REAL q(iip1,sb:se,llmax)
-
-!     INTEGER ngroup
-!     PARAMETER (ngroup=3)
-
-      REAL airecn,qn
-      REAL airecs,qs
-
-      INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
-
-c--------------------------------------------------------------------c 
-c Strategie d'optimisation                                           c
-c stocker les valeurs systematiquement recalculees                   c
-c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
-c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
-c de grille au cours de la simulation tout devrait bien se passer.   c
-c Autre optimisation : determination des bornes entre lesquelles "j" c
-c varie, au lieu de faire un test a chaque fois...
-c--------------------------------------------------------------------c 
-
-      INTEGER j_start, j_finish
-
-      REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
-      REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
-!$OMP THREADPRIVATE(airen_tab, aires_tab)
-
-      LOGICAL, SAVE :: first = .TRUE.
-!$OMP THREADPRIVATE(first)
-!     INTEGER,SAVE :: i_index(iim,ngroup)
-      INTEGER      :: offset
-!     REAL         :: qsum(iim/ngroup)
-
-      IF (first) THEN
-         CALL init_groupeun_loc(airen_tab, aires_tab)
-         first = .FALSE.
-      ENDIF
-
-c Champs 3D
-      jd=jjp1-jjmax
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         j1=1+jd
-         j2=2
-         DO ig=1,ngroup
-
-c     Concerne le pole nord
-            j_start  = MAX(jjb, j1-jd)
-            j_finish = MIN(jje, j2-jd)
-            DO ig2=1,ngroup-ig+1
-              offset=2**(ig2-1)
-              DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-                 DO i0=1,iim,2**ig2
-                   q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) 
-                 ENDDO
-              ENDDO
-            ENDDO
-            
-            DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
-               ENDDO
-            ENDDO
-
-            DO j=j_start, j_finish
-!CDIR ON_ADB(airen_tab)
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
-               ENDDO
-               q(iip1,j,l)=q(1,j,l)
-            ENDDO
-       
-!c     Concerne le pole sud
-            j_start  = MAX(1+jjp1-jje-jd, j1-jd)
-            j_finish = MIN(1+jjp1-jjb-jd, j2-jd)
-            DO ig2=1,ngroup-ig+1
-              offset=2**(ig2-1)
-              DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-                 DO i0=1,iim,2**ig2
-                   q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l)
-     &                                 +q(i0+offset,jjp1-j+1-jd,l) 
-                 ENDDO
-              ENDDO
-            ENDDO
-
-
-            DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),
-     &                                jjp1-j+1-jd,l)
-               ENDDO
-            ENDDO
-
-            DO j=j_start, j_finish
-!CDIR ON_ADB(aires_tab)
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)*  
-     &                              aires_tab(i,jjp1-j+1,jd)
-               ENDDO
-               q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
-            ENDDO
-
-        
-            j1=j2+1
-            j2=j2+2**ig
-         ENDDO
-      ENDDO
-!$OMP END DO NOWAIT
-
-      RETURN
-      END
-
-
-
-      SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
-
-      USE parallel_lmdz
-      USE comconst_mod, ONLY: ngroup
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-!     INTEGER ngroup
-!     PARAMETER (ngroup=3)
-
-      REAL airen,airecn
-      REAL aires,airecs
-
-      INTEGER i,j,l,ig,j1,j2,i0,jd
-
-      INTEGER j_start, j_finish
-
-      REAL :: airen_tab(iip1,jjp1,0:1)
-      REAL :: aires_tab(iip1,jjp1,0:1)
-
-      DO jd=0, 1
-         j1=1+jd
-         j2=2
-         DO ig=1,ngroup
-            
-!     c     Concerne le pole nord
-            j_start = j1-jd
-            j_finish = j2-jd
-            DO j=j_start, j_finish
-               DO i0=1,iim,2**(ngroup-ig+1)
-                  airen=0.
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     airen = airen+aire(i,j)
-                  ENDDO
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     airen_tab(i,j,jd) = 
-     &                    aire(i,j) / airen
-                  ENDDO
-               ENDDO
-            ENDDO
-            
-!     c     Concerne le pole sud
-            j_start = j1-jd
-            j_finish = j2-jd
-            DO j=j_start, j_finish
-               DO i0=1,iim,2**(ngroup-ig+1)
-                  aires=0.
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     aires=aires+aire(i,jjp1-j+1)
-                  ENDDO
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     aires_tab(i,jjp1-j+1,jd) = 
-     &                    aire(i,jjp1-j+1) / aires
-                  ENDDO
-               ENDDO
-            ENDDO
-            
-            j1=j2+1
-            j2=j2+2**ig
-         ENDDO
-      ENDDO
-      
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupeun_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupeun_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupeun_loc.f90	(revision 5105)
@@ -0,0 +1,201 @@
+SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
+  USE parallel_lmdz
+  USE Write_Field_p
+  USE comconst_mod, ONLY: ngroup
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  INTEGER :: jjmax,llmax,sb,se,jjb,jje
+  REAL :: q(iip1,sb:se,llmax)
+
+  ! INTEGER ngroup
+  ! PARAMETER (ngroup=3)
+
+  REAL :: airecn,qn
+  REAL :: airecs,qs
+
+  INTEGER :: i,j,l,ig,ig2,j1,j2,i0,jd
+
+  !--------------------------------------------------------------------c
+  ! Strategie d'optimisation                                           c
+  ! stocker les valeurs systematiquement recalculees                   c
+  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
+  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
+  ! de grille au cours de la simulation tout devrait bien se passer.   c
+  ! Autre optimisation : determination des bornes entre lesquelles "j" c
+  ! varie, au lieu de faire un test a chaque fois...
+  !--------------------------------------------------------------------c
+
+  INTEGER :: j_start, j_finish
+
+  REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
+  REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
+!$OMP THREADPRIVATE(airen_tab, aires_tab)
+
+  LOGICAL, SAVE :: first = .TRUE.
+!$OMP THREADPRIVATE(first)
+  ! INTEGER,SAVE :: i_index(iim,ngroup)
+  INTEGER      :: offset
+  ! REAL         :: qsum(iim/ngroup)
+
+  IF (first) THEN
+     CALL init_groupeun_loc(airen_tab, aires_tab)
+     first = .FALSE.
+  ENDIF
+
+  ! Champs 3D
+  jd=jjp1-jjmax
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     j1=1+jd
+     j2=2
+     DO ig=1,ngroup
+
+  ! Concerne le pole nord
+        j_start  = MAX(jjb, j1-jd)
+        j_finish = MIN(jje, j2-jd)
+        DO ig2=1,ngroup-ig+1
+          offset=2**(ig2-1)
+          DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+             DO i0=1,iim,2**ig2
+               q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
+             ENDDO
+          ENDDO
+        ENDDO
+
+        DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
+           ENDDO
+        ENDDO
+
+        DO j=j_start, j_finish
+  !CDIR ON_ADB(airen_tab)
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
+           ENDDO
+           q(iip1,j,l)=q(1,j,l)
+        ENDDO
+
+  !c     Concerne le pole sud
+        j_start  = MAX(1+jjp1-jje-jd, j1-jd)
+        j_finish = MIN(1+jjp1-jjb-jd, j2-jd)
+        DO ig2=1,ngroup-ig+1
+          offset=2**(ig2-1)
+          DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+             DO i0=1,iim,2**ig2
+               q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) &
+                     +q(i0+offset,jjp1-j+1-jd,l)
+             ENDDO
+          ENDDO
+        ENDDO
+
+
+        DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), &
+                   jjp1-j+1-jd,l)
+           ENDDO
+        ENDDO
+
+        DO j=j_start, j_finish
+  !CDIR ON_ADB(aires_tab)
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* &
+                   aires_tab(i,jjp1-j+1,jd)
+           ENDDO
+           q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
+        ENDDO
+
+
+        j1=j2+1
+        j2=j2+2**ig
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+
+END SUBROUTINE groupeun_loc
+
+
+
+SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
+
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: ngroup
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  ! INTEGER ngroup
+  ! PARAMETER (ngroup=3)
+
+  REAL :: airen,airecn
+  REAL :: aires,airecs
+
+  INTEGER :: i,j,l,ig,j1,j2,i0,jd
+
+  INTEGER :: j_start, j_finish
+
+  REAL :: airen_tab(iip1,jjp1,0:1)
+  REAL :: aires_tab(iip1,jjp1,0:1)
+
+  DO jd=0, 1
+     j1=1+jd
+     j2=2
+     DO ig=1,ngroup
+
+  ! c     Concerne le pole nord
+        j_start = j1-jd
+        j_finish = j2-jd
+        DO j=j_start, j_finish
+           DO i0=1,iim,2**(ngroup-ig+1)
+              airen=0.
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 airen = airen+aire(i,j)
+              ENDDO
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 airen_tab(i,j,jd) = &
+                       aire(i,j) / airen
+              ENDDO
+           ENDDO
+        ENDDO
+
+  ! c     Concerne le pole sud
+        j_start = j1-jd
+        j_finish = j2-jd
+        DO j=j_start, j_finish
+           DO i0=1,iim,2**(ngroup-ig+1)
+              aires=0.
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 aires=aires+aire(i,jjp1-j+1)
+              ENDDO
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 aires_tab(i,jjp1-j+1,jd) = &
+                       aire(i,jjp1-j+1) / aires
+              ENDDO
+           ENDDO
+        ENDDO
+
+        j1=j2+1
+        j2=j2+2**ig
+     ENDDO
+  ENDDO
+
+
+END SUBROUTINE init_groupeun_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/guide_loc_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/guide_loc_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/guide_loc_mod.F90	(revision 5105)
@@ -2381,5 +2381,5 @@
          enddo
      enddo
-     return
+
   END SUBROUTINE  correctbid
 
@@ -2415,5 +2415,5 @@
     CALL barrier
 
-    return
+
     END SUBROUTINE  dump2du
 
@@ -2430,5 +2430,5 @@
      CALL dump2du(unat2(:,jjbu:jjeu,nlevnc),'  unat2 couche nlevnc')
      CALL dump2du(ugui1(ijb_u:ije_u,1)*sqrt(unscu2(ijb_u:ije_u)),'  ugui1 couche 1')
-     return
+
 END SUBROUTINE  dumpall
 
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/initdynav_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initdynav_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,280 +1,0 @@
-
-! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-
-      SUBROUTINE initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
-
-! This routine needs IOIPSL
-       USE IOIPSL
-       USE parallel_lmdz
-       use Write_field
-       use misc_mod
-!       USE infotrac
-       use com_io_dyn_mod, ONLY: histaveid,histvaveid,histuaveid,       &
-     &        dynhistave_file,dynhistvave_file,dynhistuave_file
-       USE comconst_mod, ONLY: pi
-       USE comvert_mod, ONLY: presnivs
-       USE temps_mod, ONLY: itau_dyn
-       
-       implicit none
-
-C
-C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-C   au format IOIPSL. Initialisation du fichier histoire moyenne.
-C
-C   Appels succesifs des routines: histbeg
-C                                  histhori
-C                                  histver
-C                                  histdef
-C                                  histend
-C
-C   Entree:
-C
-C      day0,anne0: date de reference
-C      tstep : frequence d'ecriture
-C      t_ops: frequence de l'operation pour IOIPSL
-C      t_wrt: frequence d'ecriture sur le fichier
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C   Arguments
-C
-      integer(kind=4) day0, anne0
-      real tstep, t_ops, t_wrt
-
-! This routine needs IOIPSL
-C   Variables locales
-C
-      integer tau0
-      real zjulian
-      integer iq
-      real rlong(iip1,jjp1), rlat(iip1,jjp1)
-      integer uhoriid, vhoriid, thoriid
-      integer zvertiid,zvertiidv,zvertiidu
-      integer ii,jj
-      integer zan, dayref
-      integer :: jjb,jje,jjn
-
-! definition du domaine d'ecriture pour le rebuild
-
-      INTEGER,DIMENSION(2) :: ddid
-      INTEGER,DIMENSION(2) :: dsg
-      INTEGER,DIMENSION(2) :: dsl
-      INTEGER,DIMENSION(2) :: dpf
-      INTEGER,DIMENSION(2) :: dpl
-      INTEGER,DIMENSION(2) :: dhs
-      INTEGER,DIMENSION(2) :: dhe
-
-      INTEGER :: dynhistave_domain_id
-      INTEGER :: dynhistvave_domain_id
-      INTEGER :: dynhistuave_domain_id
-
-      if (adjust) return
-
-C
-C  Initialisations
-C
-      pi = 4. * atan (1.)
-C
-C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-C
-
-      zan = anne0
-      dayref = day0
-      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-      tau0 = itau_dyn
-
-      do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonv(ii) * 180. / pi
-          rlat(ii,jj)  = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-
-! Creation de 3 fichiers pour les differentes grilles horizontales
-! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
-! Grille Scalaire
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-
-      ddid=(/ 1,2 /)
-      dsg=(/ iip1,jjp1 /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-
-      CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
-     .                 'box',dynhistave_domain_id)
-
-      CALL histbeg(dynhistave_file,iip1, rlong(:,1), jjn,
-     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
-     .             zjulian, tstep, thoriid,
-     .             histaveid,dynhistave_domain_id)
-
-
-C  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
-C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-C  un meme fichier)
-! Grille V
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-      IF (pole_sud) jjn=jjn-1
-      IF (pole_sud) jje=jje-1
-
-      do jj = jjb, jje
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonv(ii) * 180. / pi
-          rlat(ii,jj) = rlatv(jj) * 180. / pi
-        enddo
-      enddo
-
-      ddid=(/ 1,2 /)
-      dsg=(/ iip1,jjm /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-
-      CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
-     .                 'box',dynhistvave_domain_id)
-
-      CALL histbeg(dynhistvave_file,iip1, rlong(:,1), jjn,
-     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
-     .             zjulian, tstep, vhoriid,
-     .             histvaveid,dynhistvave_domain_id)
-
-! Grille U
-
-      do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonu(ii) * 180. / pi
-          rlat(ii,jj) = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-
-      ddid=(/ 1,2 /)
-      dsg=(/ iip1,jjp1 /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-
-      CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
-     .                 'box',dynhistuave_domain_id)
-
-      CALL histbeg(dynhistuave_file,iip1, rlong(:,1), jjn,
-     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
-     .             zjulian, tstep, uhoriid,
-     .             histuaveid,dynhistuave_domain_id)
-
-
-C
-C  Appel a histvert pour la grille verticale
-C
-      CALL histvert(histaveid,'presnivs','Niveaux Pression
-     &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
-      CALL histvert(histuaveid,'presnivs','Niveaux Pression
-     &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
-      CALL histvert(histvaveid,'presnivs','Niveaux Pression
-     &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
-
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-C
-C  Vents U
-C
-      jjn=jj_nb
-      CALL histdef(histuaveid, 'u', 'vent u moyen ',
-     .             'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu,
-     .             32, 'ave(X)', t_ops, t_wrt)
-
-C
-C  Vents V
-C
-      if (pole_sud) jjn=jj_nb-1
-      CALL histdef(histvaveid, 'v', 'vent v moyen',
-     .             'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv,
-     .             32, 'ave(X)', t_ops, t_wrt)
-
-C
-C  Temperature
-C
-      jjn=jj_nb
-      CALL histdef(histaveid, 'temp', 'temperature moyenne', 'K',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Temperature potentielle
-C
-      CALL histdef(histaveid, 'theta', 'temperature potentielle', 'K',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-
-
-C
-C  Geopotentiel
-C
-      CALL histdef(histaveid, 'phi', 'geopotentiel moyen', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Traceurs
-C
-!        DO iq=1,nqtot
-!          CALL histdef(histaveid, tracers(iq)%name,
-!     .                            tracers(iq)%longName, '-',
-!     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-!     .             32, 'ave(X)', t_ops, t_wrt)
-!        enddo
-C
-C  Masse
-C
-      CALL histdef(histaveid, 'masse', 'masse moyenne', 'kg',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Pression au sol
-C
-      CALL histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa',
-     .             iip1, jjn, thoriid, 1, 1, 1, -99,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Geopotentiel au sol
-C
-!      CALL histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
-!     .             iip1, jjn, thoriid, 1, 1, 1, -99,
-!     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Fin
-C
-      CALL histend(histaveid)
-      CALL histend(histuaveid)
-      CALL histend(histvaveid)
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initdynav_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initdynav_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initdynav_loc.f90	(revision 5105)
@@ -0,0 +1,280 @@
+
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+
+SUBROUTINE initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
+
+  ! This routine needs IOIPSL
+   USE IOIPSL
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+    ! USE infotrac
+   use com_io_dyn_mod, ONLY: histaveid,histvaveid,histuaveid,       &
+         dynhistave_file,dynhistvave_file,dynhistuave_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+
+   implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep : frequence d'ecriture
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  integer(kind=4) day0, anne0
+  real :: tstep, t_ops, t_wrt
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynhistave_domain_id
+  INTEGER :: dynhistvave_domain_id
+  INTEGER :: dynhistuave_domain_id
+
+  if (adjust) return
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistave_domain_id)
+
+  CALL histbeg(dynhistave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, thoriid, &
+        histaveid,dynhistave_domain_id)
+
+
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistvave_domain_id)
+
+  CALL histbeg(dynhistvave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, vhoriid, &
+        histvaveid,dynhistvave_domain_id)
+
+  ! Grille U
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistuave_domain_id)
+
+  CALL histbeg(dynhistuave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, uhoriid, &
+        histuaveid,dynhistuave_domain_id)
+
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  CALL histvert(histaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
+  CALL histvert(histuaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
+  CALL histvert(histvaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
+
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  CALL histdef(histuaveid, 'u', 'vent u moyen ', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  CALL histdef(histvaveid, 'v', 'vent v moyen', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  CALL histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  CALL histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+
+  !
+  !  Geopotentiel
+  !
+  CALL histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      CALL histdef(histaveid, tracers(iq)%name,
+  ! .                            tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  CALL histdef(histaveid, 'masse', 'masse moyenne', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  CALL histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  CALL histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  CALL histend(histaveid)
+  CALL histend(histuaveid)
+  CALL histend(histvaveid)
+end subroutine initdynav_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/initfluxsto_p.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initfluxsto_p.F	(revision 5104)
+++ 	(revision )
@@ -1,287 +1,0 @@
-
-! $Id$
-
-      SUBROUTINE initfluxsto_p
-     .  (infile,tstep,t_ops,t_wrt,
-     .                    fileid,filevid,filedid)
-
-! This routine needs IOIPSL
-       USE IOIPSL
-       USE parallel_lmdz
-       use Write_field
-       use misc_mod
-       USE comconst_mod, ONLY: pi
-       USE comvert_mod, ONLY: nivsigs
-       USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-       
-      implicit none
-
-C
-C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-C   au format IOIPSL
-C
-C   Appels succesifs des routines: histbeg
-C                                  histhori
-C                                  histver
-C                                  histdef
-C                                  histend
-C
-C   Entree:
-C
-C      infile: nom du fichier histoire a creer
-C      day0,anne0: date de reference
-C      tstep: duree du pas de temps en seconde
-C      t_ops: frequence de l'operation pour IOIPSL
-C      t_wrt: frequence d'ecriture sur le fichier
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C      filevid:ID du fichier netcdf pour la grille v
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C   Arguments
-C
-      character*(*) infile
-      real tstep, t_ops, t_wrt
-      integer fileid, filevid,filedid
-
-! This routine needs IOIPSL
-C   Variables locales
-C
-      real nivd(1)
-      integer tau0
-      real zjulian
-      character*3 str
-      character*10 ctrac
-      integer iq
-      real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
-      integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
-      integer ii,jj
-      integer zan, idayref
-      logical ok_sync
-      integer :: jjb,jje,jjn
-
-! definition du domaine d'ecriture pour le rebuild
-
-      INTEGER,DIMENSION(2) :: ddid
-      INTEGER,DIMENSION(2) :: dsg
-      INTEGER,DIMENSION(2) :: dsl
-      INTEGER,DIMENSION(2) :: dpf
-      INTEGER,DIMENSION(2) :: dpl
-      INTEGER,DIMENSION(2) :: dhs
-      INTEGER,DIMENSION(2) :: dhe
-
-      INTEGER :: dynu_domain_id
-      INTEGER :: dynv_domain_id
-
-C
-C  Initialisations
-C
-      pi = 4. * atan (1.)
-      str='q  '
-      ctrac = 'traceur   '
-      ok_sync = .TRUE.
-C
-C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-C
-
-      zan = annee_ref
-      idayref = day_ref
-      CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
-      tau0 = itau_dyn
-
-        do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonu(ii) * 180. / pi
-          rlat(ii,jj) = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-
-      ddid=(/ 1,2 /)
-      dsg=(/ iip1,jjp1 /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-      CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
-     .                 'box',dynu_domain_id)
-
-      CALL histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
-     .             1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid,
-     .             fileid,dynu_domain_id)
-C
-C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
-C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-C  un meme fichier)
-
-
-      do jj = 1, jjm
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonv(ii) * 180. / pi
-          rlat(ii,jj) = rlatv(jj) * 180. / pi
-        enddo
-      enddo
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-      if (pole_sud) jje=jj_end-1
-      if (pole_sud) jjn=jj_nb-1
-
-      ddid=(/ 1,2 /)
-      dsg=(/ iip1,jjm /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-      CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
-     .                 'box',dynv_domain_id)
-
-      CALL histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
-     .             1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid,
-     .             filevid,dynv_domain_id)
-
-      rl(1,1) = 1.
-
-      if (mpi_rank==0) then
-
-        CALL histbeg('defstoke.nc', 1, rl, 1, rl,
-     .               1, 1, 1, 1,
-     .               tau0, zjulian, tstep, dhoriid, filedid)
-
-      endif
-C
-C  Appel a histhori pour rajouter les autres grilles horizontales
-C
-      do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonv(ii) * 180. / pi
-          rlat(ii,jj) = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-
-      CALL histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje),
-     .             'scalar','Grille points scalaires', thoriid)
-
-C
-C  Appel a histvert pour la grille verticale
-C
-      CALL histvert(fileid, 'sig_s', 'Niveaux sigma',
-     . 'sigma_level',
-     .              llm, nivsigs, zvertiid)
-C Pour le fichier V
-      CALL histvert(filevid, 'sig_s', 'Niveaux sigma',
-     .  'sigma_level',
-     .              llm, nivsigs, zvertiid)
-c pour le fichier def
-      if (mpi_rank==0) then
-         nivd(1) = 1
-         CALL histvert(filedid, 'sig_s', 'Niveaux sigma',
-     .        'sigma_level',
-     .        1, nivd, dvertiid)
-      endif
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-
-        CALL histdef(fileid, "phis", "Surface geop. height", "-",
-     .                iip1,jjn,thoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(fileid, "aire", "Grid area", "-",
-     .                iip1,jjn,thoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-        if (mpi_rank==0) then
-
-        CALL histdef(filedid, "dtvr", "tps dyn", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(filedid, "istdyn", "tps stock", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(filedid, "istphy", "tps stock phy", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-        endif
-C
-C Masse
-C
-      CALL histdef(fileid, 'masse', 'Masse', 'kg',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Pbaru
-C
-      CALL histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
-     .             iip1, jjn, uhoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Pbarv
-C
-      if (pole_sud) jjn=jj_nb-1
-
-      CALL histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
-     .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  w
-C
-      if (pole_sud) jjn=jj_nb
-      CALL histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Temperature potentielle
-C
-      CALL histdef(fileid, 'teta', 'temperature potentielle', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-
-C
-C Geopotentiel
-C
-      CALL histdef(fileid, 'phi', 'geopotentiel instantane', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Fin
-C
-      CALL histend(fileid)
-      CALL histend(filevid)
-      if (mpi_rank==0) CALL histend(filedid)
-      if (ok_sync) then
-        CALL histsync(fileid)
-        CALL histsync(filevid)
-        if (mpi_rank==0) CALL histsync(filedid)
-      endif
-
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initfluxsto_p.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initfluxsto_p.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initfluxsto_p.f90	(revision 5105)
@@ -0,0 +1,287 @@
+
+! $Id$
+
+SUBROUTINE initfluxsto_p &
+        (infile,tstep,t_ops,t_wrt, &
+        fileid,filevid,filedid)
+
+  ! This routine needs IOIPSL
+   USE IOIPSL
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: nivsigs
+   USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !  filevid:ID du fichier netcdf pour la grille v
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  character(len=*) :: infile
+  real :: tstep, t_ops, t_wrt
+  integer :: fileid, filevid,filedid
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  real :: nivd(1)
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+  integer :: ii,jj
+  integer :: zan, idayref
+  logical :: ok_sync
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynu_domain_id
+  INTEGER :: dynv_domain_id
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  str='q  '
+  ctrac = 'traceur   '
+  ok_sync = .TRUE.
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+    do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+  CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynu_domain_id)
+
+  CALL histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+        1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, &
+        fileid,dynu_domain_id)
+  !
+  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+
+
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+  CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynv_domain_id)
+
+  CALL histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+        1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, &
+        filevid,dynv_domain_id)
+
+  rl(1,1) = 1.
+
+  if (mpi_rank==0) then
+
+    CALL histbeg('defstoke.nc', 1, rl, 1, rl, &
+          1, 1, 1, 1, &
+          tau0, zjulian, tstep, dhoriid, filedid)
+
+  endif
+  !
+  !  Appel a histhori pour rajouter les autres grilles horizontales
+  !
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  CALL histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), &
+        'scalar','Grille points scalaires', thoriid)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  CALL histvert(fileid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! Pour le fichier V
+  CALL histvert(filevid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! pour le fichier def
+  if (mpi_rank==0) then
+     nivd(1) = 1
+     CALL histvert(filedid, 'sig_s', 'Niveaux sigma', &
+           'sigma_level', &
+           1, nivd, dvertiid)
+  endif
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+          iip1,jjn,thoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(fileid, "aire", "Grid area", "-", &
+           iip1,jjn,thoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    if (mpi_rank==0) then
+
+    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
+          1,1,dhoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istdyn", "tps stock", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    endif
+  !
+  ! Masse
+  !
+  CALL histdef(fileid, 'masse', 'Masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbaru
+  !
+  CALL histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
+        iip1, jjn, uhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Pbarv
+  !
+  if (pole_sud) jjn=jj_nb-1
+
+  CALL histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
+        iip1, jjn, vhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  w
+  !
+  if (pole_sud) jjn=jj_nb
+  CALL histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature potentielle
+  !
+  CALL histdef(fileid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+
+  !
+  ! Geopotentiel
+  !
+  CALL histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  CALL histend(fileid)
+  CALL histend(filevid)
+  if (mpi_rank==0) CALL histend(filedid)
+  if (ok_sync) then
+    CALL histsync(fileid)
+    CALL histsync(filevid)
+    if (mpi_rank==0) CALL histsync(filedid)
+  endif
+
+
+end subroutine initfluxsto_p
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,452 +1,0 @@
-
-! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
-
-      SUBROUTINE integrd_loc
-     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
-     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
-      USE parallel_lmdz
-      USE control_mod
-      USE mod_filtreg_p
-      USE write_field_loc
-      USE write_field
-      USE integrd_mod
-      USE comconst_mod, ONLY: pi
-      USE logic_mod, ONLY: leapf
-      USE comvert_mod, ONLY: ap, bp
-      USE temps_mod, ONLY: dt
-      USE strings_mod, ONLY: int2str
-      
-      IMPLICIT NONE
-
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   objet:
-c   ------
-c
-c   Incrementation des tendances dynamiques
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
-
-      REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
-      REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
-      REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
-      REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
-      REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
-      REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
-      REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
-      ! values at previous time step
-      REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
-      REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
-      REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
-      ! the tendencies to add
-      REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
-      REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
-      REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
-!      REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
-
-c   Local:
-c   ------
-
-      REAL vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
-      REAL hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
-      REAL massescr( ijb_u:ije_u,llm )
-!      REAL finvmasse(ijb_u:ije_u,llm)
-      REAL tpn,tps,tppn(iim),tpps(iim)
-      REAL qpn,qps,qppn(iim),qpps(iim)
-
-      INTEGER  l,ij,iq,i,j
-
-      REAL SSUM
-      EXTERNAL SSUM
-      INTEGER ijb,ije,jjb,jje
-      LOGICAL :: checksum
-      LOGICAL,SAVE :: checksum_all=.TRUE.
-      INTEGER :: stop_it
-      INTEGER :: ierr
-
-      !write(*,*) 'integrd 88: entree, nq=',nq
-c-----------------------------------------------------------------------
-
-c$OMP BARRIER     
-      if (pole_nord) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO  l = 1,llm
-          DO  ij = 1,iip1
-           ucov(    ij    , l) = 0.
-           uscr(     ij      ) = 0.
-           ENDDO
-        ENDDO
-c$OMP END DO NOWAIT        
-      ENDIF
-
-      if (pole_sud) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO  l = 1,llm
-          DO  ij = 1,iip1
-           ucov( ij +ip1jm, l) = 0.
-           uscr( ij +ip1jm   ) = 0.
-          ENDDO
-        ENDDO
-c$OMP END DO NOWAIT      
-      ENDIF
-
-c    ............    integration  de       ps         ..............
-
-c      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
-
-      ijb=ij_begin
-      ije=ij_end
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-      DO  l = 1,llm
-        massescr(ijb:ije,l)=masse(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT 
-
-c$OMP DO SCHEDULE(STATIC)
-      DO ij = ijb,ije
-       pscr (ij)    = ps0(ij)
-       ps (ij)      = psm1(ij) + dt * dp(ij)     
-
-      END DO
-
-c$OMP END DO  
-c$OMP BARRIER
-c --> ici synchro OPENMP pour ps
-       
-      checksum=.TRUE.
-      stop_it=0
-
-c$OMP MASTER
-!c$OMP DO SCHEDULE(STATIC)
-      DO ij = ijb,ije
-         IF( ps(ij)<0. ) THEN
-           IF (checksum) stop_it=ij
-           checksum=.FALSE.
-         ENDIF
-       ENDDO
-!c$OMP END DO NOWAIT 
-       
-!      CALL MPI_ALLREDUCE(checksum,checksum_all,1,
-!     &                   MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr)
-      IF( .NOT. checksum ) THEN
-         write(lunout,*) "integrd: ps = ", ps(stop_it)
-         write(lunout,*) " at node ij =", stop_it
-         ! since ij=j+(i-1)*jjp1 , we have
-          j=modulo(stop_it,jjp1)
-          i=1+(stop_it-j)/jjp1
-          write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
-     &                    " lat = ",rlatu(j)*180./pi, " deg"
-         CALL abort_gcm("integrd_loc", "negative surface pressure", 1)
-      ENDIF
-
-c$OMP END MASTER
-c$OMP BARRIER
-        !write(*,*) 'integrd 170'
-      IF (.NOT. Checksum_all) THEN
-        CALL WriteField_v('int_vcov',vcov)
-        CALL WriteField_u('int_ucov',ucov)
-        CALL WriteField_u('int_teta',teta)
-        CALL WriteField_u('int_ps0',ps0)
-        CALL WriteField_u('int_masse',masse)
-        CALL WriteField_u('int_phis',phis)
-        CALL WriteField_v('int_vcovm1',vcovm1)
-        CALL WriteField_u('int_ucovm1',ucovm1)
-        CALL WriteField_u('int_tetam1',tetam1)
-        CALL WriteField_u('int_psm1',psm1)
-        CALL WriteField_u('int_massem1',massem1)
-
-        CALL WriteField_v('int_dv',dv)
-        CALL WriteField_u('int_du',du)
-        CALL WriteField_u('int_dteta',dteta)
-        CALL WriteField_u('int_dp',dp)
-!        CALL WriteField_u('int_finvmaold',finvmaold)
-        do j=1,nq
-          CALL WriteField_u('int_q'//trim(int2str(j)),
-     .                q(:,:,j))
-          CALL WriteField_u('int_dq'//trim(int2str(j)),
-     .                dq(:,:,j))
-        enddo
-        CALL abort_gcm("integrd_loc", "", 1)
-      ENDIF
-    
-       
-c
-        !write(*,*) 'integrd 200'
-C$OMP MASTER
-      if (pole_nord) THEN
-      
-        DO  ij    = 1, iim
-         tppn(ij) = aire(   ij   ) * ps(  ij    )
-        ENDDO
-         tpn      = SSUM(iim,tppn,1)/apoln
-        DO ij   = 1, iip1
-         ps(   ij   )  = tpn
-        ENDDO
-      
-      ENDIF
-      
-      if (pole_sud) THEN
-      
-        DO  ij    = 1, iim
-         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
-        ENDDO
-         tps      = SSUM(iim,tpps,1)/apols
-        DO ij   = 1, iip1
-         ps(ij+ip1jm)  = tps
-        ENDDO
-      
-      ENDIF
-c$OMP END MASTER
-c$OMP BARRIER
-      !write(*,*) 'integrd 217'  
-c
-c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
-c
-
-      CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
-
-c$OMP BARRIER
-      CALL massdair_loc (     p  , masse         )
-
-! Ehouarn : we don't use/need finvmaold and finvmasse,
-!           so might as well not compute them
-!c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
-!      ijb=ij_begin
-!      ije=ij_end
-
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-!      DO  l = 1,llm
-!        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
-!      ENDDO
-!c$OMP END DO NOWAIT
-
-!      jjb=jj_begin
-!      jje=jj_end
-!      CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
-!     &                -2, 2, .TRUE., 1  )
-c
-
-c    ............   integration  de  ucov, vcov,  h     ..............
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-      DO l = 1,llm
-      
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb,ije
-      uscr( ij )   =  ucov( ij,l )
-      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
-      END DO
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb,ije
-      vscr( ij )   =  vcov( ij,l )
-      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
-      END DO
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-      DO ij = ijb,ije
-      hscr( ij )    =  teta(ij,l)
-      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) 
-     $                + dt * dteta(ij,l) / masse(ij,l)
-      END DO
-
-c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
-c
-c
-        !write(*,*) 'integrd 291'
-      IF (pole_nord) THEN
-       
-        DO  ij   = 1, iim
-          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
-        ENDDO
-          tpn      = SSUM(iim,tppn,1)/apoln
-
-        DO ij   = 1, iip1
-          teta(   ij   ,l)  = tpn
-        ENDDO
-      
-      ENDIF
-      
-      IF (pole_sud) THEN
-       
-        DO  ij   = 1, iim
-          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
-        ENDDO
-          tps      = SSUM(iim,tpps,1)/apols
-
-        DO ij   = 1, iip1
-          teta(ij+ip1jm,l)  = tps
-        ENDDO
-      
-      ENDIF
-c
-
-      IF(leapf)  THEN
-c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
-c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
-c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
-        ijb=ij_begin
-        ije=ij_end
-        ucovm1(ijb:ije,l)=uscr(ijb:ije)
-        tetam1(ijb:ije,l)=hscr(ijb:ije)
-        if (pole_sud) ije=ij_end-iip1
-        vcovm1(ijb:ije,l)=vscr(ijb:ije)
-      
-      END IF
-
-      END DO
-c$OMP END DO NOWAIT
-
-c
-c   .......  integration de   q   ......
-c
-      ijb=ij_begin
-      ije=ij_end
-
-         if (planet_type=="earth") then
-! Earth-specific treatment of first 2 tracers (water)
-c$OMP BARRIER
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-          DO l = 1, llm
-           DO ij = ijb, ije
-            deltap(ij,l) =  p(ij,l) - p(ij,l+1) 
-           ENDDO
-          ENDDO
-          
-c$OMP END DO NOWAIT
-c$OMP BARRIER
-
-        CALL check_isotopes(q,ijb,ije,'integrd 342')
-
-        !write(*,*) 'integrd 341'
-        CALL qminimum_loc( q, nq, deltap )
-        !write(*,*) 'integrd 343'
-
-        CALL check_isotopes(q,ijb,ije,'integrd 346')
-c
-c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
-c
-c$OMP BARRIER
-      IF (pole_nord) THEN 
-      
-        DO iq = 1, nq
-        
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-  
-             DO ij = 1, iim
-               qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
-             ENDDO
-               qpn  =  SSUM(iim,qppn,1)/apoln
-      
-             DO ij = 1, iip1
-               q(   ij   ,l,iq)  = qpn
-             ENDDO    
-  
-          ENDDO
-c$OMP END DO NOWAIT
-
-        ENDDO
-      
-      ENDIF
-
-      IF (pole_sud) THEN 
-      
-        DO iq = 1, nq
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-  
-             DO ij = 1, iim
-               qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
-             ENDDO
-               qps  =  SSUM(iim,qpps,1)/apols 
-  
-             DO ij = 1, iip1
-               q(ij+ip1jm,l,iq)  = qps
-             ENDDO    
-  
-          ENDDO
-c$OMP END DO NOWAIT
-
-        ENDDO
-      
-      ENDIF
-
-      CALL check_isotopes(q,ijb,ije,'integrd 409')
-      
-! Ehouarn: forget about finvmaold
-!c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
-
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-!      DO l = 1, llm      
-!        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)        
-!      ENDDO
-!c$OMP END DO NOWAIT
-
-      endif ! of if (planet_type.eq."earth")
-
-c
-c
-c     .....   FIN  de l'integration  de   q    .......
-
-15    continue
-          !write(*,*) 'integrd 410'
-
-c$OMP DO SCHEDULE(STATIC)
-      DO ij=ijb,ije  
-        ps0(ij)=ps(ij)
-      ENDDO
-c$OMP END DO NOWAIT 
-
-c    .................................................................
-
-
-      IF( leapf )  THEN
-c       CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
-c       CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
-c$OMP DO SCHEDULE(STATIC)
-      DO ij=ijb,ije  
-        psm1(ij)=pscr(ij)
-      ENDDO
-c$OMP END DO NOWAIT 
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-            massem1(ijb:ije,l)=massescr(ijb:ije,l)
-          ENDDO
-c$OMP END DO NOWAIT          
-      END IF
-c$OMP BARRIER
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.f90	(revision 5105)
@@ -0,0 +1,451 @@
+
+! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
+
+SUBROUTINE integrd_loc &
+        (  nq,vcovm1,ucovm1,tetam1,psm1,massem1, &
+        dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
+  USE parallel_lmdz
+  USE control_mod
+  USE mod_filtreg_p
+  USE write_field_loc
+  USE write_field
+  USE integrd_mod
+  USE comconst_mod, ONLY: pi
+  USE logic_mod, ONLY: leapf
+  USE comvert_mod, ONLY: ap, bp
+  USE temps_mod, ONLY: dt
+  USE strings_mod, ONLY: int2str
+
+  IMPLICIT NONE
+
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   objet:
+  !   ------
+  !
+  !   Incrementation des tendances dynamiques
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
+
+  REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
+  REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
+  REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
+  REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
+  ! ! values at previous time step
+  REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
+  REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
+  REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
+  ! ! the tendencies to add
+  REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
+  REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
+  REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
+   ! REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
+
+  !   Local:
+  !   ------
+
+  REAL :: vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
+  REAL :: hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
+  REAL :: massescr( ijb_u:ije_u,llm )
+   ! REAL finvmasse(ijb_u:ije_u,llm)
+  REAL :: tpn,tps,tppn(iim),tpps(iim)
+  REAL :: qpn,qps,qppn(iim),qpps(iim)
+
+  INTEGER :: l,ij,iq,i,j
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  LOGICAL :: checksum
+  LOGICAL,SAVE :: checksum_all=.TRUE.
+  INTEGER :: stop_it
+  INTEGER :: ierr
+
+  ! !write(*,*) 'integrd 88: entree, nq=',nq
+  !-----------------------------------------------------------------------
+
+!$OMP BARRIER
+  if (pole_nord) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  l = 1,llm
+      DO  ij = 1,iip1
+       ucov(    ij    , l) = 0.
+       uscr(     ij      ) = 0.
+       ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  if (pole_sud) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  l = 1,llm
+      DO  ij = 1,iip1
+       ucov( ij +ip1jm, l) = 0.
+       uscr( ij +ip1jm   ) = 0.
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  !    ............    integration  de       ps         ..............
+
+   ! CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l = 1,llm
+    massescr(ijb:ije,l)=masse(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC)
+  DO ij = ijb,ije
+   pscr (ij)    = ps0(ij)
+   ps (ij)      = psm1(ij) + dt * dp(ij)
+
+  END DO
+
+!$OMP END DO
+!$OMP BARRIER
+  ! --> ici synchro OPENMP pour ps
+
+  checksum=.TRUE.
+  stop_it=0
+
+!$OMP MASTER
+  !c$OMP DO SCHEDULE(STATIC)
+  DO ij = ijb,ije
+     IF( ps(ij)<0. ) THEN
+       IF (checksum) stop_it=ij
+       checksum=.FALSE.
+     ENDIF
+   ENDDO
+  !c$OMP END DO NOWAIT
+
+   ! CALL MPI_ALLREDUCE(checksum,checksum_all,1,
+  ! &                   MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr)
+  IF( .NOT. checksum ) THEN
+     write(lunout,*) "integrd: ps = ", ps(stop_it)
+     write(lunout,*) " at node ij =", stop_it
+     ! ! since ij=j+(i-1)*jjp1 , we have
+      j=modulo(stop_it,jjp1)
+      i=1+(stop_it-j)/jjp1
+      write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg", &
+            " lat = ",rlatu(j)*180./pi, " deg"
+     CALL abort_gcm("integrd_loc", "negative surface pressure", 1)
+  ENDIF
+
+!$OMP END MASTER
+!$OMP BARRIER
+    ! !write(*,*) 'integrd 170'
+  IF (.NOT. Checksum_all) THEN
+    CALL WriteField_v('int_vcov',vcov)
+    CALL WriteField_u('int_ucov',ucov)
+    CALL WriteField_u('int_teta',teta)
+    CALL WriteField_u('int_ps0',ps0)
+    CALL WriteField_u('int_masse',masse)
+    CALL WriteField_u('int_phis',phis)
+    CALL WriteField_v('int_vcovm1',vcovm1)
+    CALL WriteField_u('int_ucovm1',ucovm1)
+    CALL WriteField_u('int_tetam1',tetam1)
+    CALL WriteField_u('int_psm1',psm1)
+    CALL WriteField_u('int_massem1',massem1)
+
+    CALL WriteField_v('int_dv',dv)
+    CALL WriteField_u('int_du',du)
+    CALL WriteField_u('int_dteta',dteta)
+    CALL WriteField_u('int_dp',dp)
+     ! CALL WriteField_u('int_finvmaold',finvmaold)
+    do j=1,nq
+      CALL WriteField_u('int_q'//trim(int2str(j)), &
+            q(:,:,j))
+      CALL WriteField_u('int_dq'//trim(int2str(j)), &
+            dq(:,:,j))
+    enddo
+    CALL abort_gcm("integrd_loc", "", 1)
+  ENDIF
+
+
+  !
+  !   !write(*,*) 'integrd 200'
+!$OMP MASTER
+  if (pole_nord) THEN
+
+    DO  ij    = 1, iim
+     tppn(ij) = aire(   ij   ) * ps(  ij    )
+    ENDDO
+     tpn      = SSUM(iim,tppn,1)/apoln
+    DO ij   = 1, iip1
+     ps(   ij   )  = tpn
+    ENDDO
+
+  ENDIF
+
+  if (pole_sud) THEN
+
+    DO  ij    = 1, iim
+     tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+    ENDDO
+     tps      = SSUM(iim,tpps,1)/apols
+    DO ij   = 1, iip1
+     ps(ij+ip1jm)  = tps
+    ENDDO
+
+  ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  ! !write(*,*) 'integrd 217'
+  !
+  !  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+  !
+
+  CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
+
+!$OMP BARRIER
+  CALL massdair_loc (     p  , masse         )
+
+  ! Ehouarn : we don't use/need finvmaold and finvmasse,
+        ! so might as well not compute them
+  !c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+   ! ijb=ij_begin
+   ! ije=ij_end
+
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   ! DO  l = 1,llm
+   !   finvmasse(ijb:ije,l)=masse(ijb:ije,l)
+   ! ENDDO
+  !c$OMP END DO NOWAIT
+
+   ! jjb=jj_begin
+   ! jje=jj_end
+   ! CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
+  ! &                -2, 2, .TRUE., 1  )
+  !
+
+  !    ............   integration  de  ucov, vcov,  h     ..............
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+  uscr( ij )   =  ucov( ij,l )
+  ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+  END DO
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+  vscr( ij )   =  vcov( ij,l )
+  vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+  END DO
+
+  ijb=ij_begin
+  ije=ij_end
+
+  DO ij = ijb,ije
+  hscr( ij )    =  teta(ij,l)
+  teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) &
+        + dt * dteta(ij,l) / masse(ij,l)
+  END DO
+
+  !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+  !
+  !
+  !   !write(*,*) 'integrd 291'
+  IF (pole_nord) THEN
+
+    DO  ij   = 1, iim
+      tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+    ENDDO
+      tpn      = SSUM(iim,tppn,1)/apoln
+
+    DO ij   = 1, iip1
+      teta(   ij   ,l)  = tpn
+    ENDDO
+
+  ENDIF
+
+  IF (pole_sud) THEN
+
+    DO  ij   = 1, iim
+      tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+    ENDDO
+      tps      = SSUM(iim,tpps,1)/apols
+
+    DO ij   = 1, iip1
+      teta(ij+ip1jm,l)  = tps
+    ENDDO
+
+  ENDIF
+  !
+
+  IF(leapf)  THEN
+      ! CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+      ! CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+      ! CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+    ijb=ij_begin
+    ije=ij_end
+    ucovm1(ijb:ije,l)=uscr(ijb:ije)
+    tetam1(ijb:ije,l)=hscr(ijb:ije)
+    if (pole_sud) ije=ij_end-iip1
+    vcovm1(ijb:ije,l)=vscr(ijb:ije)
+
+  END IF
+
+  END DO
+!$OMP END DO NOWAIT
+
+  !
+  !   .......  integration de   q   ......
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+     if (planet_type=="earth") then
+  ! Earth-specific treatment of first 2 tracers (water)
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+       DO ij = ijb, ije
+        deltap(ij,l) =  p(ij,l) - p(ij,l+1)
+       ENDDO
+      ENDDO
+
+!$OMP END DO NOWAIT
+!$OMP BARRIER
+
+    CALL check_isotopes(q,ijb,ije,'integrd 342')
+
+    ! !write(*,*) 'integrd 341'
+    CALL qminimum_loc( q, nq, deltap )
+    ! !write(*,*) 'integrd 343'
+
+    CALL check_isotopes(q,ijb,ije,'integrd 346')
+  !
+  !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+  !
+!$OMP BARRIER
+  IF (pole_nord) THEN
+
+    DO iq = 1, nq
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+
+         DO ij = 1, iim
+           qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+         ENDDO
+           qpn  =  SSUM(iim,qppn,1)/apoln
+
+         DO ij = 1, iip1
+           q(   ij   ,l,iq)  = qpn
+         ENDDO
+
+      ENDDO
+!$OMP END DO NOWAIT
+
+    ENDDO
+
+  ENDIF
+
+  IF (pole_sud) THEN
+
+    DO iq = 1, nq
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+
+         DO ij = 1, iim
+           qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+         ENDDO
+           qps  =  SSUM(iim,qpps,1)/apols
+
+         DO ij = 1, iip1
+           q(ij+ip1jm,l,iq)  = qps
+         ENDDO
+
+      ENDDO
+!$OMP END DO NOWAIT
+
+    ENDDO
+
+  ENDIF
+
+  CALL check_isotopes(q,ijb,ije,'integrd 409')
+
+  ! Ehouarn: forget about finvmaold
+  !c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   ! DO l = 1, llm
+   !   finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
+   ! ENDDO
+  !c$OMP END DO NOWAIT
+
+  endif ! of if (planet_type.eq."earth")
+
+  !
+  !
+  ! .....   FIN  de l'integration  de   q    .......
+
+      ! !write(*,*) 'integrd 410'
+
+!$OMP DO SCHEDULE(STATIC)
+  DO ij=ijb,ije
+    ps0(ij)=ps(ij)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !    .................................................................
+
+
+  IF( leapf )  THEN
+    ! CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+    ! CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+!$OMP DO SCHEDULE(STATIC)
+  DO ij=ijb,ije
+    psm1(ij)=pscr(ij)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+        massem1(ijb:ije,l)=massescr(ijb:ije,l)
+      ENDDO
+!$OMP END DO NOWAIT
+  END IF
+!$OMP BARRIER
+
+END SUBROUTINE integrd_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,65 +1,0 @@
-      SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam,
-     *                        unsapolnga, unsapolsga, teta, divgra )
-
-c  P. Le Van
-c
-c   ************************************************************
-c
-c      ....   calcul de  (div( grad ))   de   teta  .....
-c   ************************************************************
-c    klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    ............     variables  en arguments    ..........
-c
-      INTEGER klevel
-      REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
-      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 )
-      REAL unsaigam(ip1jmp1)
-      REAL unsapolnga, unsapolsga
-c
-c    ...........    variables  locales    .................
-c
-      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
-c    ......................................................
-
-      INTEGER :: ijb,ije
-      INTEGER :: l      
-c
-c
-c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
-c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
-c   ...  unsairegam =  1. /  aire ** (- gamdissip )
-c
-
-c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
-      
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud ) ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,klevel      
-        divgra(ijb:ije,l)=teta(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-c
-      CALL   grad_loc ( klevel, divgra, ghx, ghy )
-c
-      CALL  diverg_gam_loc ( klevel, cuvsga, cvusga,  unsaigam  ,
-     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
-
-c
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.f90	(revision 5105)
@@ -0,0 +1,65 @@
+SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam, &
+        unsapolnga, unsapolsga, teta, divgra )
+
+  !  P. Le Van
+  !
+  !   ************************************************************
+  !
+  !  ....   calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  !    klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    ............     variables  en arguments    ..........
+  !
+  INTEGER :: klevel
+  REAL :: teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
+  REAL :: cuvsga(ip1jm) , cvusga( ip1jmp1 )
+  REAL :: unsaigam(ip1jmp1)
+  REAL :: unsapolnga, unsapolsga
+  !
+  !    ...........    variables  locales    .................
+  !
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !    ......................................................
+
+  INTEGER :: ijb,ije
+  INTEGER :: l
+  !
+  !
+  !   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+  !   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+  !   ...  unsairegam =  1. /  aire ** (- gamdissip )
+  !
+
+  !  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud ) ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,klevel
+    divgra(ijb:ije,l)=teta(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+  CALL   grad_loc ( klevel, divgra, ghx, ghy )
+  !
+  CALL  diverg_gam_loc ( klevel, cuvsga, cvusga,  unsaigam  , &
+        unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+  !
+
+
+END SUBROUTINE laplacien_gam_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,58 +1,0 @@
-      SUBROUTINE laplacien_loc ( klevel, teta, divgra )
-c
-c     P. Le Van
-c
-c   ************************************************************
-c    ....     calcul de  (div( grad ))   de   teta  .....
-c   ************************************************************
-c     klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    .........      variables  en arguments   ..............
-c
-      INTEGER klevel
-      REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
-      INTEGER :: l
-c
-c    ............     variables  locales      ..............
-c
-      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
-c    .......................................................
-
-      
-      INTEGER :: ijb,ije,jjb,jje
-c
-c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
-
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud ) ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,klevel      
-        divgra(ijb:ije,l)=teta(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-      
-      jjb=jj_begin-1
-      jje=jj_end+1
-      if (pole_nord) jjb=jj_begin
-      if (pole_sud ) jje=jj_end
-      
-      CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, 
-     &                klevel,  2, 1, .TRUE., 1 )
-      CALL   grad_loc ( klevel,divgra,   ghx , ghy              )
-      CALL  divergf_loc ( klevel, ghx , ghy  , divgra           )
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.f90	(revision 5105)
@@ -0,0 +1,58 @@
+SUBROUTINE laplacien_loc ( klevel, teta, divgra )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !    ....     calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    .........      variables  en arguments   ..............
+  !
+  INTEGER :: klevel
+  REAL :: teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
+  INTEGER :: l
+  !
+  !    ............     variables  locales      ..............
+  !
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !    .......................................................
+
+
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud ) ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,klevel
+    divgra(ijb:ije,l)=teta(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud ) jje=jj_end
+
+  CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, &
+        klevel,  2, 1, .TRUE., 1 )
+  CALL   grad_loc ( klevel,divgra,   ghx , ghy              )
+  CALL  divergf_loc ( klevel, ghx , ghy  , divgra           )
+
+
+END SUBROUTINE laplacien_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,47 +1,0 @@
-      SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
-c
-c    P. Le Van
-c
-c   ************************************************************
-c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
-c   ************************************************************
-c
-c     klevel et rotin  sont des arguments  d'entree pour le s-prog
-c      rotout           est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c 
-c   ..........    variables  en  arguments     .............
-c
-      INTEGER klevel
-      REAL rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
-c
-c   ..........    variables   locales       ................
-c
-      REAL ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel)
-c   ........................................................
-c
-c
-      INTEGER :: ijb,ije,jjb,jje
-      
-      jjb=jj_begin-1
-      jje=jj_end+1
-      
-      if (pole_nord) jjb=jj_begin
-      if (pole_sud) jje=jj_end-1
-      
-      CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm,
-     &                  klevel,2, 1, .FALSE., 1)
-
-      CALL   nxgrad_loc ( klevel, rotin,   ghx ,  ghy            )
-      CALL   rotatf_loc  ( klevel, ghx  ,   ghy , rotout         )
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.f90	(revision 5105)
@@ -0,0 +1,47 @@
+SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
+  !
+  !    P. Le Van
+  !
+  !   ************************************************************
+  !    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+  !   ************************************************************
+  !
+  ! klevel et rotin  sont des arguments  d'entree pour le s-prog
+  !  rotout           est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !   ..........    variables  en  arguments     .............
+  !
+  INTEGER :: klevel
+  REAL :: rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+  !
+  !   ..........    variables   locales       ................
+  !
+  REAL :: ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel)
+  !   ........................................................
+  !
+  !
+  INTEGER :: ijb,ije,jjb,jje
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+
+  CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm, &
+        klevel,2, 1, .FALSE., 1)
+
+  CALL   nxgrad_loc ( klevel, rotin,   ghx ,  ghy            )
+  CALL   rotatf_loc  ( klevel, ghx  ,   ghy , rotout         )
+  !
+
+END SUBROUTINE laplacien_rot_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rotgam_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rotgam_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,48 +1,0 @@
-      SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
-c
-c     P. Le Van
-c
-c   ************************************************************
-c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
-c   ************************************************************
-c     klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    .............   variables  en  arguments    ...........
-c
-      INTEGER klevel
-      REAL rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
-c
-c   ............     variables   locales     ...............
-c
-      INTEGER l, ij
-      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
-c   ........................................................
-c
-      INTEGER :: ijb,ije
-      
-c
-
-      CALL   nxgrad_gam_loc ( klevel, rotin,   ghx ,   ghy  )
-      CALL   rotat_nfil_loc ( klevel, ghx  ,   ghy , rotout )
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l = 1, klevel
-        DO ij = ijb, ije
-         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rotgam_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rotgam_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rotgam_loc.f90	(revision 5105)
@@ -0,0 +1,48 @@
+SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    .............   variables  en  arguments    ...........
+  !
+  INTEGER :: klevel
+  REAL :: rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+  !
+  !   ............     variables   locales     ...............
+  !
+  INTEGER :: l, ij
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !   ........................................................
+  !
+  INTEGER :: ijb,ije
+
+  !
+
+  CALL   nxgrad_gam_loc ( klevel, rotin,   ghx ,   ghy  )
+  CALL   rotat_nfil_loc ( klevel, ghx  ,   ghy , rotout )
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+     rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE laplacien_rotgam_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/leapfrog_loc.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/leapfrog_loc.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/leapfrog_loc.F90	(revision 5105)
@@ -1290,4 +1290,4 @@
   abort_message = 'Simulation finished'
   CALL abort_gcm(modname, abort_message, 0)
-  RETURN
+
 END SUBROUTINE leapfrog_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,119 +1,0 @@
-      SUBROUTINE massdair_loc( p, masse )
-      USE parallel_lmdz
-c
-c *********************************************************************
-c       ....  Calcule la masse d'air  dans chaque maille   ....
-c *********************************************************************
-c
-c    Auteurs : P. Le Van , Fr. Hourdin  .
-c   ..........
-c
-c  ..    p                      est  un argum. d'entree pour le s-pg ...
-c  ..  masse                    est un  argum.de sortie pour le s-pg ...
-c     
-c  ....  p est defini aux interfaces des llm couches   .....
-c
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c  .....   arguments  ....
-c
-      REAL p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm)
-
-c   ....  Variables locales  .....
-
-      INTEGER l,ij
-      INTEGER ijb,ije
-      REAL massemoyn, massemoys
-
-      REAL SSUM
-      EXTERNAL SSUM
-c
-c
-c   Methode pour calculer massebx et masseby .
-c   ----------------------------------------
-c
-c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
-c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
-c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
-c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
-c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
-c
-c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
-c
-c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
-c
-c
-c
-c   alpha4 .         . alpha1    . alpha4
-c    (i,j)             (i,j)       (i+1,j)
-c
-c             P .        U .          . P
-c           (i,j)       (i,j)         (i+1,j)
-c
-c   alpha3 .         . alpha2    .alpha3 
-c    (i,j)              (i,j)     (i+1,j)
-c
-c             V .        Z .          . V
-c           (i,j)
-c
-c   alpha4 .         . alpha1    .alpha4
-c   (i,j+1)            (i,j+1)   (i+1,j+1) 
-c
-c             P .        U .          . P
-c          (i,j+1)                    (i+1,j+1)
-c
-c
-c
-c                       On  a :
-c
-c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
-c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-c     localise  au point  ... U (i,j) ...
-c
-c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
-c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-c     localise  au point  ... V (i,j) ...
-c
-c
-c=======================================================================
-
-      
-
-      
-      ijb=ij_begin-iip1
-      ije=ij_end+2*iip1
-      
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO   l = 1 , llm
-c
-        DO    ij     = ijb, ije
-         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
-        ENDDO
-c
-        DO   ij = ijb, ije,iip1
-         masse(ij+ iim,l) = masse(ij,l)
-        ENDDO
-c
-c       DO    ij     = 1,  iim
-c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
-c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
-c       ENDDO
-c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
-c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
-c       DO    ij     = 1, iip1
-c        masse(   ij   ,l )    = massemoyn
-c        masse(ij+ip1jm,l )    = massemoys
-c       ENDDO
-       
-      END DO
-c$OMP END DO NOWAIT
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.f90	(revision 5105)
@@ -0,0 +1,119 @@
+SUBROUTINE massdair_loc( p, masse )
+  USE parallel_lmdz
+  !
+  ! *********************************************************************
+  !   ....  Calcule la masse d'air  dans chaque maille   ....
+  ! *********************************************************************
+  !
+  !    Auteurs : P. Le Van , Fr. Hourdin  .
+  !   ..........
+  !
+  !  ..    p                      est  un argum. d'entree pour le s-pg ...
+  !  ..  masse                    est un  argum.de sortie pour le s-pg ...
+  !
+  !  ....  p est defini aux interfaces des llm couches   .....
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !  .....   arguments  ....
+  !
+  REAL :: p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm)
+
+  !   ....  Variables locales  .....
+
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  REAL :: massemoyn, massemoys
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  !
+  !   Methode pour calculer massebx et masseby .
+  !   ----------------------------------------
+  !
+  !    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+  !   alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+  !   alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+  !   alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+  !   alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+  !
+  !    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+  !
+  !    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+  !
+  !
+  !
+  !   alpha4 .         . alpha1    . alpha4
+  !    (i,j)             (i,j)       (i+1,j)
+  !
+  !         P .        U .          . P
+  !       (i,j)       (i,j)         (i+1,j)
+  !
+  !   alpha3 .         . alpha2    .alpha3
+  !    (i,j)              (i,j)     (i+1,j)
+  !
+  !         V .        Z .          . V
+  !       (i,j)
+  !
+  !   alpha4 .         . alpha1    .alpha4
+  !   (i,j+1)            (i,j+1)   (i+1,j+1)
+  !
+  !         P .        U .          . P
+  !      (i,j+1)                    (i+1,j+1)
+  !
+  !
+  !
+  !                   On  a :
+  !
+  !    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+  !               masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+  ! localise  au point  ... U (i,j) ...
+  !
+  !    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+  !               masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
+  ! localise  au point  ... V (i,j) ...
+  !
+  !
+  !=======================================================================
+
+
+
+
+  ijb=ij_begin-iip1
+  ije=ij_end+2*iip1
+
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1 , llm
+  !
+    DO    ij     = ijb, ije
+     masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+    ENDDO
+  !
+    DO   ij = ijb, ije,iip1
+     masse(ij+ iim,l) = masse(ij,l)
+    ENDDO
+  !
+  !   DO    ij     = 1,  iim
+  !    masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+  !    masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm)
+  !   ENDDO
+  !    massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+  !    massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+  !   DO    ij     = 1, iip1
+  !    masse(   ij   ,l )    = massemoyn
+  !    masse(ij+ip1jm,l )    = massemoys
+  !   ENDDO
+
+  END DO
+!$OMP END DO NOWAIT
+  !
+
+END SUBROUTINE massdair_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/mod_filtreg_p.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/mod_filtreg_p.F	(revision 5104)
+++ 	(revision )
@@ -1,442 +1,0 @@
-      MODULE mod_filtreg_p
-      
-      CONTAINS
-      
-      SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, 
-     &     ifiltre, iaire, griscal ,iter)
-      USE parallel_lmdz, ONLY: OMP_CHUNK
-      USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft,
-     &                              filtre_v_fft, filtre_inv_fft
-      USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
-      
-      USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus,
-     &                       matricevn, matricevs
-      
-      IMPLICIT NONE
-      
-c=======================================================================
-c
-c   Auteur: P. Le Van        07/10/97
-c   ------
-c
-c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
-c                     pour l'operateur  Filtre    .
-c   ------
-c
-c   Arguments:
-c   ----------
-c
-c      
-c      ibeg..iend            lattitude a filtrer
-c      nlat                  nombre de latitudes du champ
-c      nbniv                 nombre de niveaux verticaux a filtrer
-c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
-c                            en sortie : champ filtre
-c      ifiltre               +1  Transformee directe
-c                            -1  Transformee inverse
-c                            +2  Filtre directe
-c                            -2  Filtre inverse
-c
-c      iaire                 1   si champ intensif
-c                            2   si champ extensif (pondere par les aires)
-c
-c      iter                  1   filtre simple
-c
-c=======================================================================
-c
-c
-c                      Variable Intensive
-c                ifiltre = 1     filtre directe
-c                ifiltre =-1     filtre inverse
-c
-c                      Variable Extensive
-c                ifiltre = 2     filtre directe
-c                ifiltre =-2     filtre inverse
-c
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "coefils.h"
-c
-      INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
-      INTEGER,INTENT(IN) :: iaire
-      LOGICAL,INTENT(IN) :: griscal
-      REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
-      
-      INTEGER i,j,l,k
-      INTEGER iim2,immjm
-      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
-      INTEGER    hemisph
-      REAL :: champ_fft(iip1,jjb:jje,nbniv)
-!      REAL :: champ_in(iip1,jjb:jje,nbniv)
-      
-      LOGICAL,SAVE     :: first=.TRUE.
-c$OMP THREADPRIVATE(first) 
-
-      REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
-      INTEGER :: ll_nb, nbniv_loc
-      REAL, SAVE :: sdd12(iim,4)
-c$OMP THREADPRIVATE(sdd12) 
-
-      INTEGER, PARAMETER :: type_sddu=1
-      INTEGER, PARAMETER :: type_sddv=2
-      INTEGER, PARAMETER :: type_unsddu=3
-      INTEGER, PARAMETER :: type_unsddv=4
-
-      INTEGER :: sdd1_type, sdd2_type
-      CHARACTER (LEN=132) :: abort_message
-
-      IF (first) THEN
-         sdd12(1:iim,type_sddu) = sddu(1:iim)
-         sdd12(1:iim,type_sddv) = sddv(1:iim)
-         sdd12(1:iim,type_unsddu) = unsddu(1:iim)
-         sdd12(1:iim,type_unsddv) = unsddv(1:iim)
-
-         CALL Init_timer
-         first=.FALSE.
-      ENDIF
-
-c$OMP MASTER      
-      CALL start_timer
-c$OMP END MASTER
-
-c-------------------------------------------------------c
-
-      IF(ifiltre==1.or.ifiltre==-1)
-     &  CALL abort_gcm("mod_filtreg_p",'Pas de transformee 
-     &simple dans cette version',1)
-      
-      IF( iter== 2 )  THEN
-         PRINT *,' Pas d iteration du filtre dans cette version !'
-     &        , ' Utiliser old_filtreg et repasser !'
-         CALL abort_gcm("mod_filtreg_p","stopped",1)
-      ENDIF
-
-      IF( ifiltre== -2 .AND..NOT.griscal )     THEN
-         PRINT *,' Cette routine ne calcule le filtre inverse que '
-     &        , ' sur la grille des scalaires !'
-         CALL abort_gcm("mod_filtreg_p","stopped",1)
-      ENDIF
-
-      IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
-         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
-     &        , ' corriger et repasser !'
-         CALL abort_gcm("mod_filtreg_p","stopped",1)
-      ENDIF
-c
-
-      iim2   = iim * iim
-      immjm  = iim * jjm
-c
-c
-      IF( griscal )   THEN
-         IF( nlat. NE. jjp1 )  THEN
-            CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjp1",1)
-         ELSE
-c     
-            IF( iaire==1 )  THEN
-               sdd1_type = type_sddv
-               sdd2_type = type_unsddv
-            ELSE
-               sdd1_type = type_unsddv
-               sdd2_type = type_sddv
-            ENDIF
-c
-            jdfil1 = 2
-            jffil1 = jfiltnu
-            jdfil2 = jfiltsu
-            jffil2 = jjm
-         ENDIF
-      ELSE
-         IF( nlat/=jjm )  THEN
-            CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjm",1)
-         ELSE
-c
-            IF( iaire==1 )  THEN
-               sdd1_type = type_sddu
-               sdd2_type = type_unsddu
-            ELSE
-               sdd1_type = type_unsddu
-               sdd2_type = type_sddu
-            ENDIF
-c     
-            jdfil1 = 1
-            jffil1 = jfiltnv
-            jdfil2 = jfiltsv
-            jffil2 = jjm
-         ENDIF
-      ENDIF
-c      
-      DO hemisph = 1, 2
-c     
-         IF ( hemisph==1 )  THEN
-cym
-            jdfil = max(jdfil1,ibeg)
-            jffil = min(jffil1,iend)
-         ELSE
-cym
-            jdfil = max(jdfil2,ibeg)
-            jffil = min(jffil2,iend)
-         ENDIF
-
-
-cccccccccccccccccccccccccccccccccccccccccccc
-c Utilisation du filtre classique
-cccccccccccccccccccccccccccccccccccccccccccc
-
-         IF (.NOT. use_filtre_fft) THEN
-      
-c     !---------------------------------!
-c     ! Agregation des niveau verticaux !
-c     ! uniquement necessaire pour une  !
-c     ! execution OpenMP                !
-c     !---------------------------------!
-            ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l = 1, nbniv
-               ll_nb = ll_nb+1
-               DO j = jdfil,jffil
-                  DO i = 1, iim
-                     champ_loc(i,j,ll_nb) = 
-     &                    champ(i,j,l) * sdd12(i,sdd1_type)
-                  ENDDO
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-
-            nbniv_loc = ll_nb
-
-            IF( hemisph==1 )      THEN
-               
-               IF( ifiltre==-2 )   THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matrinvn(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matrinvn(1:iim,1:iim,j),
-     &                    champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE IF ( griscal )     THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matriceun(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matriceun(1:iim,1:iim,j),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE 
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matricevn(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matricevn(1:iim,1:iim,j),           
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ENDIF
-               
-            ELSE
-               
-               IF( ifiltre==-2 )   THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matrinvs(1,1,j-jfiltsu+1), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE IF ( griscal )     THEN
-                  
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matriceus(1,1,j-jfiltsu+1), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matriceus(1:iim,1:iim,j-jfiltsu+1),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE 
-                  
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matricevs(1,1,j-jfiltsv+1), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matricevs(1:iim,1:iim,j-jfiltsv+1),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ENDIF
-               
-            ENDIF
-!     c     
-            IF( ifiltre==2 )  THEN
-               
-c     !-------------------------------------!
-c     ! DÃ©s-agregation des niveau verticaux !
-c     ! uniquement necessaire pour une      !
-c     ! execution OpenMP                    !
-c     !-------------------------------------!
-               ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-               DO l = 1, nbniv
-                  ll_nb = ll_nb + 1
-                  DO j = jdfil,jffil
-                     DO i = 1, iim
-                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
-     &                       + champ_fft(i,j,ll_nb))
-     &                       * sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT
-               
-            ELSE
-               
-               ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-               DO l = 1, nbniv
-                  ll_nb = ll_nb + 1
-                  DO j = jdfil,jffil
-                     DO i = 1, iim
-                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
-     &                       - champ_fft(i,j,ll_nb))
-     &                       * sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT
-               
-            ENDIF
-            
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l = 1, nbniv
-               DO j = jdfil,jffil
-                  ! add redundant longitude
-                  champ( iip1,j,l ) = champ( 1,j,l )
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-            
-ccccccccccccccccccccccccccccccccccccccccccccc
-c Utilisation du filtre FFT
-ccccccccccccccccccccccccccccccccccccccccccccc
-        
-         ELSE
-       
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l=1,nbniv
-               DO j=jdfil,jffil
-                  DO  i = 1, iim
-                     champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
-                     champ_fft( i,j,l) = champ(i,j,l)
-                  ENDDO
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-
-            IF (jdfil<=jffil) THEN
-               IF( ifiltre == -2 )   THEN
-                CALL Filtre_inv_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv) 
-               ELSE IF ( griscal )     THEN
-                  CALL Filtre_u_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
-               ELSE
-                  CALL Filtre_v_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
-               ENDIF
-            ENDIF
-
-
-            IF( ifiltre== 2 )  THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
-               DO l=1,nbniv
-                  DO j=jdfil,jffil
-                     DO  i = 1, iim
-                        champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l))
-     &                       *sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT	  
-            ELSE
-        
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
-               DO l=1,nbniv
-                  DO j=jdfil,jffil
-                     DO  i = 1, iim
-                        champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l))
-     &                       *sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT          
-            ENDIF
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-            DO l=1,nbniv
-               DO j=jdfil,jffil
-!            champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
-                  ! add redundant longitude
-                  champ( iip1,j,l ) = champ( 1,j,l )
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT          	
-         ENDIF 
-c Fin de la zone de filtrage
-
-	
-      ENDDO
-
-!      DO j=1,nlat
-
-!          PRINT *,"check FFT ----> Delta(",j,")=",
-!     &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
-!     &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) 
-!      ENDDO
-      
-!          PRINT *,"check FFT ----> Delta(",j,")=",
-!     &            sum(champ-champ_fft)/sum(champ)
-
-c
- 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
-     &     filtrer, sur la grille des scalaires'/)
- 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
-     &     ltrer, sur la grille de V ou de Z'/)
-c$OMP MASTER      
-      CALL stop_timer
-c$OMP END MASTER
-      RETURN
-      END SUBROUTINE filtreg_p
-      END MODULE mod_filtreg_p
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/mod_filtreg_p.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/mod_filtreg_p.F90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/mod_filtreg_p.F90	(revision 5105)
@@ -0,0 +1,438 @@
+MODULE mod_filtreg_p
+
+CONTAINS
+
+  SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, &
+          ifiltre, iaire, griscal ,iter)
+    USE parallel_lmdz, ONLY: OMP_CHUNK
+    USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft, &
+          filtre_v_fft, filtre_inv_fft
+    USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
+
+    USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus, &
+          matricevn, matricevs
+
+    IMPLICIT NONE
+
+    !=======================================================================
+    !
+    !   Auteur: P. Le Van        07/10/97
+    !   ------
+    !
+    !   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+    !                 pour l'operateur  Filtre    .
+    !   ------
+    !
+    !   Arguments:
+    !   ----------
+    !
+    !
+    !  ibeg..iend            lattitude a filtrer
+    !  nlat                  nombre de latitudes du champ
+    !  nbniv                 nombre de niveaux verticaux a filtrer
+    !  champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+    !                        en sortie : champ filtre
+    !  ifiltre               +1  Transformee directe
+    !                        -1  Transformee inverse
+    !                        +2  Filtre directe
+    !                        -2  Filtre inverse
+    !
+    !  iaire                 1   si champ intensif
+    !                        2   si champ extensif (pondere par les aires)
+    !
+    !  iter                  1   filtre simple
+    !
+    !=======================================================================
+    !
+    !
+    !                  Variable Intensive
+    !            ifiltre = 1     filtre directe
+    !            ifiltre =-1     filtre inverse
+    !
+    !                  Variable Extensive
+    !            ifiltre = 2     filtre directe
+    !            ifiltre =-2     filtre inverse
+    !
+    !
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "coefils.h"
+    !
+    INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
+    INTEGER,INTENT(IN) :: iaire
+    LOGICAL,INTENT(IN) :: griscal
+    REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
+
+    INTEGER :: i,j,l,k
+    INTEGER :: iim2,immjm
+    INTEGER :: jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+    INTEGER :: hemisph
+    REAL :: champ_fft(iip1,jjb:jje,nbniv)
+     ! REAL :: champ_in(iip1,jjb:jje,nbniv)
+
+    LOGICAL,SAVE     :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+    REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
+    INTEGER :: ll_nb, nbniv_loc
+    REAL, SAVE :: sdd12(iim,4)
+!$OMP THREADPRIVATE(sdd12)
+
+    INTEGER, PARAMETER :: type_sddu=1
+    INTEGER, PARAMETER :: type_sddv=2
+    INTEGER, PARAMETER :: type_unsddu=3
+    INTEGER, PARAMETER :: type_unsddv=4
+
+    INTEGER :: sdd1_type, sdd2_type
+    CHARACTER (LEN=132) :: abort_message
+
+    IF (first) THEN
+       sdd12(1:iim,type_sddu) = sddu(1:iim)
+       sdd12(1:iim,type_sddv) = sddv(1:iim)
+       sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+       sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+
+       CALL Init_timer
+       first=.FALSE.
+    ENDIF
+
+!$OMP MASTER
+    CALL start_timer
+!$OMP END MASTER
+
+    !-------------------------------------------------------c
+
+    IF(ifiltre==1.or.ifiltre==-1) &
+          CALL abort_gcm("mod_filtreg_p",'Pas de transformee&
+          &simple dans cette version',1)
+
+    IF( iter== 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'&
+             &        , ' Utiliser old_filtreg et repasser !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+
+    IF( ifiltre== -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ' &
+             , ' sur la grille des scalaires !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+
+    IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
+             , ' corriger et repasser !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+    !
+
+    iim2   = iim * iim
+    immjm  = iim * jjm
+    !
+    !
+    IF( griscal )   THEN
+       IF( nlat /= jjp1 )  THEN
+          CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjp1",1)
+       ELSE
+    !
+          IF( iaire==1 )  THEN
+             sdd1_type = type_sddv
+             sdd2_type = type_unsddv
+          ELSE
+             sdd1_type = type_unsddv
+             sdd2_type = type_sddv
+          ENDIF
+    !
+          jdfil1 = 2
+          jffil1 = jfiltnu
+          jdfil2 = jfiltsu
+          jffil2 = jjm
+       ENDIF
+    ELSE
+       IF( nlat/=jjm )  THEN
+          CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjm",1)
+       ELSE
+    !
+          IF( iaire==1 )  THEN
+             sdd1_type = type_sddu
+             sdd2_type = type_unsddu
+          ELSE
+             sdd1_type = type_unsddu
+             sdd2_type = type_sddu
+          ENDIF
+    !
+          jdfil1 = 1
+          jffil1 = jfiltnv
+          jdfil2 = jfiltsv
+          jffil2 = jjm
+       ENDIF
+    ENDIF
+    !
+    DO hemisph = 1, 2
+    !
+       IF ( hemisph==1 )  THEN
+    !ym
+          jdfil = max(jdfil1,ibeg)
+          jffil = min(jffil1,iend)
+       ELSE
+    !ym
+          jdfil = max(jdfil2,ibeg)
+          jffil = min(jffil2,iend)
+       ENDIF
+
+
+    !ccccccccccccccccccccccccccccccccccccccccccc
+    ! Utilisation du filtre classique
+    !ccccccccccccccccccccccccccccccccccccccccccc
+
+       IF (.NOT. use_filtre_fft) THEN
+
+    ! !---------------------------------!
+    ! ! Agregation des niveau verticaux !
+    ! ! uniquement necessaire pour une  !
+    ! ! execution OpenMP                !
+    ! !---------------------------------!
+          ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, nbniv
+             ll_nb = ll_nb+1
+             DO j = jdfil,jffil
+                DO i = 1, iim
+                   champ_loc(i,j,ll_nb) = &
+                         champ(i,j,l) * sdd12(i,sdd1_type)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+
+          nbniv_loc = ll_nb
+
+          IF( hemisph==1 )      THEN
+
+             IF( ifiltre==-2 )   THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matrinvn(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matrinvn(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE IF ( griscal )     THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matriceun(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matriceun(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matricevn(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matricevn(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ENDIF
+
+          ELSE
+
+             IF( ifiltre==-2 )   THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matrinvs(1,1,j-jfiltsu+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE IF ( griscal )     THEN
+
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matriceus(1,1,j-jfiltsu+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matriceus(1:iim,1:iim,j-jfiltsu+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE
+
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matricevs(1,1,j-jfiltsv+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matricevs(1:iim,1:iim,j-jfiltsv+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ENDIF
+
+          ENDIF
+    ! c
+          IF( ifiltre==2 )  THEN
+
+    ! !-------------------------------------!
+    ! ! DÃ©s-agregation des niveau verticaux !
+    ! ! uniquement necessaire pour une      !
+    ! ! execution OpenMP                    !
+    ! !-------------------------------------!
+             ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l = 1, nbniv
+                ll_nb = ll_nb + 1
+                DO j = jdfil,jffil
+                   DO i = 1, iim
+                      champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                            + champ_fft(i,j,ll_nb)) &
+                            * sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+
+          ELSE
+
+             ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l = 1, nbniv
+                ll_nb = ll_nb + 1
+                DO j = jdfil,jffil
+                   DO i = 1, iim
+                      champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                            - champ_fft(i,j,ll_nb)) &
+                            * sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+
+          ENDIF
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, nbniv
+             DO j = jdfil,jffil
+                ! ! add redundant longitude
+                champ( iip1,j,l ) = champ( 1,j,l )
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+
+    !cccccccccccccccccccccccccccccccccccccccccccc
+    ! Utilisation du filtre FFT
+    !cccccccccccccccccccccccccccccccccccccccccccc
+
+       ELSE
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,nbniv
+             DO j=jdfil,jffil
+                DO  i = 1, iim
+                   champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
+                   champ_fft( i,j,l) = champ(i,j,l)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+
+          IF (jdfil<=jffil) THEN
+             IF( ifiltre == -2 )   THEN
+              CALL Filtre_inv_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
+             ELSE IF ( griscal )     THEN
+                CALL Filtre_u_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
+             ELSE
+                CALL Filtre_v_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
+             ENDIF
+          ENDIF
+
+
+          IF( ifiltre== 2 )  THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l=1,nbniv
+                DO j=jdfil,jffil
+                   DO  i = 1, iim
+                      champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) &
+                            *sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT	
+          ELSE
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l=1,nbniv
+                DO j=jdfil,jffil
+                   DO  i = 1, iim
+                      champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) &
+                            *sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+          ENDIF
+    !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,nbniv
+             DO j=jdfil,jffil
+           ! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
+           !      ! add redundant longitude
+                champ( iip1,j,l ) = champ( 1,j,l )
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT          	
+       ENDIF
+    ! Fin de la zone de filtrage
+
+
+    ENDDO
+
+     ! DO j=1,nlat
+
+     !     PRINT *,"check FFT ----> Delta(",j,")=",
+    ! &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
+    ! &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:))
+    !  ENDDO
+
+    !      PRINT *,"check FFT ----> Delta(",j,")=",
+    ! &            sum(champ-champ_fft)/sum(champ)
+
+    !
+!$OMP MASTER
+    CALL stop_timer
+!$OMP END MASTER
+
+  END SUBROUTINE filtreg_p
+END MODULE mod_filtreg_p
+
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,69 +1,0 @@
-      SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y )
-c
-c  P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel )
-      REAL x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      integer ismin,ismax
-      external ismin,ismax
-      INTEGER :: ijb,ije
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1,klevel
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-      
-      DO ij = ijb+1, ije
-      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
-      END DO
-c
-c    ..... correction pour  y ( 1,j,l )  ......
-c
-c    ....    y(1,j,l)= y(iip1,j,l) ....
-CDIR$ IVDEP
-      DO ij = ijb, ije, iip1
-      y( ij,l ) = y( ij +iim,l )
-      END DO
-c
-      ijb=ij_begin
-      ije=ij_end+iip1
-      if(pole_nord) ijb=ij_begin+iip1
-      if(pole_sud) ije=ij_end-iip1
-      
-      DO ij = ijb,ije
-      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
-      END DO
-    
-      if (pole_nord) then
-        DO  ij = 1,iip1
-         x(    ij    ,l ) = 0.
-        ENDDO
-      endif
-
-      if (pole_sud) then
-        DO  ij = 1,iip1
-         x( ij +ip1jm,l ) = 0.
-        ENDDO
-      endif
-c
-      END DO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.f90	(revision 5105)
@@ -0,0 +1,69 @@
+SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y )
+  !
+  !  P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  integer :: ismin,ismax
+  external ismin,ismax
+  INTEGER :: ijb,ije
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+  DO ij = ijb+1, ije
+  y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO ij = ijb, ije, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if(pole_nord) ijb=ij_begin+iip1
+  if(pole_sud) ije=ij_end-iip1
+
+  DO ij = ijb,ije
+  x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+  END DO
+
+  if (pole_nord) then
+    DO  ij = 1,iip1
+     x(    ij    ,l ) = 0.
+    ENDDO
+  endif
+
+  if (pole_sud) then
+    DO  ij = 1,iip1
+     x( ij +ip1jm,l ) = 0.
+    ENDDO
+  endif
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE nxgrad_gam_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,68 +1,0 @@
-      SUBROUTINE nxgrad_loc (klevel, rot, x, y )
-c
-c     P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel )
-      REAL y(ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      INTEGER :: ijb,ije
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l = 1,klevel
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_sud)  ije=ij_end-iip1
-       
-      DO ij = ijb+1, ije
-      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
-      END DO
-c
-c    ..... correction pour  y ( 1,j,l )  ......
-c
-c    ....    y(1,j,l)= y(iip1,j,l) ....
-CDIR$ IVDEP
-      DO ij = ijb, ije, iip1
-      y( ij,l ) = y( ij +iim,l )
-      END DO
-c
-      ijb=ij_begin
-      ije=ij_end+iip1
-      
-      if (pole_nord)  ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij = ijb,ije
-      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
-      END DO
-   
-      if (pole_nord) then 
-        DO ij = 1,iip1
-          x(    ij    ,l ) = 0.
-        ENDDO
-      endif
-      
-      if (pole_sud) then 
-        DO ij = 1,iip1
-          x( ij +ip1jm,l ) = 0.
-        ENDDO
-      endif
-c
-      END DO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.f90	(revision 5105)
@@ -0,0 +1,68 @@
+SUBROUTINE nxgrad_loc (klevel, rot, x, y )
+  !
+  ! P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel )
+  REAL :: y(ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb+1, ije
+  y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO ij = ijb, ije, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+
+  if (pole_nord)  ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+  x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+  END DO
+
+  if (pole_nord) then
+    DO ij = 1,iip1
+      x(    ij    ,l ) = 0.
+    ENDDO
+  endif
+
+  if (pole_sud) then
+    DO ij = 1,iip1
+      x( ij +ip1jm,l ) = 0.
+    ENDDO
+  endif
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE nxgrad_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,143 +1,0 @@
-       SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
-c
-c      P.Le Van .
-c   ***********************************************************
-c                                 lr
-c      calcul de  ( nxgrad (rot) )   du vect. v  ....
-c
-c       xcov et ycov  etant les compos. covariantes de  v
-c   ***********************************************************
-c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
-c      grx   et  gry     sont des arguments de sortie pour le s-prog
-c
-c
-      USE write_Field_p
-      USE parallel_lmdz
-      USE times
-      USE mod_hallo
-      USE mod_filtreg_p
-      USE nxgraro2_mod
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comdissipn.h"
-c
-c    ......  variables en arguments  .......
-c
-      INTEGER klevel
-      REAL xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
-      REAL  grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
-c
-c    ......   variables locales     ........
-c
-      REAL  signe, nugradrs
-      INTEGER l,ij,iter,lr
-      Type(Request),SAVE :: Request_dissip
-!$OMP THREADPRIVATE(Request_dissip)
-c    ........................................................
-c
-      INTEGER :: ijb,ije,jjb,jje
-      
-c
-c
-      signe    = (-1.)**lr
-      nugradrs = signe * crot
-c
-c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
-c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
- 
-      ijb=ij_begin
-      ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO    l = 1, klevel
-        grx(ijb:ije,l)=xcov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-c$OMP BARRIER
-       CALL Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO    l = 1, klevel
-        gry(ijb:ije,l)=ycov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
- 
-c
-      CALL     rotatf_loc ( klevel, grx, gry, rot )
-c      CALL write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
-
-c$OMP BARRIER
-       CALL Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-      
-      CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
-c       CALL write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
-c
-c    .....   Iteration de l'operateur laplacien_rotgam  .....
-c
-      DO  iter = 1, lr -2
-c$OMP BARRIER
-       CALL Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-	CALL laplacien_rotgam_loc( klevel, rot, rot )
-      ENDDO
-      
-c       CALL write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
-      
-c
-c
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-       
-      CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm,
-     &                klevel, 2,1, .FALSE.,1)
-c$OMP BARRIER
-       CALL Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
-       CALL SendRequest(Request_dissip)
-c$OMP BARRIER
-       CALL WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      CALL nxgrad_loc ( klevel, rot, grx, gry )
-
-c
-      ijb=ij_begin
-      ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO    l = 1, klevel
-        
-         if(pole_sud) ije=ij_end-iip1
-         DO  ij = ijb, ije
-          gry_out( ij,l ) = gry( ij,l ) * nugradrs
-         ENDDO
-        
-         if(pole_sud) ije=ij_end
-         DO  ij = ijb, ije
-          grx_out( ij,l ) = grx( ij,l ) * nugradrs
-         ENDDO
-     
-      ENDDO
-c$OMP END DO NOWAIT
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.f90	(revision 5105)
@@ -0,0 +1,143 @@
+ SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
+  !
+  !  P.Le Van .
+  !   ***********************************************************
+  !                             lr
+  !  calcul de  ( nxgrad (rot) )   du vect. v  ....
+  !
+  !   xcov et ycov  etant les compos. covariantes de  v
+  !   ***********************************************************
+  ! xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+  !  grx   et  gry     sont des arguments de sortie pour le s-prog
+  !
+  !
+  USE write_Field_p
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE mod_filtreg_p
+  USE nxgraro2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comdissipn.h"
+  !
+  !    ......  variables en arguments  .......
+  !
+  INTEGER :: klevel
+  REAL :: xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+  REAL :: grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
+  !
+  !    ......   variables locales     ........
+  !
+  REAL :: signe, nugradrs
+  INTEGER :: l,ij,iter,lr
+  Type(Request),SAVE :: Request_dissip
+!$OMP THREADPRIVATE(Request_dissip)
+  !    ........................................................
+  !
+  INTEGER :: ijb,ije,jjb,jje
+
+  !
+  !
+  signe    = (-1.)**lr
+  nugradrs = signe * crot
+  !
+  !  CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+  !  CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+    grx(ijb:ije,l)=xcov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP BARRIER
+   CALL Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+    gry(ijb:ije,l)=ycov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+  CALL     rotatf_loc ( klevel, grx, gry, rot )
+   ! CALL write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+
+!$OMP BARRIER
+   CALL Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
+    ! CALL write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
+  !
+  !    .....   Iteration de l'operateur laplacien_rotgam  .....
+  !
+  DO  iter = 1, lr -2
+!$OMP BARRIER
+   CALL Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+    CALL laplacien_rotgam_loc( klevel, rot, rot )
+  ENDDO
+
+    ! CALL write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
+
+  !
+  !
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm, &
+        klevel, 2,1, .FALSE.,1)
+!$OMP BARRIER
+   CALL Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
+   CALL SendRequest(Request_dissip)
+!$OMP BARRIER
+   CALL WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL nxgrad_loc ( klevel, rot, grx, gry )
+
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+
+     if(pole_sud) ije=ij_end-iip1
+     DO  ij = ijb, ije
+      gry_out( ij,l ) = gry( ij,l ) * nugradrs
+     ENDDO
+
+     if(pole_sud) ije=ij_end
+     DO  ij = ijb, ije
+      grx_out( ij,l ) = grx( ij,l ) * nugradrs
+     ENDDO
+
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+
+END SUBROUTINE nxgraro2_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/parallel_lmdz.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/parallel_lmdz.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/parallel_lmdz.F90	(revision 5105)
@@ -609,5 +609,5 @@
       ENDIF  ! using_mpi
       
-      RETURN
+
       
     END SUBROUTINE  exchange_Hallo
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/pression_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/pression_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,42 +1,0 @@
-      SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
-      USE parallel_lmdz, ONLY: ij_begin, ij_end, ijb_u, ije_u,
-     &                         pole_nord, pole_sud, omp_chunk
-c
-
-c      Auteurs : P. Le Van , Fr.Hourdin  .
-
-c  ************************************************************************
-c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
-c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
-c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
-c  ************************************************************************
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-c
-      INTEGER,INTENT(IN) :: ngrid ! not used
-      INTEGER l,ij
- 
-      REAL,INTENT(IN) :: ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
-      REAL,INTENT(OUT) :: p( ijb_u:ije_u,llmp1 ) 
-      
-      INTEGER ijb,ije
-
-      
-      ijb=ij_begin-iip1
-      ije=ij_end+2*iip1
-      
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-      DO    l    = 1, llmp1
-        DO  ij   = ijb, ije
-         p(ij,l) = ap(l) + bp(l) * ps(ij)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT   
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/pression_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/pression_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/pression_loc.f90	(revision 5105)
@@ -0,0 +1,42 @@
+SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
+  USE parallel_lmdz, ONLY: ij_begin, ij_end, ijb_u, ije_u, &
+        pole_nord, pole_sud, omp_chunk
+  !
+
+  !  Auteurs : P. Le Van , Fr.Hourdin  .
+
+  !  ************************************************************************
+  ! Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+  ! sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm)
+  ! couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .
+  !  ************************************************************************
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  !
+  INTEGER,INTENT(IN) :: ngrid ! not used
+  INTEGER :: l,ij
+
+  REAL,INTENT(IN) :: ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
+  REAL,INTENT(OUT) :: p( ijb_u:ije_u,llmp1 )
+
+  INTEGER :: ijb,ije
+
+
+  ijb=ij_begin-iip1
+  ije=ij_end+2*iip1
+
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l    = 1, llmp1
+    DO  ij   = ijb, ije
+     p(ij,l) = ap(l) + bp(l) * ps(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE pression_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/qminimum_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/qminimum_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,293 +1,0 @@
-
-!     $Id$
-
-      SUBROUTINE qminimum_loc( q,nqtot,deltap )
-      USE parallel_lmdz
-      USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, 
-     &                    isoCheck, min_qParent
-      USE strings_mod, ONLY: strIdx
-      USE readTracFiles_mod, ONLY: addPhase
-      IMPLICIT none
-c
-c  -- Objet : Traiter les valeurs trop petites (meme negatives)
-c             pour l'eau vapeur et l'eau liquide
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "iniprint.h"
-c
-      INTEGER nqtot ! CRisi: on remplace nq par nqtot
-      REAL q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
-c
-      LOGICAL, SAVE :: first=.TRUE.
-      INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
-c$OMP THREADPRIVATE(iq_vap, iq_liq, first)
-      REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
-      REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
-c
-c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
-c            parametres seuil_vap, seuil_liq soient pareilles a celles 
-c            qui  sont utilisees dans la routine    ADDFI       )
-c     .................................................................
-c
-cDC iq_val and iq_liq are usable for q only, NOT for q_follow
-c   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
-c   water at hardcoded indices 1/2 in these variables
-      INTEGER i, k, iq
-      REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
-
-      real zx_defau_diag(ijb_u:ije_u,llm,2) 
-      real q_follow(ijb_u:ije_u,llm,2) 
-c
-      REAL SSUM
-      EXTERNAL SSUM
-c
-      INTEGER imprim
-      SAVE imprim
-      DATA imprim /0/
-c$OMP THREADPRIVATE(imprim)
-      INTEGER ijb,ije
-      INTEGER Index_pump(ij_end-ij_begin+1)
-      INTEGER nb_pump
-      INTEGER ixt
-      INTEGER iso_verif_noNaN_nostop
-
-c$OMP BARRIER
-
-      !write(lunout,*) 'qminimum 52: entree'
-      IF(first) THEN
-         iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
-         iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
-         first = .FALSE.
-      END IF
-c
-c Quand l'eau liquide est trop petite (ou negative), on prend
-c l'eau vapeur de la meme couche et la convertit en eau liquide
-c (sans changer la temperature !)
-c
-
-      CALL check_isotopes(q,ij_begin,ij_end,'qminimum 52')
-
-      ijb=ij_begin
-      ije=ij_end
-
-      DO k = 1, llm
-c$OMP DO SCHEDULE(STATIC)
-        DO i = ijb, ije
-          zx_defau_diag(i,k,1)=0.0
-          zx_defau_diag(i,k,2)=0.0
-          q_follow(i,k,1)=q(i,k,iq_vap)
-          q_follow(i,k,2)=q(i,k,iq_liq)
-        ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-      !write(lunout,*) 'qminimum 57'
-      DO k = 1, llm
-c$OMP DO SCHEDULE(STATIC)       
-        DO i = ijb, ije
-          if (seuil_liq - q(i,k,iq_liq) > 0.d0 ) then
-
-            if (niso > 0) zx_defau_diag(i,k,2)=AMAX1
-     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
-
-            q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
-            q(i,k,iq_liq) = seuil_liq
-          endif
-        END DO
-c$OMP END DO NOWAIT
-      END DO
-
-c
-c Quand l'eau vapeur est trop faible (ou negative), on complete
-c le defaut en prennant de l'eau vapeur de la couche au-dessous.
-c
-      !write(lunout,*) 'qminimum 81'
-      DO k = llm, 2, -1
-ccc      zx_abc = dpres(k) / dpres(k-1)
-c$OMP DO SCHEDULE(STATIC)
-        DO i = ijb, ije
-
-          if ( seuil_vap - q(i,k,iq_vap) > 0.d0 ) then
-
-            if (niso > 0) zx_defau_diag(i,k,1)
-     &           = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
-
-            q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap
-     &           -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
-            q(i,k,iq_vap)   =  seuil_vap  
-
-          endif
-        ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-c
-c Quand il s'agit de la premiere couche au-dessus du sol, on
-c doit imprimer un message d'avertissement (saturation possible).
-c
-      !write(lunout,*) 'qminimum 106'
-      nb_pump=0
-c$OMP DO SCHEDULE(STATIC)
-      DO i = ijb, ije
-         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
-         q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
-         IF (zx_pump(i) > 0.0) THEN
-            nb_pump = nb_pump+1
-            Index_pump(nb_pump)=i
-         ENDIF
-      ENDDO
-c$OMP END DO NOWAIT 
-!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
-
-      IF (imprim<=100 .AND. nb_pump > 0 ) THEN
-         PRINT *, 'ATT!:on pompe de l eau au sol'
-         DO i = 1, nb_pump
-               imprim = imprim + 1
-               PRINT*,'  en ',index_pump(i),zx_pump(index_pump(i))
-         ENDDO
-      ENDIF
-
-      !write(lunout,*) 'qminimum 128'
-      if (niso > 0) then
-              !write(lunout,*) 'qminimum 140'
-      ! CRisi: traiter de même les traceurs d'eau
-      ! Mais il faut les prendre à l'envers pour essayer de conserver la
-      ! masse.
-      ! 1) pompage dans le sol  
-      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
-      ! rien ici et on croise les doigts pour que ça ne soit pas trop
-      ! génant
-      ! en fait, si, c'est genant quand les isotopes doivent eux même transporter des
-      ! traceurs -> apporter aussi un peu d'isotopes... Combien?
-      ! Essayer tnat/2 = -500 permil? C'est déjà mieux que -1000
-      ! permil...
-      ! pb: que faire pour les traceurs?
-c$OMP DO SCHEDULE(STATIC)      
-      DO i = ijb, ije
-        if (zx_pump(i)>0.0) then
-          q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
-        endif !if (zx_pump(i).gt.0.0) then
-      enddo !DO i = ijb, ije  
-c$OMP END DO NOWAIT
-
-      ! 2) transfert de vap vers les couches plus hautes
-      !write(lunout,*) 'qminimum 158'
-      do k=2,llm
-c$OMP DO SCHEDULE(STATIC)      
-        DO i = ijb, ije
-          if (zx_defau_diag(i,k,1)>0.0) then
-              ! on ajoute la vapeur en k     
-!              write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
-!     :                 i,k,q_follow(i,k-1,1)          
-              if (q_follow(i,k-1,1)<min_qParent) then
-                write(lunout,*) 'tmp qmin: on stoppe'
-                write(lunout,*) 'zx_pump(i)=',zx_pump(i)
-                write(lunout,*) 'q_follow(i,:,ivap)=',
-     :                   q_follow(i,:,1)
-                write(lunout,*) 'k=',k
-                CALL abort_gcm("qminimum","not enough vapor",1)
-              endif  
-            do ixt=1,ntiso
-!                write(lunout,*) 'qmin 168: ixt=',ixt
-!                write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
-!     :             q(i,k,iqIsoPha(ixt,iq_vap))
-!                write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
-!     :                  zx_defau_diag(i,k,1)
-!                write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
-!     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))     
-
-               q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :           +zx_defau_diag(i,k,1)
-     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
-                
-              if (isoCheck) then
-                if(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)),
-     :                   'qminimum 155')==1) then
-                   write(*,*) 'i,k,ixt=',i,k,ixt
-                   write(*,*) 'q_follow(i,k-1,ivap)=',
-     :                   q_follow(i,k-1,1)
-                   write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k,iqIsoPha(ixt,iq_vap))
-                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
-     :                   zx_defau_diag(i,k,1)
-                   write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
-                CALL abort_gcm("qminimum_loc","stopped",1)
-                endif
-              endif
-
-              ! et on la retranche en k-1
-               q(i,k-1,iqIsoPha(ixt,iq_vap)) =
-     :            q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,1)
-     :              *deltap(i,k)/deltap(i,k-1)
-     :              *q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              /q_follow(i,k-1,1)
-
-               if (isoCheck) then
-                if (iso_verif_noNaN_nostop(
-     :              q(i,k-1,iqIsoPha(ixt,iq_vap)),
-     :                   'qminimum 175')==1) then
-                   write(*,*) 'k,i,ixt=',k,i,ixt
-                   write(*,*) 'q_follow(i,k-1,ivap)=',
-     :                   q_follow(i,k-1,1)
-                   write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k,iqIsoPha(ixt,iq_vap))
-                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
-     :                   zx_defau_diag(i,k,1)
-                   write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
-                   CALL abort_gcm("qminimum_loc","stopped",1)
-                endif
-              endif 
-
-              enddo !do ixt=1,niso
-              q_follow(i,k,1)=   q_follow(i,k,1)
-     :               +zx_defau_diag(i,k,1)
-              q_follow(i,k-1,1)=   q_follow(i,k-1,1)
-     :               -zx_defau_diag(i,k,1)
-     :              *deltap(i,k)/deltap(i,k-1)
-          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
-        enddo !DO i = 1, ip1jmp1        
-c$OMP END DO NOWAIT
-        enddo !do k=2,llm
-
-        CALL check_isotopes(q,ijb,ije,'qminimum 168')
-        
-      
-        ! 3) transfert d'eau de la vapeur au liquide
-        !write(*,*) 'qminimum 164'
-        do k=1,llm
-c$OMP DO SCHEDULE(STATIC)
-        DO i = ijb, ije
-          if (zx_defau_diag(i,k,2)>0.0) then
-
-              ! on ajoute eau liquide en k en k              
-              do ixt=1,ntiso
-               q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq))
-     :              +zx_defau_diag(i,k,2)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
-              ! et on la retranche à la vapeur en k
-               q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,2)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)   
-              enddo !do ixt=1,niso
-              q_follow(i,k,2)=   q_follow(i,k,2)
-     :               +zx_defau_diag(i,k,2)
-              q_follow(i,k,1)=   q_follow(i,k,1)
-     :               -zx_defau_diag(i,k,2)
-          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
-        enddo !DO i = ijb, ije
-c$OMP END DO NOWAIT       
-       enddo !do k=2,llm  
-
-       CALL check_isotopes(q,ijb,ije,'qminimum 197')
-
-      endif !if (niso > 0) then
-      !write(*,*) 'qminimum 188'
-c$OMP BARRIER
-
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/qminimum_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/qminimum_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/qminimum_loc.f90	(revision 5105)
@@ -0,0 +1,293 @@
+
+! $Id$
+
+SUBROUTINE qminimum_loc( q,nqtot,deltap )
+  USE parallel_lmdz
+  USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, &
+        isoCheck, min_qParent
+  USE strings_mod, ONLY: strIdx
+  USE readTracFiles_mod, ONLY: addPhase
+  IMPLICIT none
+  !
+  !  -- Objet : Traiter les valeurs trop petites (meme negatives)
+  !         pour l'eau vapeur et l'eau liquide
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  INTEGER :: nqtot ! CRisi: on remplace nq par nqtot
+  REAL :: q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
+  !
+  LOGICAL, SAVE :: first=.TRUE.
+  INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
+!$OMP THREADPRIVATE(iq_vap, iq_liq, first)
+  REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
+  REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
+  !
+  !  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+  !        parametres seuil_vap, seuil_liq soient pareilles a celles
+  !        qui  sont utilisees dans la routine    ADDFI       )
+  ! .................................................................
+  !
+  !DC iq_val and iq_liq are usable for q only, NOT for q_follow
+  !   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
+  !   water at hardcoded indices 1/2 in these variables
+  INTEGER :: i, k, iq
+  REAL :: zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
+
+  real :: zx_defau_diag(ijb_u:ije_u,llm,2)
+  real :: q_follow(ijb_u:ije_u,llm,2)
+  !
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  INTEGER :: imprim
+  SAVE imprim
+  DATA imprim /0/
+!$OMP THREADPRIVATE(imprim)
+  INTEGER :: ijb,ije
+  INTEGER :: Index_pump(ij_end-ij_begin+1)
+  INTEGER :: nb_pump
+  INTEGER :: ixt
+  INTEGER :: iso_verif_noNaN_nostop
+
+!$OMP BARRIER
+
+  ! !write(lunout,*) 'qminimum 52: entree'
+  IF(first) THEN
+     iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
+     iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
+     first = .FALSE.
+  END IF
+  !
+  ! Quand l'eau liquide est trop petite (ou negative), on prend
+  ! l'eau vapeur de la meme couche et la convertit en eau liquide
+  ! (sans changer la temperature !)
+  !
+
+  CALL check_isotopes(q,ij_begin,ij_end,'qminimum 52')
+
+  ijb=ij_begin
+  ije=ij_end
+
+  DO k = 1, llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      zx_defau_diag(i,k,1)=0.0
+      zx_defau_diag(i,k,2)=0.0
+      q_follow(i,k,1)=q(i,k,iq_vap)
+      q_follow(i,k,2)=q(i,k,iq_liq)
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  ! !write(lunout,*) 'qminimum 57'
+  DO k = 1, llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (seuil_liq - q(i,k,iq_liq) > 0.d0 ) then
+
+        if (niso > 0) zx_defau_diag(i,k,2)=AMAX1 &
+              ( seuil_liq - q(i,k,iq_liq), 0.0 )
+
+        q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+        q(i,k,iq_liq) = seuil_liq
+      endif
+    END DO
+!$OMP END DO NOWAIT
+  END DO
+
+  !
+  ! Quand l'eau vapeur est trop faible (ou negative), on complete
+  ! le defaut en prennant de l'eau vapeur de la couche au-dessous.
+  !
+  ! !write(lunout,*) 'qminimum 81'
+  DO k = llm, 2, -1
+  !cc      zx_abc = dpres(k) / dpres(k-1)
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+
+      if ( seuil_vap - q(i,k,iq_vap) > 0.d0 ) then
+
+        if (niso > 0) zx_defau_diag(i,k,1) &
+              = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
+
+        q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap &
+              -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
+        q(i,k,iq_vap)   =  seuil_vap
+
+      endif
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  !
+  ! Quand il s'agit de la premiere couche au-dessus du sol, on
+  ! doit imprimer un message d'avertissement (saturation possible).
+  !
+  ! !write(lunout,*) 'qminimum 106'
+  nb_pump=0
+!$OMP DO SCHEDULE(STATIC)
+  DO i = ijb, ije
+     zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
+     q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
+     IF (zx_pump(i) > 0.0) THEN
+        nb_pump = nb_pump+1
+        Index_pump(nb_pump)=i
+     ENDIF
+  ENDDO
+!$OMP END DO NOWAIT
+   ! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+
+  IF (imprim<=100 .AND. nb_pump > 0 ) THEN
+     PRINT *, 'ATT!:on pompe de l eau au sol'
+     DO i = 1, nb_pump
+           imprim = imprim + 1
+           PRINT*,'  en ',index_pump(i),zx_pump(index_pump(i))
+     ENDDO
+  ENDIF
+
+  ! !write(lunout,*) 'qminimum 128'
+  if (niso > 0) then
+          ! !write(lunout,*) 'qminimum 140'
+  ! ! CRisi: traiter de même les traceurs d'eau
+  ! ! Mais il faut les prendre à l'envers pour essayer de conserver la
+  ! ! masse.
+  ! ! 1) pompage dans le sol
+  ! ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
+  ! ! rien ici et on croise les doigts pour que ça ne soit pas trop
+  ! ! génant
+  ! ! en fait, si, c'est genant quand les isotopes doivent eux même transporter des
+  ! ! traceurs -> apporter aussi un peu d'isotopes... Combien?
+  ! ! Essayer tnat/2 = -500 permil? C'est déjà mieux que -1000
+  ! ! permil...
+  ! ! pb: que faire pour les traceurs?
+!$OMP DO SCHEDULE(STATIC)
+  DO i = ijb, ije
+    if (zx_pump(i)>0.0) then
+      q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
+    endif !if (zx_pump(i).gt.0.0) then
+  enddo !DO i = ijb, ije
+!$OMP END DO NOWAIT
+
+  ! ! 2) transfert de vap vers les couches plus hautes
+  ! !write(lunout,*) 'qminimum 158'
+  do k=2,llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (zx_defau_diag(i,k,1)>0.0) then
+          ! ! on ajoute la vapeur en k
+          !  write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
+  ! :                 i,k,q_follow(i,k-1,1)
+          if (q_follow(i,k-1,1)<min_qParent) then
+            write(lunout,*) 'tmp qmin: on stoppe'
+            write(lunout,*) 'zx_pump(i)=',zx_pump(i)
+            write(lunout,*) 'q_follow(i,:,ivap)=', &
+                  q_follow(i,:,1)
+            write(lunout,*) 'k=',k
+            CALL abort_gcm("qminimum","not enough vapor",1)
+          endif
+        do ixt=1,ntiso
+             ! write(lunout,*) 'qmin 168: ixt=',ixt
+             ! write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
+  ! :             q(i,k,iqIsoPha(ixt,iq_vap))
+  !            write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
+  ! :                  zx_defau_diag(i,k,1)
+  !            write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
+  ! :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
+
+           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
+                 +zx_defau_diag(i,k,1) &
+                 *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
+
+          if (isoCheck) then
+            if(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)), &
+                  'qminimum 155')==1) then
+               write(*,*) 'i,k,ixt=',i,k,ixt
+               write(*,*) 'q_follow(i,k-1,ivap)=', &
+                     q_follow(i,k-1,1)
+               write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k,iqIsoPha(ixt,iq_vap))
+               write(*,*) 'zx_defau_diag(i,k,ivap)=', &
+                     zx_defau_diag(i,k,1)
+               write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k-1,iqIsoPha(ixt,iq_vap))
+            CALL abort_gcm("qminimum_loc","stopped",1)
+            endif
+          endif
+
+          ! ! et on la retranche en k-1
+           q(i,k-1,iqIsoPha(ixt,iq_vap)) = &
+                 q(i,k-1,iqIsoPha(ixt,iq_vap)) &
+                 -zx_defau_diag(i,k,1) &
+                 *deltap(i,k)/deltap(i,k-1) &
+                 *q(i,k-1,iqIsoPha(ixt,iq_vap)) &
+                 /q_follow(i,k-1,1)
+
+           if (isoCheck) then
+            if (iso_verif_noNaN_nostop( &
+                  q(i,k-1,iqIsoPha(ixt,iq_vap)), &
+                  'qminimum 175')==1) then
+               write(*,*) 'k,i,ixt=',k,i,ixt
+               write(*,*) 'q_follow(i,k-1,ivap)=', &
+                     q_follow(i,k-1,1)
+               write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k,iqIsoPha(ixt,iq_vap))
+               write(*,*) 'zx_defau_diag(i,k,ivap)=', &
+                     zx_defau_diag(i,k,1)
+               write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k-1,iqIsoPha(ixt,iq_vap))
+               CALL abort_gcm("qminimum_loc","stopped",1)
+            endif
+          endif
+
+          enddo !do ixt=1,niso
+          q_follow(i,k,1)=   q_follow(i,k,1) &
+                +zx_defau_diag(i,k,1)
+          q_follow(i,k-1,1)=   q_follow(i,k-1,1) &
+                -zx_defau_diag(i,k,1) &
+                *deltap(i,k)/deltap(i,k-1)
+      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+    enddo !DO i = 1, ip1jmp1
+!$OMP END DO NOWAIT
+    enddo !do k=2,llm
+
+    CALL check_isotopes(q,ijb,ije,'qminimum 168')
+
+
+    ! ! 3) transfert d'eau de la vapeur au liquide
+    ! !write(*,*) 'qminimum 164'
+    do k=1,llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (zx_defau_diag(i,k,2)>0.0) then
+
+          ! ! on ajoute eau liquide en k en k
+          do ixt=1,ntiso
+           q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq)) &
+                 +zx_defau_diag(i,k,2) &
+                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+          ! ! et on la retranche à la vapeur en k
+           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
+                 -zx_defau_diag(i,k,2) &
+                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+          enddo !do ixt=1,niso
+          q_follow(i,k,2)=   q_follow(i,k,2) &
+                +zx_defau_diag(i,k,2)
+          q_follow(i,k,1)=   q_follow(i,k,1) &
+                -zx_defau_diag(i,k,2)
+      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+    enddo !DO i = ijb, ije
+!$OMP END DO NOWAIT
+   enddo !do k=2,llm
+
+   CALL check_isotopes(q,ijb,ije,'qminimum 197')
+
+  endif !if (niso > 0) then
+  ! !write(*,*) 'qminimum 188'
+!$OMP BARRIER
+
+  !
+
+END SUBROUTINE qminimum_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,52 +1,0 @@
-      SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
-c
-c    Auteur :   P.Le Van 
-c**************************************************************
-c.          Calcule le rotationnel  non filtre   ,
-c      a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel )
-      REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-      INTEGER :: ijb,ije
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO  l = 1,klevel
-c
-        DO   ij = ijb, ije - 1
-         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
-     *                   x(ij +iip1, l )  -  x( ij,l )  
-        ENDDO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-        DO  ij = ijb+iip1-1, ije, iip1
-         rot( ij,l ) = rot( ij -iim,l )
-        ENDDO
-c
-      END DO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.f90	(revision 5105)
@@ -0,0 +1,52 @@
+SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
+  !
+  !    Auteur :   P.Le Van
+  !**************************************************************
+  !.          Calcule le rotationnel  non filtre   ,
+  !  a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE rotat_nfil_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.F	(revision 5104)
+++ 	(revision )
@@ -1,63 +1,0 @@
-      SUBROUTINE rotat_p (klevel, x, y, rot )
-c
-c     Auteur : P.Le Van 
-c**************************************************************
-c.  calcule le rotationnel
-c     a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ip1jm,klevel )
-      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-      INTEGER :: ijb,ije
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO  l = 1,klevel
-c
-        DO   ij = ijb, ije - 1
-         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
-     *                   x(ij +iip1, l )  -  x( ij,l )  
-        ENDDO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-        DO  ij = ijb+iip1-1, ije, iip1
-         rot( ij,l ) = rot( ij -iim,l )
-        ENDDO
-c
-      END DO
-c$OMP END DO NOWAIT
-ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO l = 1, klevel
-          DO ij = ijb, ije
-           rot(ij,l) = rot(ij,l) * unsairez(ij)
-          ENDDO
-        ENDDO
-c$OMP END DO NOWAIT
-c
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.f90	(revision 5105)
@@ -0,0 +1,63 @@
+SUBROUTINE rotat_p (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  !cc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+      DO ij = ijb, ije
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+  !
+
+END SUBROUTINE rotat_p
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,69 +1,0 @@
-      SUBROUTINE rotatf_loc (klevel, x, y, rot )
-c
-c     Auteur : P.Le Van 
-c**************************************************************
-c.  calcule le rotationnel
-c     a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel )
-      REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO  l = 1,klevel
-c
-        DO   ij = ijb, ije - 1
-         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
-     *                   x(ij +iip1, l )  -  x( ij,l )  
-        ENDDO
-c
-c    .... correction pour rot( iip1,j,l)  ....
-c    ....   rot(iip1,j,l)= rot(1,j,l) ...
-CDIR$ IVDEP
-        DO  ij = ijb+iip1-1, ije, iip1
-         rot( ij,l ) = rot( ij -iim,l )
-        ENDDO
-c
-      END DO
-c$OMP END DO NOWAIT
-        jjb=jj_begin
-        jje=jj_end
-        if (pole_sud) jje=jj_end-1
-        CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm,
-     &                  klevel, 2, 2, .FALSE., 1 )
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l = 1, klevel
-          DO ij = ijb, ije
-           rot(ij,l) = rot(ij,l) * unsairez(ij)
-          ENDDO
-        ENDDO
-c$OMP END DO NOWAIT
-c
-c
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.f90	(revision 5105)
@@ -0,0 +1,69 @@
+SUBROUTINE rotatf_loc (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+    CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm, &
+          klevel, 2, 2, .FALSE., 1 )
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+      DO ij = ijb, ije
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+  !
+
+END SUBROUTINE rotatf_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/sw_case_williamson91_6_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/sw_case_williamson91_6_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,189 +1,0 @@
-
-! $Id $
-
-      SUBROUTINE sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
-
-c=======================================================================
-c
-c   Author:    Thomas Dubos      original: 26/01/2010
-c   -------
-c
-c   Subject:
-c   ------
-c   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      USE parallel_lmdz
-      USE comconst_mod, ONLY: cpp, omeg, rad
-      USE comvert_mod, ONLY: ap, bp, preff
-
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-c   variables dynamiques
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) ! vents covariants
-      REAL teta(ijb_u:ije_u,llm)                 ! temperature potentielle
-      REAL ps(ijb_u:ije_u)                       ! pression  au sol
-      REAL masse(ijb_u:ije_u,llm)                ! masse d'air
-      REAL phis(ijb_u:ije_u)                     ! geopotentiel au sol
-
-c   Local:
-c   ------
-
-      real,allocatable :: ucov_glo(:,:)
-      real,allocatable :: vcov_glo(:,:)
-      real,allocatable :: teta_glo(:,:)
-      real,allocatable :: masse_glo(:,:)
-      real,allocatable :: ps_glo(:)
-
-!      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
-!      REAL pks(ip1jmp1)                      ! exner au  sol
-!      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
-!      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
-!      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
-
-      real,allocatable :: p(:,:)
-      real,allocatable :: pks(:)
-      real,allocatable :: pk(:,:)
-      real,allocatable :: pkf(:,:)
-      real,allocatable :: alpha(:,:),beta(:,:)
-
-      REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
-      INTEGER i,j,ij
-
-      REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
-      REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
-      REAL, PARAMETER    :: gh0  = 9.80616 * 8e3 
-      INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
-c NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
-c      omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
-
-
-       ! allocate (global) arrays
-       allocate(vcov_glo(ip1jm,llm))
-       allocate(ucov_glo(ip1jmp1,llm))
-       allocate(teta_glo(ip1jmp1,llm))
-       allocate(ps_glo(ip1jmp1))
-       allocate(masse_glo(ip1jmp1,llm))
-
-       allocate(p(ip1jmp1,llmp1))
-       allocate(pks(ip1jmp1))
-       allocate(pk(ip1jmp1,llm))
-       allocate(pkf(ip1jmp1,llm))
-       allocate(alpha(ip1jmp1,llm))
-       allocate(beta(ip1jmp1,llm))
- 
-      IF(0==0) THEN
-!c Williamson et al. (1991) : onde de Rossby-Haurwitz
-         teta_glo(:,:) = preff/rho/cpp
-!c geopotentiel (pression de surface)
-         do j=1,jjp1
-            costh2 = cos(rlatu(j))**2
-            Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
-            Ath = .25*(K**2)*(costh2**(R0-1))*Ath
-            Ath = .5*K*(2*omeg+K)*costh2 + Ath 
-            Bth = (R1*R1+1)-R1*R1*costh2
-            Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
-            Cth = R1*costh2 - R2
-            Cth = .25*K*K*(costh2**R0)*Cth
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               lon = rlonv(i)
-               dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
-               ps_glo(ij) = rho*(gh0 + (rad**2)*dps)
-            enddo
-         enddo
-!         write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
-c vitesse zonale ucov
-         do j=1,jjp1
-            costh  = cos(rlatu(j))
-            costh2 = costh**2
-            Ath = rad*K*costh
-            Bth = R0*(1-costh2)-costh2
-            Bth = rad*K*Bth*(costh**(R0-1))
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               lon = rlonu(i)
-               ucov_glo(ij,1) = (Ath + Bth*cos(R0*lon))
-            enddo
-         enddo
-!         write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
-         ucov_glo(:,1)=ucov_glo(:,1)*cu
-c vitesse meridienne vcov
-         do j=1,jjm
-            sinth  = sin(rlatv(j))
-            costh  = cos(rlatv(j))
-            Ath = -rad*K*R0*sinth*(costh**(R0-1))
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               lon = rlonv(i)
-               vcov_glo(ij,1) = Ath*sin(R0*lon)
-            enddo
-         enddo
-         write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
-         vcov_glo(:,1)=vcov_glo(:,1)*cv
-        
-c         ucov_glo=0
-c         vcov_glo=0
-      ELSE
-c test non-tournant, onde se propageant en latitude
-         do j=1,jjp1
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               ps_glo(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2))
-            enddo
-         enddo
-         
-c     rho = preff/(cpp*teta)
-         teta_glo(:,:) = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
-         ucov_glo(:,:)=0.
-         vcov_glo(:,:)=0.
-      END IF      
-      
-      CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
-      CALL massdair(p,masse_glo)
-
-      ! copy data from global array to local array:
-      teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
-      ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
-      vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
-      masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
-      ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
-
-      ! cleanup
-      deallocate(teta_glo)
-      deallocate(ucov_glo)
-      deallocate(vcov_glo)
-      deallocate(masse_glo)
-      deallocate(ps_glo)
-      deallocate(p)
-      deallocate(pks)
-      deallocate(pk)
-      deallocate(pkf)
-      deallocate(alpha)
-      deallocate(beta)
-
-      END
-c-----------------------------------------------------------------------
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/sw_case_williamson91_6_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/sw_case_williamson91_6_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/sw_case_williamson91_6_loc.f90	(revision 5105)
@@ -0,0 +1,189 @@
+
+! $Id $
+
+SUBROUTINE sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
+
+  !=======================================================================
+  !
+  !   Author:    Thomas Dubos      original: 26/01/2010
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: cpp, omeg, rad
+  USE comvert_mod, ONLY: ap, bp, preff
+
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  !   variables dynamiques
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) ! vents covariants
+  REAL :: teta(ijb_u:ije_u,llm)                 ! temperature potentielle
+  REAL :: ps(ijb_u:ije_u)                       ! pression  au sol
+  REAL :: masse(ijb_u:ije_u,llm)                ! masse d'air
+  REAL :: phis(ijb_u:ije_u)                     ! geopotentiel au sol
+
+  !   Local:
+  !   ------
+
+  real,allocatable :: ucov_glo(:,:)
+  real,allocatable :: vcov_glo(:,:)
+  real,allocatable :: teta_glo(:,:)
+  real,allocatable :: masse_glo(:,:)
+  real,allocatable :: ps_glo(:)
+
+   ! REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+   ! REAL pks(ip1jmp1)                      ! exner au  sol
+   ! REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+   ! REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+   ! REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+
+  real,allocatable :: p(:,:)
+  real,allocatable :: pks(:)
+  real,allocatable :: pk(:,:)
+  real,allocatable :: pkf(:,:)
+  real,allocatable :: alpha(:,:),beta(:,:)
+
+  REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
+  INTEGER :: i,j,ij
+
+  REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
+  REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
+  REAL, PARAMETER    :: gh0  = 9.80616 * 8e3
+  INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
+  ! NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
+   ! omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
+
+
+   ! ! allocate (global) arrays
+   allocate(vcov_glo(ip1jm,llm))
+   allocate(ucov_glo(ip1jmp1,llm))
+   allocate(teta_glo(ip1jmp1,llm))
+   allocate(ps_glo(ip1jmp1))
+   allocate(masse_glo(ip1jmp1,llm))
+
+   allocate(p(ip1jmp1,llmp1))
+   allocate(pks(ip1jmp1))
+   allocate(pk(ip1jmp1,llm))
+   allocate(pkf(ip1jmp1,llm))
+   allocate(alpha(ip1jmp1,llm))
+   allocate(beta(ip1jmp1,llm))
+
+  IF(0==0) THEN
+  !c Williamson et al. (1991) : onde de Rossby-Haurwitz
+     teta_glo(:,:) = preff/rho/cpp
+  !c geopotentiel (pression de surface)
+     do j=1,jjp1
+        costh2 = cos(rlatu(j))**2
+        Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
+        Ath = .25*(K**2)*(costh2**(R0-1))*Ath
+        Ath = .5*K*(2*omeg+K)*costh2 + Ath
+        Bth = (R1*R1+1)-R1*R1*costh2
+        Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
+        Cth = R1*costh2 - R2
+        Cth = .25*K*K*(costh2**R0)*Cth
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonv(i)
+           dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
+           ps_glo(ij) = rho*(gh0 + (rad**2)*dps)
+        enddo
+     enddo
+      ! write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
+  ! vitesse zonale ucov
+     do j=1,jjp1
+        costh  = cos(rlatu(j))
+        costh2 = costh**2
+        Ath = rad*K*costh
+        Bth = R0*(1-costh2)-costh2
+        Bth = rad*K*Bth*(costh**(R0-1))
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonu(i)
+           ucov_glo(ij,1) = (Ath + Bth*cos(R0*lon))
+        enddo
+     enddo
+      ! write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
+     ucov_glo(:,1)=ucov_glo(:,1)*cu
+  ! vitesse meridienne vcov
+     do j=1,jjm
+        sinth  = sin(rlatv(j))
+        costh  = cos(rlatv(j))
+        Ath = -rad*K*R0*sinth*(costh**(R0-1))
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonv(i)
+           vcov_glo(ij,1) = Ath*sin(R0*lon)
+        enddo
+     enddo
+     write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
+     vcov_glo(:,1)=vcov_glo(:,1)*cv
+
+      ! ucov_glo=0
+      ! vcov_glo=0
+  ELSE
+  ! test non-tournant, onde se propageant en latitude
+     do j=1,jjp1
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           ps_glo(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2))
+        enddo
+     enddo
+
+  ! rho = preff/(cpp*teta)
+     teta_glo(:,:) = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
+     ucov_glo(:,:)=0.
+     vcov_glo(:,:)=0.
+  END IF
+
+  CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
+  CALL massdair(p,masse_glo)
+
+  ! ! copy data from global array to local array:
+  teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
+  ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
+  vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
+  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
+  ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
+
+  ! ! cleanup
+  deallocate(teta_glo)
+  deallocate(ucov_glo)
+  deallocate(vcov_glo)
+  deallocate(masse_glo)
+  deallocate(ps_glo)
+  deallocate(p)
+  deallocate(pks)
+  deallocate(pk)
+  deallocate(pkf)
+  deallocate(alpha)
+  deallocate(beta)
+
+END SUBROUTINE sw_case_williamson91_6_loc
+!-----------------------------------------------------------------------
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/top_bound_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/top_bound_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,256 +1,0 @@
-
-! $Id: $
-
-      SUBROUTINE top_bound_loc(vcov,ucov,teta,masse,dt)
-      USE parallel_lmdz
-      USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound,
-     &                        tau_top_bound
-      USE comvert_mod, ONLY: presnivs, preff, scaleheight
-
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-
-c ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
-C     F. LOTT DEC. 2006
-c                                 (  10/12/06  )
-
-c=======================================================================
-c
-c   Auteur:  F. LOTT  
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   Dissipation linéaire (ex top_bound de la physique)
-c
-c=======================================================================
-
-! top_bound sponge layer model:
-! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
-! where Am is the zonal average of the field (or zero), and lambda the inverse
-! of the characteristic quenching/relaxation time scale
-! Thus, assuming Am to be time-independent, field at time t+dt is given by:
-! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
-! Moreover lambda can be a function of model level (see below), and relaxation
-! can be toward the average zonal field or just zero (see below).
-
-! NB: top_bound sponge is only called from leapfrog if ok_strato=.TRUE.
-
-! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
-!    iflag_top_bound=0 for no sponge
-!    iflag_top_bound=1 for sponge over 4 topmost layers
-!    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
-!    mode_top_bound=0: no relaxation
-!    mode_top_bound=1: u and v relax towards 0
-!    mode_top_bound=2: u and v relax towards their zonal mean
-!    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
-!    tau_top_bound : inverse of charactericstic relaxation time scale at
-!                       the topmost layer (Hz)
-
-
-      INCLUDE "comdissipn.h"
-      INCLUDE "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-      real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
-      real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
-      real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
-      real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere 
-      real,intent(in) :: dt ! time step (s) of sponge model
-
-!      REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
-!      REAL dh(iip1,jjb_u:jje_u,llm)
-
-c   Local:
-c   ------
-      REAL massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm)
-      REAL zm
-      REAL uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm)
-      REAL tzon(jjb_u:jje_u,llm)
-      
-      integer i
-      REAL,SAVE :: rdamp(llm)
-      real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
-      LOGICAL,SAVE :: first=.TRUE.
-      INTEGER j,l,jjb,jje
-
-
-      if (iflag_top_bound == 0) return
-
-      if (first) then
-c$OMP BARRIER
-c$OMP MASTER
-         if (iflag_top_bound == 1) then
-! sponge quenching over the topmost 4 atmospheric layers
-             lambda(:)=0.
-             lambda(llm)=tau_top_bound
-             lambda(llm-1)=tau_top_bound/2.
-             lambda(llm-2)=tau_top_bound/4.
-             lambda(llm-3)=tau_top_bound/8.
-         else if (iflag_top_bound == 2) then
-! sponge quenching over topmost layers down to pressures which are
-! higher than 100 times the topmost layer pressure
-             lambda(:)=tau_top_bound
-     s       *max(presnivs(llm)/presnivs(:)-0.01,0.)
-         endif
-
-! quenching coefficient rdamp(:)
-!         rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
-         rdamp(:)=1.-exp(-lambda(:)*dt)
-
-         write(lunout,*)'TOP_BOUND mode',mode_top_bound
-         write(lunout,*)'Sponge layer coefficients'
-         write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
-         do l=1,llm
-           if (rdamp(l)/=0.) then
-             write(lunout,'(6(1pe12.4,1x))')
-     &        presnivs(l),log(preff/presnivs(l))*scaleheight,
-     &           1./lambda(l),lambda(l)
-           endif
-         enddo
-         first=.FALSE.
-c$OMP END MASTER
-c$OMP BARRIER
-      endif ! of if (first)
-
-
-      CALL massbar_loc(masse,massebx,masseby)
-
-      ! compute zonal average of vcov (or set it to zero)
-      if (mode_top_bound>=2) then
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_sud) jje=jj_end-1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          zm=0.
-          vzon(j,l)=0
-          do i=1,iim
-! NB: we can work using vcov zonal mean rather than v since the
-! cv coefficient (which relates the two) only varies with latitudes 
-            vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
-            zm=zm+masseby(i,j,l)
-          enddo
-          vzon(j,l)=vzon(j,l)/zm
-        enddo
-       enddo
-c$OMP END DO NOWAIT   
-      else
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-         vzon(:,l)=0.
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.2)
-
-      ! compute zonal average of u (or set it to zero)
-      if (mode_top_bound>=2) then
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          uzon(j,l)=0.
-          zm=0.
-          do i=1,iim
-            uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
-            zm=zm+massebx(i,j,l)
-          enddo
-          uzon(j,l)=uzon(j,l)/zm
-        enddo
-       enddo
-c$OMP END DO NOWAIT
-      else
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-         uzon(:,l)=0.
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.2)
-
-      ! compute zonal average of potential temperature, if necessary
-      if (mode_top_bound>=3) then
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-       do l=1,llm
-        do j=jjb,jje
-          zm=0.
-          tzon(j,l)=0.
-          do i=1,iim
-            tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
-            zm=zm+masse(i,j,l)
-          enddo
-          tzon(j,l)=tzon(j,l)/zm
-        enddo
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.3)
-
-      if (mode_top_bound>=1) then
-       ! Apply sponge quenching on vcov:
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_sud) jje=jj_end-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          do i=1,iip1
-            vcov(i,j,l)=vcov(i,j,l)
-     &                  -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
-          enddo
-        enddo
-       enddo
-c$OMP END DO NOWAIT
-
-       ! Apply sponge quenching on ucov:
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          do i=1,iip1
-            ucov(i,j,l)=ucov(i,j,l)
-     &                  -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
-          enddo
-       enddo
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.1)
-
-      if (mode_top_bound>=3) then
-       ! Apply sponge quenching on teta:
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          do i=1,iip1
-            teta(i,j,l)=teta(i,j,l)
-     &                  -rdamp(l)*(teta(i,j,l)-tzon(j,l))
-          enddo
-       enddo
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bond.ge.3)
-
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/top_bound_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/top_bound_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/top_bound_loc.f90	(revision 5105)
@@ -0,0 +1,256 @@
+
+! $Id: $
+
+SUBROUTINE top_bound_loc(vcov,ucov,teta,masse,dt)
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound, &
+        tau_top_bound
+  USE comvert_mod, ONLY: presnivs, preff, scaleheight
+
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+
+  ! ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
+  ! F. LOTT DEC. 2006
+  !                             (  10/12/06  )
+
+  !=======================================================================
+  !
+  !   Auteur:  F. LOTT
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Dissipation linéaire (ex top_bound de la physique)
+  !
+  !=======================================================================
+
+  ! top_bound sponge layer model:
+  ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
+  ! where Am is the zonal average of the field (or zero), and lambda the inverse
+  ! of the characteristic quenching/relaxation time scale
+  ! Thus, assuming Am to be time-independent, field at time t+dt is given by:
+  ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
+  ! Moreover lambda can be a function of model level (see below), and relaxation
+  ! can be toward the average zonal field or just zero (see below).
+
+  ! NB: top_bound sponge is only called from leapfrog if ok_strato=.TRUE.
+
+  ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
+  !    iflag_top_bound=0 for no sponge
+  !    iflag_top_bound=1 for sponge over 4 topmost layers
+  !    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
+  !    mode_top_bound=0: no relaxation
+  !    mode_top_bound=1: u and v relax towards 0
+  !    mode_top_bound=2: u and v relax towards their zonal mean
+  !    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
+  !    tau_top_bound : inverse of charactericstic relaxation time scale at
+  !                   the topmost layer (Hz)
+
+
+  INCLUDE "comdissipn.h"
+  INCLUDE "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
+  real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
+  real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
+  real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere
+  real,intent(in) :: dt ! time step (s) of sponge model
+
+   ! REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
+   ! REAL dh(iip1,jjb_u:jje_u,llm)
+
+  !   Local:
+  !   ------
+  REAL :: massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm)
+  REAL :: zm
+  REAL :: uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm)
+  REAL :: tzon(jjb_u:jje_u,llm)
+
+  integer :: i
+  REAL,SAVE :: rdamp(llm)
+  real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
+  LOGICAL,SAVE :: first=.TRUE.
+  INTEGER :: j,l,jjb,jje
+
+
+  if (iflag_top_bound == 0) return
+
+  if (first) then
+!$OMP BARRIER
+!$OMP MASTER
+     if (iflag_top_bound == 1) then
+  ! sponge quenching over the topmost 4 atmospheric layers
+         lambda(:)=0.
+         lambda(llm)=tau_top_bound
+         lambda(llm-1)=tau_top_bound/2.
+         lambda(llm-2)=tau_top_bound/4.
+         lambda(llm-3)=tau_top_bound/8.
+     else if (iflag_top_bound == 2) then
+  ! sponge quenching over topmost layers down to pressures which are
+  ! higher than 100 times the topmost layer pressure
+         lambda(:)=tau_top_bound &
+               *max(presnivs(llm)/presnivs(:)-0.01,0.)
+     endif
+
+  ! quenching coefficient rdamp(:)
+      ! rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
+     rdamp(:)=1.-exp(-lambda(:)*dt)
+
+     write(lunout,*)'TOP_BOUND mode',mode_top_bound
+     write(lunout,*)'Sponge layer coefficients'
+     write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
+     do l=1,llm
+       if (rdamp(l)/=0.) then
+         write(lunout,'(6(1pe12.4,1x))') &
+               presnivs(l),log(preff/presnivs(l))*scaleheight, &
+               1./lambda(l),lambda(l)
+       endif
+     enddo
+     first=.FALSE.
+!$OMP END MASTER
+!$OMP BARRIER
+  endif ! of if (first)
+
+
+  CALL massbar_loc(masse,massebx,masseby)
+
+  ! ! compute zonal average of vcov (or set it to zero)
+  if (mode_top_bound>=2) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      zm=0.
+      vzon(j,l)=0
+      do i=1,iim
+  ! NB: we can work using vcov zonal mean rather than v since the
+  ! cv coefficient (which relates the two) only varies with latitudes
+        vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
+        zm=zm+masseby(i,j,l)
+      enddo
+      vzon(j,l)=vzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+     vzon(:,l)=0.
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.2)
+
+  ! ! compute zonal average of u (or set it to zero)
+  if (mode_top_bound>=2) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      uzon(j,l)=0.
+      zm=0.
+      do i=1,iim
+        uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
+        zm=zm+massebx(i,j,l)
+      enddo
+      uzon(j,l)=uzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+     uzon(:,l)=0.
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.2)
+
+  ! ! compute zonal average of potential temperature, if necessary
+  if (mode_top_bound>=3) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      zm=0.
+      tzon(j,l)=0.
+      do i=1,iim
+        tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
+        zm=zm+masse(i,j,l)
+      enddo
+      tzon(j,l)=tzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.3)
+
+  if (mode_top_bound>=1) then
+   ! ! Apply sponge quenching on vcov:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        vcov(i,j,l)=vcov(i,j,l) &
+              -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
+      enddo
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+
+   ! ! Apply sponge quenching on ucov:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        ucov(i,j,l)=ucov(i,j,l) &
+              -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+      enddo
+   enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.1)
+
+  if (mode_top_bound>=3) then
+   ! ! Apply sponge quenching on teta:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        teta(i,j,l)=teta(i,j,l) &
+              -rdamp(l)*(teta(i,j,l)-tzon(j,l))
+      enddo
+   enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bond.ge.3)
+
+END SUBROUTINE top_bound_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/vlsplt_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlsplt_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,1195 +1,0 @@
-
-! $Id$
-
-      RECURSIVE SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x,iq)
-
-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   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE infotrac, ONLY: nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL u_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm)
-      REAL q(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot
-      REAL w(ijb_u:ije_u,llm)
-      INTEGER iq ! CRisi
-c
-c      Local
-c   ---------
-c
-      INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju
-      INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
-c
-      REAL new_m,zu_m,zdum(ijb_u:ije_u,llm)
-      REAL sigu(ijb_u:ije_u),dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
-      REAL zz(ijb_u:ije_u)
-      REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
-      REAL u_mq(ijb_u:ije_u,llm)
-
-      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      INTEGER ifils,iq2 ! CRisi
-
-      Logical extremum
-
-      REAL      SSUM
-
-      REAL z1,z2,z3
-
-      INTEGER ijb,ije,ijb_x,ije_x
-
-      !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
-!     &   iq,ijb_x
-c   calcul de la pente a droite et a gauche de la maille
-
-      ijb=ijb_x
-      ije=ije_x
-
-      if (pole_nord.and.ijb==1) ijb=ijb+iip1
-      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
-
-      IF (pente_max>-1.e-5) THEN
-c       IF (pente_max.gt.10) THEN
-
-c   calcul des pentes avec limitation, Van Leer scheme I:
-c   -----------------------------------------------------
-      ! on a besoin de q entre ijb et ije
-c   calcul de la pente aux points u
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l = 1, llm
-
-            DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
-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,iq)
-            ENDDO
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqu(ij)=dxqu(ij-iim)
-c              sigu(ij)=sigu(ij-iim)
-            ENDDO
-
-            DO ij=ijb,ije
-               adxqu(ij)=abs(dxqu(ij))
-            ENDDO
-
-c   calcul de la pente maximum dans la maille en valeur absolue
-
-            DO ij=ijb+1,ije
-               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=ijb+iip1-1,ije,iip1
-               dxqmax(ij-iim,l)=dxqmax(ij,l)
-            ENDDO
-
-            DO ij=ijb+1,ije
-               IF(dxqu(ij-1)*dxqu(ij)>0) THEN
-                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
-               ELSE
-c   extremum local
-                  dxq(ij,l)=0.
-               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
-c$OMP END DO NOWAIT
-c	PRINT*,'Ok calcul des pentes'
-
-      ELSE ! (pente_max.lt.-1.e-5)
-
-c   Pentes produits:
-c   ----------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l = 1, llm
-            DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
-            ENDDO
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqu(ij)=dxqu(ij-iim)
-            ENDDO
-
-            DO ij=ijb+1,ije
-               zz(ij)=dxqu(ij-1)*dxqu(ij)
-               zz(ij)=zz(ij)+zz(ij)
-               IF(zz(ij)>0) THEN
-                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
-               ELSE
-c   extremum local
-                  dxq(ij,l)=0.
-               ENDIF
-            ENDDO
-
-         ENDDO
-c$OMP END DO NOWAIT
-      ENDIF ! (pente_max.lt.-1.e-5)
-
-      !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x
-
-c   bouclage de la pente en iip1:
-c   -----------------------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb+iip1-1,ije,iip1
-            dxq(ij-iim,l)=dxq(ij,l)
-         ENDDO
-         DO ij=ijb,ije
-            iadvplus(ij,l)=0
-         ENDDO
-
-      ENDDO
-c$OMP END DO NOWAIT
-c	 PRINT*,'Bouclage en iip1'
-
-c   calcul des flux a gauche et a droite
-
-
-c   on cumule le flux correspondant a toutes les mailles dont la masse
-c   au travers de la paroi pENDant le pas de temps.
-c	PRINT*,'Cumule ....'
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        ! on a besoin de masse entre ijb et ije
-      DO l=1,llm
-       DO ij=ijb,ije-1
-c	PRINT*,'masse(',ij,')=',masse(ij,l,iq)
-          IF (u_m(ij,l)>0.) THEN
-             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
-             u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)
-     :           +0.5*zdum(ij,l)*dxq(ij,l))
-          ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
-             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
-     :           -0.5*zdum(ij,l)*dxq(ij+1,l))
-          ENDIF
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   detection des points ou on advecte plus que la masse de la
-c   maille
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb,ije-1
-            IF(zdum(ij,l)<0) THEN
-               iadvplus(ij,l)=1
-               u_mq(ij,l)=0.
-            ENDIF
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-c	PRINT*,'Ok test 1'
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       DO ij=ijb+iip1-1,ije,iip1
-          iadvplus(ij,l)=iadvplus(ij-iim,l)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-c	 PRINT*,'Ok test 2'
-
-
-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
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         nl(l)=0
-         DO ij=ijb,ije
-            nl(l)=nl(l)+iadvplus(ij,l)
-         ENDDO
-         n0=n0+nl(l)
-      ENDDO
-c$OMP END DO NOWAIT
-cym      IF(n0.gt.1) THEN
-cym      IF(n0.gt.0) THEN
-
-c      PRINT*,'Nombre de points pour lesquels on advect plus que le'
-c     &       ,'contenu de la maille : ',n0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-
-
-         DO l=1,llm
-            IF(nl(l)>0) THEN
-               iju=0
-c   indicage des mailles concernees par le traitement special
-               DO ij=ijb,ije
-                  IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
-                     iju=iju+1
-                     indu(iju)=ij
-                  ENDIF
-               ENDDO
-               niju=iju
-               !PRINT*,'vlx 278, 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>0.) THEN
-                     ijq=ij
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(zu_m>masse(ijq,l,iq))
-                        u_mq(ij,l)=u_mq(ij,l)
-     &                          +q(ijq,l,iq)*masse(ijq,l,iq)
-                        zu_m=zu_m-masse(ijq,l,iq)
-                        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,iq)+0.5*
-     &               (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
-                  ELSE
-                     ijq=ij+1
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(-zu_m>masse(ijq,l,iq))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
-     &                           *masse(ijq,l,iq)
-                        zu_m=zu_m+masse(ijq,l,iq)
-                        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,iq)-
-     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
-                  ENDIF
-               ENDDO
-            ENDIF
-         ENDDO
-c$OMP END DO NOWAIT
-cym      ENDIF  ! n0.gt.0
-
-c   bouclage en latitude
-c	PRINT*,'Avant bouclage en latitude'
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        DO ij=ijb+iip1-1,ije,iip1
-           u_mq(ij,l)=u_mq(ij-iim,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! CRisi: appel récursif de l'advection sur les fils.
-! Il faut faire ça avant d'avoir mis à jour q et masse
-
-      do ifils=1,tracers(iq)%nqDescen
-        ! attention: comme Ratio est utilisé comme q dans l'appel
-        ! recursif, il doit contenir à lui seul tous les indices de tous
-        ! les descendants!
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          DO ij=ijb,ije
-            ! On a besoin de q et masse seulement entre ijb et ije. On ne
-            ! les calcule donc que de ijb à ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-            if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio
-            endif
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo !do ifils=1,tracers(iq)%nqDescen
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        CALL vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
-      enddo
-! end CRisi
-
-
-c   calcul des tENDances
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb+1,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
-     &        u_mq(ij-1,l)-u_mq(ij,l))
-     &        /new_m
-            masse(ij,l,iq)=new_m
-         ENDDO
-c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
-         DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l,iq)=q(ij,l,iq)
-            masse(ij-iim,l,iq)=masse(ij,l,iq)
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio
-      ! puis on boucle en longitude
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          DO ij=ijb+1,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
-          enddo
-          DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l,iq2)=q(ij,l,iq2)
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-      !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x
-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
-
-
-      RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq)
-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   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE infotrac, ONLY: nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
-      USE comconst_mod, ONLY: pi
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL masse_adv_v( ijb_v:ije_v,llm)
-      REAL q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm)
-      INTEGER iq ! CRisi
-c
-c      Local
-c   ---------
-c
-      INTEGER i,ij,l
-c
-      REAL airej2,airejjm,airescb(iim),airesch(iim)
-      REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v),zdvm(ijb_u:ije_u,llm)
-      REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
-      REAL qbyv(ijb_v:ije_v,llm)
-
-      REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
-c     REAL newq,oldmasse
-      Logical extremum,first
-      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
-      SAVE temps0,temps1,temps2,temps3,temps4,temps5
-c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
-      SAVE first
-c$OMP THREADPRIVATE(first)
-
-      REAL convpn,convps,convmpn,convmps
-      real massepn,masseps,qpn,qps
-      REAL sinlon(iip1),sinlondlon(iip1)
-      REAL coslon(iip1),coslondlon(iip1)
-      SAVE sinlon,coslon,sinlondlon,coslondlon
-c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
-      SAVE airej2,airejjm
-c$OMP THREADPRIVATE(airej2,airejjm)
-
-      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      INTEGER ifils,iq2 ! CRisi
-c
-c
-      REAL      SSUM
-      EXTERNAL  SSUM
-
-      DATA first/.TRUE./
-      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
-      INTEGER ijb,ije
-      INTEGER ijbm,ijem
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-
-      IF(first) THEN
-         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
-         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
-c	PRINT*,'CALCUL EN LATITUDE'
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      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.
-
-      if (pole_nord) then
-        DO i = 1, iim
-          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
-        ENDDO
-        qpns   = SSUM( iim,  airescb ,1 ) / airej2
-      endif
-
-      if (pole_sud) then
-        DO i = 1, iim
-          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
-        ENDDO
-        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
-      endif
-
-c   calcul des pentes aux points v
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-
-      ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
-      ! Si pole sud, entre ij_begin-2*iip1 et ij_end
-      ! Si pole Nord, entre ij_begin et ij_end+2*iip1
-      DO ij=ijb,ije
-         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
-         adyqv(ij)=abs(dyqv(ij))
-      ENDDO
-
-
-c   calcul des pentes aux points scalaires
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-      DO ij=ijb,ije
-         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
-      IF (pole_nord) THEN
-        DO ij=1,iip1
-           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
-        ENDDO
-
-        dyn1=0.
-        dyn2=0.
-        DO ij=1,iim
-          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
-          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
-        ENDDO
-        DO ij=1,iip1
-          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
-        ENDDO
-
-        DO ij=1,iip1
-         dyq(ij,l)=0.
-        ENDDO
-c ym tout cela ne sert pas a grand chose
-      ENDIF
-
-      IF (pole_sud) THEN
-
-        DO ij=1,iip1
-           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
-        ENDDO
-
-        dys1=0.
-        dys2=0.
-
-        DO ij=1,iim
-          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
-          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
-        ENDDO
-
-        DO ij=1,iip1
-          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
-        ENDDO
-
-        DO ij=1,iip1
-         dyq(ip1jm+ij,l)=0.
-        ENDDO
-c ym tout cela ne sert pas a grand chose
-      ENDIF
-
-c   filtrage de la derivee
-
-c   calcul des pentes limites aux poles
-c ym partie inutile
-c      goto 8888
-c      fn=1.
-c      fs=1.
-c      DO ij=1,iim
-c         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
-c            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
-c         ENDIF
-c      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
-c         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
-c         ENDIF
-c      ENDDO
-c      DO ij=1,iip1
-c         dyq(ij,l)=fn*dyq(ij,l)
-c         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
-c      ENDDO
-c 8888    continue
-
-
-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     appn=abs(dyq(1)/dyqv(iip1+1))
-C     PRINT*,dyq(ip1jm+1)
-C     PRINT*,dyqv(ip1jm-iip1+1)
-C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
-C     DO ij=2,iim
-C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
-C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
-C     ENDDO
-C     appn=min(pente_max/appn,1.)
-C     apps=min(pente_max/apps,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    &   appn=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    &   apps=0.
-C
-C   limitation des pentes aux poles
-C     DO ij=1,iip1
-C        dyq(ij)=appn*dyq(ij)
-C        dyq(ip1jm+ij)=apps*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
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-      DO ij=ijb,ije
-         IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
-            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
-         ELSE
-            dyq(ij,l)=0.
-         ENDIF
-      ENDDO
-
-      ENDDO
-c$OMP END DO NOWAIT
-
-      ijb=ij_begin-iip1
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       DO ij=ijb,ije
-          IF(masse_adv_v(ij,l)>0) THEN
-              qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
-     ,                   0.5*(1.-masse_adv_v(ij,l)
-     ,                   /masse(ij+iip1,l,iq))
-          ELSE
-              qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq))
-          ENDIF
-          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! CRisi: appel récursif de l'advection sur les fils.
-! Il faut faire ça avant d'avoir mis à jour q et masse
-!     write(*,*)'vly 689: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1
-      ijbm=ij_begin-iip1
-      ijem=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-      if (pole_nord) ijbm=ij_begin
-      if (pole_sud)  ijem=ij_end
-
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-        ! modif des bornes: CRisi 16 nov 2020
-        ! d'abord masse avec bornes corrigées
-          DO ij=ijbm,ijem
-          !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-          enddo
-
-          ! ensuite Ratio avec anciennes bornes
-          DO ij=ijb,ije
-          !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio
-            endif
-          enddo !DO ij=ijbm,ijem
-        enddo !DO l=1,llm
-c$OMP END DO NOWAIT
-      enddo
-
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        CALL vly_loc(Ratio,pente_max,masse,qbyv,iq2)
-      enddo
-! end CRisi
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb,ije
-            newmasse=masse(ij,l,iq)
-     &         +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
-     &         -qbyv(ij-iip1,l))/newmasse
-
-            masse(ij,l,iq)=newmasse
-
-         ENDDO
-
-
-c.-. ancienne version
-c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
-c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
-         if (pole_nord) then
-           convpn=SSUM(iim,qbyv(1,l),1)
-           convmpn=ssum(iim,masse_adv_v(1,l),1)
-           massepn=ssum(iim,masse(1,l,iq),1)
-           qpn=0.
-           do ij=1,iim
-              qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
-           enddo
-           qpn=(qpn+convpn)/(massepn+convmpn)
-           do ij=1,iip1
-              q(ij,l,iq)=qpn
-           enddo
-         endif
-
-c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
-c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
-
-         if (pole_sud) then
-
-           convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
-           convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
-           masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
-           qps=0.
-           do ij = ip1jm+1,ip1jmp1-1
-              qps=qps+masse(ij,l,iq)*q(ij,l,iq)
-           enddo
-           qps=(qps+convps)/(masseps+convmps)
-           do ij=ip1jm+1,ip1jmp1
-              q(ij,l,iq)=qps
-           enddo
-         endif
-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,iq)=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,iq)=newmasse*aire(ij)
-c        ENDDO
-c._. fin nouvelle version
-      ENDDO
-c$OMP END DO NOWAIT
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      ijb=ij_begin
-      ije=ij_end
-!      if (pole_nord) ijb=ij_begin
-!      if (pole_sud)  ije=ij_end
-
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          DO ij=ijb,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-
-      RETURN
-      END
-
-
-
-      RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq)
-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   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE vlz_mod
-      USE infotrac, ONLY: nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
-
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "iniprint.h"
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      REAL w(ijb_u:ije_u,llm+1,nqtot)
-      INTEGER iq
-c
-c      Local
-c   ---------
-c
-      INTEGER i,ij,l,j,ii
-
-      REAL,DIMENSION(ijb_u:ije_u,llm+1) :: wresi,morig,qorig,dzqorig
-      INTEGER,DIMENSION(ijb_u:ije_u,llm+1) :: lorig
-      INTEGER,SAVE :: countcfl
-!$OMP THREADPRIVATE(countcfl)
-c
-      REAL newmasse
-
-      REAL dzqmax
-      REAL sigw
-
-      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
-      SAVE temps0,temps1,temps2,temps3,temps4,temps5
-c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
-
-      REAL      SSUM
-
-      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
-      INTEGER ijb,ije,ijb_x,ije_x
-      LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-      !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      ! Ces varibles doivent être déclarées en pointer et en save dans
-      ! vlz_loc si on veut qu'elles soient vues par tous les threads.
-      INTEGER ifils,iq2 ! CRisi
-
-
-      IF (first) THEN
-       first=.FALSE.
-      ENDIF
-c    On oriente tout dans le sens de la pression c'est a dire dans le
-c    sens de W
-
-      !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq
-
-      ijb=ijb_x
-      ije=ije_x
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=2,llm
-         DO ij=ijb,ije
-            dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
-            adzqw(ij,l)=abs(dzqw(ij,l))
-         ENDDO
-      ENDDO
-c$OMP END DO
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=2,llm-1
-         DO ij=ijb,ije
-            IF(dzqw(ij,l)*dzqw(ij,l+1)>0.) THEN
-                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
-            ELSE
-                dzq(ij,l)=0.
-            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
-c$OMP END DO NOWAIT
-
-c$OMP MASTER
-      DO ij=ijb,ije
-         dzq(ij,1)=0.
-         dzq(ij,llm)=0.
-      ENDDO
-c$OMP END MASTER
-c$OMP BARRIER
-
-!--------------------------------------------------------
-! On repere les points qui violent le CFL (|w| > masse)
-!--------------------------------------------------------
-
-      countcfl=0
-!     PRINT*,'vlz nouveau'
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 2,llm
-         DO ij = ijb,ije
-          IF(  (w(ij,l,iq)>0.AND.w(ij,l,iq)>masse(ij,l,iq))
-     s    .OR. (w(ij,l,iq)<=0.AND.ABS(w(ij,l,iq))>masse(ij,l-1,iq)) )
-     s    countcfl=countcfl+1
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c ---------------------------------------------------------------
-c  Identification des mailles ou on viole le CFL : w > masse
-c ---------------------------------------------------------------
-
-      IF (countcfl==0) THEN
-
-c ---------------------------------------------------------------
-c   .... calcul des termes d'advection verticale  .......
-c     Dans le cas où le  |w| < masse partout.
-c     Version d'origine
-c     Pourrait etre enleve si on voit que le code plus general
-c     est aussi rapide
-c ---------------------------------------------------------------
-
-c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
-
-       !write(*,*) 'vlz 982,ijb,ije=',ijb,ije
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-       DO l = 1,llm-1
-         do  ij = ijb,ije
-          IF(w(ij,l+1,iq)>0.) THEN
-             sigw=w(ij,l+1,iq)/masse(ij,l+1,iq)
-             wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq)
-     :           +0.5*(1.-sigw)*dzq(ij,l+1))
-          ELSE
-             sigw=w(ij,l+1,iq)/masse(ij,l,iq)
-             wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq)
-     :           -0.5*(1.+sigw)*dzq(ij,l))
-          ENDIF
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-       !write(*,*) 'vlz 1001'
-
-      ELSE ! countcfl>=1
-
-      IF (prt_level>9) THEN
-        WRITE(lunout,*)'vlz passage dans le non local'
-      ENDIF
-c ---------------------------------------------------------------
-c  Debut du traitement du cas ou on viole le CFL : w > masse
-c ---------------------------------------------------------------
-
-c Initialisation
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-       DO l = 2,llm
-         DO ij = ijb,ije
-            wresi(ij,l)=w(ij,l,iq)
-            wq(ij,l,iq)=0.
-            IF(w(ij,l,iq)>0.) THEN
-               lorig(ij,l)=l
-               morig(ij,l)=masse(ij,l,iq)
-               qorig(ij,l)=q(ij,l,iq)
-               dzqorig(ij,l)=dzq(ij,l)
-            ELSE
-               lorig(ij,l)=l-1
-               morig(ij,l)=masse(ij,l-1,iq)
-               qorig(ij,l)=q(ij,l-1,iq)
-               dzqorig(ij,l)=dzq(ij,l-1)
-            ENDIF
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-
-c Reindicage vertical en accumulant les flux sur
-c  les mailles qui viollent le CFL
-c  on itère jusqu'à ce que tous les poins satisfassent
-c  le critère
-      DO WHILE (countcfl>=1)
-        IF (prt_level>9) THEN
-          WRITE(lunout,*)'On viole le CFL Vertical sur ',countcfl,' pts'
-        ENDIF
-      countcfl=0
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 2,llm
-         DO ij = ijb,ije
-          IF (ABS(wresi(ij,l))>morig(ij,l)) THEN
-             countcfl=countcfl+1
-! rm : les 8 lignes ci dessous pourraient sans doute s'ecrire
-! avec la fonction sign
-             IF(w(ij,l,iq)>0.) THEN
-                wresi(ij,l)=wresi(ij,l)-morig(ij,l)
-                wq(ij,l,iq)=wq(ij,l,iq)+morig(ij,l)*qorig(ij,l)
-                lorig(ij,l)=lorig(ij,l)+1
-             ELSE
-                wresi(ij,l)=wresi(ij,l)+morig(ij,l)
-                wq(ij,l,iq)=wq(ij,l,iq)-morig(ij,l)*qorig(ij,l)
-                lorig(ij,l)=lorig(ij,l)-1
-             ENDIF
-             ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage
-             ! pour seg fault
-             if (lorig(ij,l)==0) then
-                CALL abort_gcm("vlz in vlsplt_loc",
-     :           "unfixable violation of CFL",1)
-             endif
-             morig(ij,l)=masse(ij,lorig(ij,l),iq)
-             qorig(ij,l)=q(ij,lorig(ij,l),iq)
-             dzqorig(ij,l)=dzq(ij,lorig(ij,l))
-          ENDIF
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      ENDDO ! WHILE (countcfl>=1)
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-       DO l = 2,llm
-         do  ij = ijb,ije
-          sigw=wresi(ij,l)/morig(ij,l)
-          IF(w(ij,l,iq)>0.) THEN
-             wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l)
-     :           +0.5*(1.-sigw)*dzqorig(ij,l))
-          ELSE
-             wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l)
-     :           -0.5*(1.+sigw)*dzqorig(ij,l))
-          ENDIF
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-
-
-       ENDIF ! councfl=0
-
-
-
-c$OMP MASTER
-       DO ij=ijb,ije
-          wq(ij,llm+1,iq)=0.
-          wq(ij,1,iq)=0.
-       ENDDO
-c$OMP END MASTER
-c$OMP BARRIER
-
-! CRisi: appel récursif de l'advection sur les fils.
-! Il faut faire ça avant d'avoir mis à jour q et masse
-!     write(*,*)'vlsplt 942: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          DO ij=ijb,ije
-           !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-            if (q(ij,l,iq)>min_qParent) then
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio
-            endif
-            !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015
-            w(ij,l,iq2)=wq(ij,l,iq)
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-c$OMP BARRIER
-
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        CALL vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2)
-      enddo
-! end CRisi
-
-! CRisi: On rajoute ici une barrière car on veut être sur que tous les
-! wq soient synchronisés
-
-c$OMP BARRIER
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb,ije
-            newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq)
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)
-     &         +wq(ij,l+1,iq)-wq(ij,l,iq))
-     &         /newmasse
-            masse(ij,l,iq)=newmasse
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          DO ij=ijb,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-      RETURN
-      END
-c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
-c
-c      INCLUDE "dimensions.h"
-c      INCLUDE "paramet.h"
-
-c      CHARACTER*(*) comment
-c      real qmin,qmax
-c      real zq(ip1jmp1,llm)
-
-c      INTEGER jadrs(ip1jmp1), jbad, k, i
-
-
-c      DO k = 1, llm
-c         jbad = 0
-c         DO i = 1, ip1jmp1
-c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
-c            jbad = jbad + 1
-c            jadrs(jbad) = i
-c         ENDIF
-c         ENDDO
-c         IF (jbad.GT.0) THEN
-c         PRINT*, comment
-c         DO i = 1, jbad
-cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
-c         ENDDO
-c         ENDIF
-c      ENDDO
-
-c      return
-c      end
-
-
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlsplt_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlsplt_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlsplt_loc.f90	(revision 5105)
@@ -0,0 +1,1121 @@
+! $Id$
+
+SUBROUTINE vlx_loc(q, pente_max, masse, u_m, ijb_x, ije_x, iq)
+
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY: nqtot, tracers, & ! CRisi                 &
+          min_qParent, min_qMass, min_ratio ! MVals et CRisi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u, llm, nqtot), pente_max
+  REAL :: u_m(ijb_u:ije_u, llm), pbarv(iip1, jjb_v:jje_v, llm)
+  REAL :: q(ijb_u:ije_u, llm, nqtot) ! CRisi: ajout dimension nqtot
+  REAL :: w(ijb_u:ije_u, llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij, l, j, i, iju, ijq, indu(ijnb_u), niju
+  INTEGER :: n0, iadvplus(ijb_u:ije_u, llm), nl(llm)
+  !
+  REAL :: new_m, zu_m, zdum(ijb_u:ije_u, llm)
+  REAL :: sigu(ijb_u:ije_u), dxq(ijb_u:ije_u, llm), dxqu(ijb_u:ije_u)
+  REAL :: zz(ijb_u:ije_u)
+  REAL :: adxqu(ijb_u:ije_u), dxqmax(ijb_u:ije_u, llm)
+  REAL :: u_mq(ijb_u:ije_u, llm)
+
+  REAL :: Ratio(ijb_u:ije_u, llm, nqtot) ! CRisi
+  INTEGER :: ifils, iq2 ! CRisi
+
+  Logical :: extremum
+
+  REAL :: SSUM
+
+  REAL :: z1, z2, z3
+
+  INTEGER :: ijb, ije, ijb_x, ije_x
+
+  ! !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
+  ! &   iq,ijb_x
+  !   calcul de la pente a droite et a gauche de la maille
+
+  ijb = ijb_x
+  ije = ije_x
+
+  if (pole_nord.and.ijb==1) ijb = ijb + iip1
+  if (pole_sud.and.ije==ip1jmp1)  ije = ije - iip1
+
+  IF (pente_max>-1.e-5) THEN
+    ! IF (pente_max.gt.10) THEN
+
+    !   calcul des pentes avec limitation, Van Leer scheme I:
+    !   -----------------------------------------------------
+    ! ! on a besoin de q entre ijb et ije
+    !   calcul de la pente aux points u
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+
+      DO ij = ijb, ije - 1
+        dxqu(ij) = q(ij + 1, l, iq) - q(ij, l, iq)
+        ! IF(u_m(ij,l).lt.0.) stop 'limx n admet pas les U<0'
+        ! sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
+      ENDDO
+      DO ij = ijb + iip1 - 1, ije, iip1
+        dxqu(ij) = dxqu(ij - iim)
+        ! sigu(ij)=sigu(ij-iim)
+      ENDDO
+
+      DO ij = ijb, ije
+        adxqu(ij) = abs(dxqu(ij))
+      ENDDO
+
+      !   calcul de la pente maximum dans la maille en valeur absolue
+
+      DO ij = ijb + 1, ije
+        dxqmax(ij, l) = pente_max * &
+                min(adxqu(ij - 1), adxqu(ij))
+        ! limitation subtile
+        !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+
+      ENDDO
+
+      DO ij = ijb + iip1 - 1, ije, iip1
+        dxqmax(ij - iim, l) = dxqmax(ij, l)
+      ENDDO
+
+      DO ij = ijb + 1, ije
+        IF(dxqu(ij - 1) * dxqu(ij)>0) THEN
+          dxq(ij, l) = dxqu(ij - 1) + dxqu(ij)
+        ELSE
+          !   extremum local
+          dxq(ij, l) = 0.
+        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
+    !$OMP END DO NOWAIT
+    ! PRINT*,'Ok calcul des pentes'
+
+  ELSE ! (pente_max.lt.-1.e-5)
+
+    !   Pentes produits:
+    !   ----------------
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      DO ij = ijb, ije - 1
+        dxqu(ij) = q(ij + 1, l, iq) - q(ij, l, iq)
+      ENDDO
+      DO ij = ijb + iip1 - 1, ije, iip1
+        dxqu(ij) = dxqu(ij - iim)
+      ENDDO
+
+      DO ij = ijb + 1, ije
+        zz(ij) = dxqu(ij - 1) * dxqu(ij)
+        zz(ij) = zz(ij) + zz(ij)
+        IF(zz(ij)>0) THEN
+          dxq(ij, l) = zz(ij) / (dxqu(ij - 1) + dxqu(ij))
+        ELSE
+          !   extremum local
+          dxq(ij, l) = 0.
+        ENDIF
+      ENDDO
+
+    ENDDO
+    !$OMP END DO NOWAIT
+  ENDIF ! (pente_max.lt.-1.e-5)
+
+  ! !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x
+
+  !   bouclage de la pente en iip1:
+  !   -----------------------------
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb + iip1 - 1, ije, iip1
+      dxq(ij - iim, l) = dxq(ij, l)
+    ENDDO
+    DO ij = ijb, ije
+      iadvplus(ij, l) = 0
+    ENDDO
+
+  ENDDO
+  !$OMP END DO NOWAIT
+  ! PRINT*,'Bouclage en iip1'
+
+  !   calcul des flux a gauche et a droite
+
+
+  !   on cumule le flux correspondant a toutes les mailles dont la masse
+  !   au travers de la paroi pENDant le pas de temps.
+  ! PRINT*,'Cumule ....'
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  ! ! on a besoin de masse entre ijb et ije
+  DO l = 1, llm
+    DO ij = ijb, ije - 1
+      ! PRINT*,'masse(',ij,')=',masse(ij,l,iq)
+      IF (u_m(ij, l)>0.) THEN
+        zdum(ij, l) = 1. - u_m(ij, l) / masse(ij, l, iq)
+        u_mq(ij, l) = u_m(ij, l) * (q(ij, l, iq) &
+                + 0.5 * zdum(ij, l) * dxq(ij, l))
+      ELSE
+        zdum(ij, l) = 1. + u_m(ij, l) / masse(ij + 1, l, iq)
+        u_mq(ij, l) = u_m(ij, l) * (q(ij + 1, l, iq) &
+                - 0.5 * zdum(ij, l) * dxq(ij + 1, l))
+      ENDIF
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  !   detection des points ou on advecte plus que la masse de la
+  !   maille
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb, ije - 1
+      IF(zdum(ij, l)<0) THEN
+        iadvplus(ij, l) = 1
+        u_mq(ij, l) = 0.
+      ENDIF
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+  ! PRINT*,'Ok test 1'
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb + iip1 - 1, ije, iip1
+      iadvplus(ij, l) = iadvplus(ij - iim, l)
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+  ! PRINT*,'Ok test 2'
+
+
+  !   traitement special pour le cas ou on advecte en longitude plus que le
+  !   contenu de la maille.
+  !   cette partie est mal vectorisee.
+
+  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+  n0 = 0
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    nl(l) = 0
+    DO ij = ijb, ije
+      nl(l) = nl(l) + iadvplus(ij, l)
+    ENDDO
+    n0 = n0 + nl(l)
+  ENDDO
+  !$OMP END DO NOWAIT
+  !ym      IF(n0.gt.1) THEN
+  !ym      IF(n0.gt.0) THEN
+
+  ! PRINT*,'Nombre de points pour lesquels on advect plus que le'
+  ! &       ,'contenu de la maille : ',n0
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+
+  DO l = 1, llm
+    IF(nl(l)>0) THEN
+      iju = 0
+      !   indicage des mailles concernees par le traitement special
+      DO ij = ijb, ije
+        IF(iadvplus(ij, l)==1.and.mod(ij, iip1)/=0) THEN
+          iju = iju + 1
+          indu(iju) = ij
+        ENDIF
+      ENDDO
+      niju = iju
+      ! !PRINT*,'vlx 278, niju,nl',niju,nl(l)
+
+      !  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>0.) THEN
+          ijq = ij
+          i = ijq - (j - 1) * iip1
+          !   accumulation pour les mailles completements advectees
+          do while(zu_m>masse(ijq, l, iq))
+            u_mq(ij, l) = u_mq(ij, l) &
+                    + q(ijq, l, iq) * masse(ijq, l, iq)
+            zu_m = zu_m - masse(ijq, l, iq)
+            i = mod(i - 2 + iim, iim) + 1
+            ijq = (j - 1) * iip1 + i
+          ENDDO
+          !   ajout de la maille non completement advectee
+          u_mq(ij, l) = u_mq(ij, l) + zu_m * &
+                  (q(ijq, l, iq) + 0.5 * &
+                          (1. - zu_m / masse(ijq, l, iq)) * dxq(ijq, l))
+        ELSE
+          ijq = ij + 1
+          i = ijq - (j - 1) * iip1
+          !   accumulation pour les mailles completements advectees
+          do while(-zu_m>masse(ijq, l, iq))
+            u_mq(ij, l) = u_mq(ij, l) - q(ijq, l, iq) &
+                    * masse(ijq, l, iq)
+            zu_m = zu_m + masse(ijq, l, iq)
+            i = mod(i, iim) + 1
+            ijq = (j - 1) * iip1 + i
+          ENDDO
+          !   ajout de la maille non completement advectee
+          u_mq(ij, l) = u_mq(ij, l) + zu_m * (q(ijq, l, iq) - &
+                  0.5 * (1. + zu_m / masse(ijq, l, iq)) * dxq(ijq, l))
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDDO
+  !$OMP END DO NOWAIT
+  !ym      ENDIF  ! n0.gt.0
+
+  !   bouclage en latitude
+  ! PRINT*,'Avant bouclage en latitude'
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb + iip1 - 1, ije, iip1
+      u_mq(ij, l) = u_mq(ij - iim, l)
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  ! CRisi: appel récursif de l'advection sur les fils.
+  ! Il faut faire ça avant d'avoir mis à jour q et masse
+
+  do ifils = 1, tracers(iq)%nqDescen
+    ! ! attention: comme Ratio est utilisé comme q dans l'appel
+    ! ! recursif, il doit contenir à lui seul tous les indices de tous
+    ! ! les descendants!
+    iq2 = tracers(iq)%iqDescen(ifils)
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      DO ij = ijb, ije
+        ! ! On a besoin de q et masse seulement entre ijb et ije. On ne
+        ! ! les calcule donc que de ijb à ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
+        if (q(ij, l, iq)>min_qParent) then ! modif 13 nov 2020
+          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
+        else
+          Ratio(ij, l, iq2) = min_ratio
+        endif
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+  enddo !do ifils=1,tracers(iq)%nqDescen
+  do ifils = 1, tracers(iq)%nqChildren
+    iq2 = tracers(iq)%iqDescen(ifils)
+    CALL vlx_loc(Ratio, pente_max, masse, u_mq, ijb_x, ije_x, iq2)
+  enddo
+  ! end CRisi
+
+
+  !   calcul des tENDances
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb + 1, ije
+      ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+      new_m = max(masse(ij, l, iq) + u_m(ij - 1, l) - u_m(ij, l), min_qMass)
+      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + &
+              u_mq(ij - 1, l) - u_mq(ij, l)) &
+              / new_m
+      masse(ij, l, iq) = new_m
+    ENDDO
+    !   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+    DO ij = ijb + iip1 - 1, ije, iip1
+      q(ij - iim, l, iq) = q(ij, l, iq)
+      masse(ij - iim, l, iq) = masse(ij, l, iq)
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  ! ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio
+  ! ! puis on boucle en longitude
+  do ifils = 1, tracers(iq)%nqDescen
+    iq2 = tracers(iq)%iqDescen(ifils)
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      DO ij = ijb + 1, ije
+        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
+      enddo
+      DO ij = ijb + iip1 - 1, ije, iip1
+        q(ij - iim, l, iq2) = q(ij, l, iq2)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+  enddo
+
+END SUBROUTINE vlx_loc
+
+
+SUBROUTINE vly_loc(q, pente_max, masse, masse_adv_v, iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+  ! dq 	       sont des arguments de sortie pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY: nqtot, tracers, & ! CRisi                 &
+          min_qParent, min_qMass, min_ratio ! MVals et CRisi
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u, llm, nqtot), pente_max
+  REAL :: masse_adv_v(ijb_v:ije_v, llm)
+  REAL :: q(ijb_u:ije_u, llm, nqtot), dq(ijb_u:ije_u, llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i, ij, l
+  !
+  REAL :: airej2, airejjm, airescb(iim), airesch(iim)
+  REAL :: dyq(ijb_u:ije_u, llm), dyqv(ijb_v:ije_v), zdvm(ijb_u:ije_u, llm)
+  REAL :: adyqv(ijb_v:ije_v), dyqmax(ijb_u:ije_u)
+  REAL :: qbyv(ijb_v:ije_v, llm)
+
+  REAL :: qpns, qpsn, appn, apps, dyn1, dys1, dyn2, dys2, newmasse, fn, fs
+  ! REAL newq,oldmasse
+  Logical :: extremum, first
+  REAL :: temps0, temps1, temps2, temps3, temps4, temps5, second
+  SAVE temps0, temps1, temps2, temps3, temps4, temps5
+  !$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+  SAVE first
+  !$OMP THREADPRIVATE(first)
+
+  REAL :: convpn, convps, convmpn, convmps
+  real :: massepn, masseps, qpn, qps
+  REAL :: sinlon(iip1), sinlondlon(iip1)
+  REAL :: coslon(iip1), coslondlon(iip1)
+  SAVE sinlon, coslon, sinlondlon, coslondlon
+  !$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+  SAVE airej2, airejjm
+  !$OMP THREADPRIVATE(airej2,airejjm)
+
+  REAL :: Ratio(ijb_u:ije_u, llm, nqtot) ! CRisi
+  INTEGER :: ifils, iq2 ! CRisi
+  !
+  !
+  REAL :: SSUM
+  EXTERNAL  SSUM
+
+  DATA first/.TRUE./
+  DATA temps0, temps1, temps2, temps3, temps4, temps5/0., 0., 0., 0., 0., 0./
+  INTEGER :: ijb, ije
+  INTEGER :: ijbm, ijem
+
+  ijb = ij_begin - 2 * iip1
+  ije = ij_end + 2 * iip1
+  if (pole_nord) ijb = ij_begin
+  if (pole_sud)  ije = ij_end
+
+  IF(first) THEN
+    PRINT*, 'Shema  Amont nouveau  appele dans  Vanleer   '
+    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
+
+  !
+  ! PRINT*,'CALCUL EN LATITUDE'
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    !
+    !   --------------------------------
+    !  CALCUL EN LATITUDE
+    !   --------------------------------
+
+    !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+    !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+    !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+    if (pole_nord) then
+      DO i = 1, iim
+        airescb(i) = aire(i + iip1) * q(i + iip1, l, iq)
+      ENDDO
+      qpns = SSUM(iim, airescb, 1) / airej2
+    endif
+
+    if (pole_sud) then
+      DO i = 1, iim
+        airesch(i) = aire(i + ip1jm - iip1) * q(i + ip1jm - iip1, l, iq)
+      ENDDO
+      qpsn = SSUM(iim, airesch, 1) / airejjm
+    endif
+
+    !   calcul des pentes aux points v
+
+    ijb = ij_begin - 2 * iip1
+    ije = ij_end + iip1
+    if (pole_nord) ijb = ij_begin
+    if (pole_sud)  ije = ij_end - iip1
+
+    ! ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
+    ! ! Si pole sud, entre ij_begin-2*iip1 et ij_end
+    ! ! Si pole Nord, entre ij_begin et ij_end+2*iip1
+    DO ij = ijb, ije
+      dyqv(ij) = q(ij, l, iq) - q(ij + iip1, l, iq)
+      adyqv(ij) = abs(dyqv(ij))
+    ENDDO
+
+
+    !   calcul des pentes aux points scalaires
+    ijb = ij_begin - iip1
+    ije = ij_end + iip1
+    if (pole_nord) ijb = ij_begin + iip1
+    if (pole_sud)  ije = ij_end - iip1
+
+    DO ij = ijb, ije
+      dyq(ij, l) = .5 * (dyqv(ij - iip1) + dyqv(ij))
+      dyqmax(ij) = min(adyqv(ij - iip1), adyqv(ij))
+      dyqmax(ij) = pente_max * dyqmax(ij)
+    ENDDO
+
+    !   calcul des pentes aux poles
+    IF (pole_nord) THEN
+      DO ij = 1, iip1
+        dyq(ij, l) = qpns - q(ij + iip1, l, iq)
+      ENDDO
+
+      dyn1 = 0.
+      dyn2 = 0.
+      DO ij = 1, iim
+        dyn1 = dyn1 + sinlondlon(ij) * dyq(ij, l)
+        dyn2 = dyn2 + coslondlon(ij) * dyq(ij, l)
+      ENDDO
+      DO ij = 1, iip1
+        dyq(ij, l) = dyn1 * sinlon(ij) + dyn2 * coslon(ij)
+      ENDDO
+
+      DO ij = 1, iip1
+        dyq(ij, l) = 0.
+      ENDDO
+      ! ym tout cela ne sert pas a grand chose
+    ENDIF
+
+    IF (pole_sud) THEN
+
+      DO ij = 1, iip1
+        dyq(ip1jm + ij, l) = q(ip1jm + ij - iip1, l, iq) - qpsn
+      ENDDO
+
+      dys1 = 0.
+      dys2 = 0.
+
+      DO ij = 1, iim
+        dys1 = dys1 + sinlondlon(ij) * dyq(ip1jm + ij, l)
+        dys2 = dys2 + coslondlon(ij) * dyq(ip1jm + ij, l)
+      ENDDO
+
+      DO ij = 1, iip1
+        dyq(ip1jm + ij, l) = dys1 * sinlon(ij) + dys2 * coslon(ij)
+      ENDDO
+
+      DO ij = 1, iip1
+        dyq(ip1jm + ij, l) = 0.
+      ENDDO
+      ! ym tout cela ne sert pas a grand chose
+    ENDIF
+
+    !   filtrage de la derivee
+
+    !   calcul des pentes limites aux poles
+    ! ym partie inutile
+    ! goto 8888
+    ! 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
+    ! 8888    continue
+
+
+    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+    !  En memoire de dIFferents tests sur la
+    !  limitation des pentes aux poles.
+    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+    ! PRINT*,dyq(1)
+    ! PRINT*,dyqv(iip1+1)
+    ! appn=abs(dyq(1)/dyqv(iip1+1))
+    ! PRINT*,dyq(ip1jm+1)
+    ! PRINT*,dyqv(ip1jm-iip1+1)
+    ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+    ! DO ij=2,iim
+    !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+    !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+    ! ENDDO
+    ! appn=min(pente_max/appn,1.)
+    ! apps=min(pente_max/apps,1.)
+    !
+    !
+    !   cas ou on a un extremum au pole
+    !
+    ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+    !    &   appn=0.
+    ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+    !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+    !    &   apps=0.
+    !
+    !   limitation des pentes aux poles
+    ! DO ij=1,iip1
+    !    dyq(ij)=appn*dyq(ij)
+    !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+    ! ENDDO
+    !
+    !   test
+    !  DO ij=1,iip1
+    !     dyq(iip1+ij)=0.
+    !     dyq(ip1jm+ij-iip1)=0.
+    !  ENDDO
+    !  DO ij=1,ip1jmp1
+    !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+    !  ENDDO
+    !
+    ! changement 10 07 96
+    ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+    !    &   THEN
+    !    DO ij=1,iip1
+    !       dyqmax(ij)=0.
+    !    ENDDO
+    ! ELSE
+    !    DO ij=1,iip1
+    !       dyqmax(ij)=pente_max*abs(dyqv(ij))
+    !    ENDDO
+    ! ENDIF
+    !
+    ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+    !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+    !    &THEN
+    !    DO ij=ip1jm+1,ip1jmp1
+    !       dyqmax(ij)=0.
+    !    ENDDO
+    ! ELSE
+    !    DO ij=ip1jm+1,ip1jmp1
+    !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+    !    ENDDO
+    ! ENDIF
+    !   fin changement 10 07 96
+    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+    !   calcul des pentes limitees
+    ijb = ij_begin - iip1
+    ije = ij_end + iip1
+    if (pole_nord) ijb = ij_begin + iip1
+    if (pole_sud)  ije = ij_end - iip1
+
+    DO ij = ijb, ije
+      IF(dyqv(ij) * dyqv(ij - iip1)>0.) THEN
+        dyq(ij, l) = sign(min(abs(dyq(ij, l)), dyqmax(ij)), dyq(ij, l))
+      ELSE
+        dyq(ij, l) = 0.
+      ENDIF
+    ENDDO
+
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  ijb = ij_begin - iip1
+  ije = ij_end
+  if (pole_nord) ijb = ij_begin
+  if (pole_sud)  ije = ij_end - iip1
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb, ije
+      IF(masse_adv_v(ij, l)>0) THEN
+        qbyv(ij, l) = q(ij + iip1, l, iq) + dyq(ij + iip1, l) * &
+                0.5 * (1. - masse_adv_v(ij, l) &
+                / masse(ij + iip1, l, iq))
+      ELSE
+        qbyv(ij, l) = q(ij, l, iq) - dyq(ij, l) * &
+                0.5 * (1. + masse_adv_v(ij, l) / masse(ij, l, iq))
+      ENDIF
+      qbyv(ij, l) = masse_adv_v(ij, l) * qbyv(ij, l)
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  ! CRisi: appel récursif de l'advection sur les fils.
+  ! Il faut faire ça avant d'avoir mis à jour q et masse
+  ! write(*,*)'vly 689: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
+
+  ijb = ij_begin - 2 * iip1
+  ije = ij_end + 2 * iip1
+  ijbm = ij_begin - iip1
+  ijem = ij_end + iip1
+  if (pole_nord) ijb = ij_begin
+  if (pole_sud)  ije = ij_end
+  if (pole_nord) ijbm = ij_begin
+  if (pole_sud)  ijem = ij_end
+
+  do ifils = 1, tracers(iq)%nqDescen
+    iq2 = tracers(iq)%iqDescen(ifils)
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      ! ! modif des bornes: CRisi 16 nov 2020
+      ! ! d'abord masse avec bornes corrigées
+      DO ij = ijbm, ijem
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
+      enddo
+
+      ! ! ensuite Ratio avec anciennes bornes
+      DO ij = ijb, ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        if (q(ij, l, iq)>min_qParent) then ! modif 13 nov 2020
+          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
+        else
+          Ratio(ij, l, iq2) = min_ratio
+        endif
+      enddo !DO ij=ijbm,ijem
+    enddo !DO l=1,llm
+    !$OMP END DO NOWAIT
+  enddo
+
+  do ifils = 1, tracers(iq)%nqChildren
+    iq2 = tracers(iq)%iqDescen(ifils)
+    CALL vly_loc(Ratio, pente_max, masse, qbyv, iq2)
+  enddo
+  ! end CRisi
+
+  ijb = ij_begin
+  ije = ij_end
+  if (pole_nord) ijb = ij_begin + iip1
+  if (pole_sud)  ije = ij_end - iip1
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb, ije
+      newmasse = masse(ij, l, iq) &
+              + masse_adv_v(ij, l) - masse_adv_v(ij - iip1, l)
+
+      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + qbyv(ij, l) &
+              - qbyv(ij - iip1, l)) / newmasse
+
+      masse(ij, l, iq) = newmasse
+
+    ENDDO
+
+    if (pole_nord) then
+      convpn = SSUM(iim, qbyv(1, l), 1)
+      convmpn = ssum(iim, masse_adv_v(1, l), 1)
+      massepn = ssum(iim, masse(1, l, iq), 1)
+      qpn = 0.
+      do ij = 1, iim
+        qpn = qpn + masse(ij, l, iq) * q(ij, l, iq)
+      enddo
+      qpn = (qpn + convpn) / (massepn + convmpn)
+      do ij = 1, iip1
+        q(ij, l, iq) = qpn
+      enddo
+    endif
+
+    if (pole_sud) then
+
+      convps = -SSUM(iim, qbyv(ip1jm - iim, l), 1)
+      convmps = -ssum(iim, masse_adv_v(ip1jm - iim, l), 1)
+      masseps = ssum(iim, masse(ip1jm + 1, l, iq), 1)
+      qps = 0.
+      do ij = ip1jm + 1, ip1jmp1 - 1
+        qps = qps + masse(ij, l, iq) * q(ij, l, iq)
+      enddo
+      qps = (qps + convps) / (masseps + convmps)
+      do ij = ip1jm + 1, ip1jmp1
+        q(ij, l, iq) = qps
+      enddo
+    endif
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  ijb = ij_begin
+  ije = ij_end
+  ! if (pole_nord) ijb=ij_begin
+  ! if (pole_sud)  ije=ij_end
+
+  do ifils = 1, tracers(iq)%nqDescen
+    iq2 = tracers(iq)%iqDescen(ifils)
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      DO ij = ijb, ije
+        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+  enddo
+
+
+END SUBROUTINE vly_loc
+
+
+SUBROUTINE vlz_loc(q, pente_max, masse, w, ijb_x, ije_x, iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  !    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  ! dq 	       sont des arguments de sortie pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE vlz_mod
+  USE infotrac, ONLY: nqtot, tracers, & ! CRisi                 &
+          min_qParent, min_qMass, min_ratio ! MVals et CRisi
+
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u, llm, nqtot), pente_max
+  REAL :: q(ijb_u:ije_u, llm, nqtot)
+  REAL :: w(ijb_u:ije_u, llm + 1, nqtot)
+  INTEGER :: iq
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i, ij, l, j, ii
+
+  REAL, DIMENSION(ijb_u:ije_u, llm + 1) :: wresi, morig, qorig, dzqorig
+  INTEGER, DIMENSION(ijb_u:ije_u, llm + 1) :: lorig
+  INTEGER, SAVE :: countcfl
+  !$OMP THREADPRIVATE(countcfl)
+  !
+  REAL :: newmasse
+
+  REAL :: dzqmax
+  REAL :: sigw
+
+  REAL :: temps0, temps1, temps2, temps3, temps4, temps5, second
+  SAVE temps0, temps1, temps2, temps3, temps4, temps5
+  !$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+
+  REAL :: SSUM
+
+  DATA temps0, temps1, temps2, temps3, temps4, temps5/0., 0., 0., 0., 0., 0./
+  INTEGER :: ijb, ije, ijb_x, ije_x
+  LOGICAL, SAVE :: first = .TRUE.
+  !$OMP THREADPRIVATE(first)
+
+  ! !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  ! ! Ces varibles doivent être déclarées en pointer et en save dans
+  ! ! vlz_loc si on veut qu'elles soient vues par tous les threads.
+  INTEGER :: ifils, iq2 ! CRisi
+
+  IF (first) THEN
+    first = .FALSE.
+  ENDIF
+  !    On oriente tout dans le sens de la pression c'est a dire dans le
+  !    sens de W
+
+  ! !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq
+
+  ijb = ijb_x
+  ije = ije_x
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 2, llm
+    DO ij = ijb, ije
+      dzqw(ij, l) = q(ij, l - 1, iq) - q(ij, l, iq)
+      adzqw(ij, l) = abs(dzqw(ij, l))
+    ENDDO
+  ENDDO
+  !$OMP END DO
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 2, llm - 1
+    DO ij = ijb, ije
+      IF(dzqw(ij, l) * dzqw(ij, l + 1)>0.) THEN
+        dzq(ij, l) = 0.5 * (dzqw(ij, l) + dzqw(ij, l + 1))
+      ELSE
+        dzq(ij, l) = 0.
+      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
+  !$OMP END DO NOWAIT
+
+  !$OMP MASTER
+  DO ij = ijb, ije
+    dzq(ij, 1) = 0.
+    dzq(ij, llm) = 0.
+  ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  !--------------------------------------------------------
+  ! On repere les points qui violent le CFL (|w| > masse)
+  !--------------------------------------------------------
+
+  countcfl = 0
+  ! PRINT*,'vlz nouveau'
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 2, llm
+    DO ij = ijb, ije
+      IF((w(ij, l, iq)>0.AND.w(ij, l, iq)>masse(ij, l, iq)) &
+              .OR. (w(ij, l, iq)<=0.AND.ABS(w(ij, l, iq))>masse(ij, l - 1, iq))) &
+              countcfl = countcfl + 1
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  ! ---------------------------------------------------------------
+  !  Identification des mailles ou on viole le CFL : w > masse
+  ! ---------------------------------------------------------------
+
+  IF (countcfl==0) THEN
+
+    ! ---------------------------------------------------------------
+    !   .... calcul des termes d'advection verticale  .......
+    ! Dans le cas où le  |w| < masse partout.
+    ! Version d'origine
+    ! Pourrait etre enleve si on voit que le code plus general
+    ! est aussi rapide
+    ! ---------------------------------------------------------------
+
+    ! calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+    !  !write(*,*) 'vlz 982,ijb,ije=',ijb,ije
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm - 1
+      do  ij = ijb, ije
+        IF(w(ij, l + 1, iq)>0.) THEN
+          sigw = w(ij, l + 1, iq) / masse(ij, l + 1, iq)
+          wq(ij, l + 1, iq) = w(ij, l + 1, iq) * (q(ij, l + 1, iq) &
+                  + 0.5 * (1. - sigw) * dzq(ij, l + 1))
+        ELSE
+          sigw = w(ij, l + 1, iq) / masse(ij, l, iq)
+          wq(ij, l + 1, iq) = w(ij, l + 1, iq) * (q(ij, l, iq) &
+                  - 0.5 * (1. + sigw) * dzq(ij, l))
+        ENDIF
+      ENDDO
+    ENDDO
+    !$OMP END DO NOWAIT
+    ! !write(*,*) 'vlz 1001'
+
+  ELSE ! countcfl>=1
+
+    IF (prt_level>9) THEN
+      WRITE(lunout, *)'vlz passage dans le non local'
+    ENDIF
+    ! ---------------------------------------------------------------
+    !  Debut du traitement du cas ou on viole le CFL : w > masse
+    ! ---------------------------------------------------------------
+
+    ! Initialisation
+
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 2, llm
+      DO ij = ijb, ije
+        wresi(ij, l) = w(ij, l, iq)
+        wq(ij, l, iq) = 0.
+        IF(w(ij, l, iq)>0.) THEN
+          lorig(ij, l) = l
+          morig(ij, l) = masse(ij, l, iq)
+          qorig(ij, l) = q(ij, l, iq)
+          dzqorig(ij, l) = dzq(ij, l)
+        ELSE
+          lorig(ij, l) = l - 1
+          morig(ij, l) = masse(ij, l - 1, iq)
+          qorig(ij, l) = q(ij, l - 1, iq)
+          dzqorig(ij, l) = dzq(ij, l - 1)
+        ENDIF
+      ENDDO
+    ENDDO
+    !$OMP END DO NOWAIT
+
+    ! Reindicage vertical en accumulant les flux sur
+    !  les mailles qui viollent le CFL
+    !  on itère jusqu'à ce que tous les poins satisfassent
+    !  le critère
+    DO WHILE (countcfl>=1)
+      IF (prt_level>9) THEN
+        WRITE(lunout, *)'On viole le CFL Vertical sur ', countcfl, ' pts'
+      ENDIF
+      countcfl = 0
+
+      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 2, llm
+        DO ij = ijb, ije
+          IF (ABS(wresi(ij, l))>morig(ij, l)) THEN
+            countcfl = countcfl + 1
+            ! rm : les 8 lignes ci dessous pourraient sans doute s'ecrire
+            ! avec la fonction sign
+            IF(w(ij, l, iq)>0.) THEN
+              wresi(ij, l) = wresi(ij, l) - morig(ij, l)
+              wq(ij, l, iq) = wq(ij, l, iq) + morig(ij, l) * qorig(ij, l)
+              lorig(ij, l) = lorig(ij, l) + 1
+            ELSE
+              wresi(ij, l) = wresi(ij, l) + morig(ij, l)
+              wq(ij, l, iq) = wq(ij, l, iq) - morig(ij, l) * qorig(ij, l)
+              lorig(ij, l) = lorig(ij, l) - 1
+            ENDIF
+            ! ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage
+            ! ! pour seg fault
+            if (lorig(ij, l)==0) then
+              CALL abort_gcm("vlz in vlsplt_loc", &
+                      "unfixable violation of CFL", 1)
+            endif
+            morig(ij, l) = masse(ij, lorig(ij, l), iq)
+            qorig(ij, l) = q(ij, lorig(ij, l), iq)
+            dzqorig(ij, l) = dzq(ij, lorig(ij, l))
+          ENDIF
+        ENDDO
+      ENDDO
+      !$OMP END DO NOWAIT
+
+    ENDDO ! WHILE (countcfl>=1)
+
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 2, llm
+      do  ij = ijb, ije
+        sigw = wresi(ij, l) / morig(ij, l)
+        IF(w(ij, l, iq)>0.) THEN
+          wq(ij, l, iq) = wq(ij, l, iq) + wresi(ij, l) * (qorig(ij, l) &
+                  + 0.5 * (1. - sigw) * dzqorig(ij, l))
+        ELSE
+          wq(ij, l, iq) = wq(ij, l, iq) + wresi(ij, l) * (qorig(ij, l) &
+                  - 0.5 * (1. + sigw) * dzqorig(ij, l))
+        ENDIF
+      ENDDO
+    ENDDO
+    !$OMP END DO NOWAIT
+
+  ENDIF ! councfl=0
+
+
+
+  !$OMP MASTER
+  DO ij = ijb, ije
+    wq(ij, llm + 1, iq) = 0.
+    wq(ij, 1, iq) = 0.
+  ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  ! CRisi: appel récursif de l'advection sur les fils.
+  ! Il faut faire ça avant d'avoir mis à jour q et masse
+  ! write(*,*)'vlsplt 942: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
+  do ifils = 1, tracers(iq)%nqDescen
+    iq2 = tracers(iq)%iqDescen(ifils)
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      DO ij = ijb, ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
+        if (q(ij, l, iq)>min_qParent) then
+          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
+        else
+          Ratio(ij, l, iq2) = min_ratio
+        endif
+        ! !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015
+        w(ij, l, iq2) = wq(ij, l, iq)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+  enddo
+  !$OMP BARRIER
+
+  do ifils = 1, tracers(iq)%nqChildren
+    iq2 = tracers(iq)%iqDescen(ifils)
+    CALL vlz_loc(Ratio, pente_max, masse, w, ijb_x, ije_x, iq2)
+  enddo
+  ! end CRisi
+
+  ! CRisi: On rajoute ici une barrière car on veut être sur que tous les
+  ! wq soient synchronisés
+
+  !$OMP BARRIER
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+    DO ij = ijb, ije
+      newmasse = masse(ij, l, iq) + w(ij, l + 1, iq) - w(ij, l, iq)
+      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) &
+              + wq(ij, l + 1, iq) - wq(ij, l, iq)) &
+              / newmasse
+      masse(ij, l, iq) = newmasse
+    ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  do ifils = 1, tracers(iq)%nqDescen
+    iq2 = tracers(iq)%iqDescen(ifils)
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+      DO ij = ijb, ije
+        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+  enddo
+
+
+END SUBROUTINE vlz_loc
+
+
+
+
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltgen_loc.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltgen_loc.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltgen_loc.F90	(revision 5105)
@@ -458,4 +458,4 @@
 
   ! !write(*,*) 'vlspltgen 597: sortie'
-  RETURN
+
 END SUBROUTINE vlspltgen_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltqs_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltqs_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,838 +1,0 @@
-
-!     $Id$
-
-      SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
-c
-c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
-c
-c    ********************************************************************
-c     Shema  d''advection " pseudo amont " .
-c    ********************************************************************
-c
-c   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE infotrac, ONLY: nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi7
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL u_m( ijb_u:ije_u,llm )
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      REAL qsat(ijb_u:ije_u,llm)
-      INTEGER iq ! CRisi
-c
-c      Local 
-c   ---------
-c
-      INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju
-      INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
-c
-      REAL new_m,zu_m,zdum(ijb_u:ije_u,llm)
-      REAL dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
-      REAL zz(ijb_u:ije_u)
-      REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
-      REAL u_mq(ijb_u:ije_u,llm)
-      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      INTEGER ifils,iq2 ! CRisi
-
-
-      REAL      SSUM
-
-
-      INTEGER ijb,ije,ijb_x,ije_x
-      
-      !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
-!     &   iq,ijb_x
-
-c   calcul de la pente a droite et a gauche de la maille
-
-c      ijb=ij_begin
-c      ije=ij_end
-
-      ijb=ijb_x
-      ije=ije_x
-        
-      if (pole_nord.and.ijb==1) ijb=ijb+iip1
-      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
-      
-      IF (pente_max>-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
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-         DO l = 1, llm
-            DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
-            ENDDO
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqu(ij)=dxqu(ij-iim)
-c              sigu(ij)=sigu(ij-iim)
-            ENDDO
-
-            DO ij=ijb,ije
-               adxqu(ij)=abs(dxqu(ij))
-            ENDDO
-
-c   calcul de la pente maximum dans la maille en valeur absolue
-
-            DO ij=ijb+1,ije
-               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=ijb+iip1-1,ije,iip1
-               dxqmax(ij-iim,l)=dxqmax(ij,l)
-            ENDDO
-
-            DO ij=ijb+1,ije
-               IF(dxqu(ij-1)*dxqu(ij)>0) THEN
-                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
-               ELSE
-c   extremum local
-                  dxq(ij,l)=0.
-               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
-c$OMP END DO NOWAIT
-
-      ELSE ! (pente_max.lt.-1.e-5)
-
-c   Pentes produits:
-c   ----------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-         DO l = 1, llm
-            DO ij=ijb,ije-1
-               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
-            ENDDO
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqu(ij)=dxqu(ij-iim)
-            ENDDO
-
-            DO ij=ijb+1,ije
-               zz(ij)=dxqu(ij-1)*dxqu(ij)
-               zz(ij)=zz(ij)+zz(ij)
-               IF(zz(ij)>0) THEN
-                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
-               ELSE
-c   extremum local
-                  dxq(ij,l)=0.
-               ENDIF
-            ENDDO
-
-         ENDDO
-c$OMP END DO NOWAIT
-      ENDIF ! (pente_max.lt.-1.e-5)
-
-c   bouclage de la pente en iip1:
-c   -----------------------------
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb+iip1-1,ije,iip1
-            dxq(ij-iim,l)=dxq(ij,l)
-         ENDDO
-
-         DO ij=ijb,ije
-            iadvplus(ij,l)=0
-         ENDDO
-
-      ENDDO
-c$OMP END DO NOWAIT
-      
-      if (pole_nord) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm      
-          iadvplus(1:iip1,l)=0
-        ENDDO
-c$OMP END DO NOWAIT
-      endif
-      
-      if (pole_sud)  THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm 
-          iadvplus(ip1jm+1:ip1jmp1,l)=0
-        ENDDO
-c$OMP END DO NOWAIT
-      endif
-              
-c   calcul des flux a gauche et a droite
-c   on cumule le flux correspondant a toutes les mailles dont la masse
-c   au travers de la paroi pENDant le pas de temps.
-c   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       DO ij=ijb,ije-1
-          IF (u_m(ij,l)>0.) THEN
-             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
-             u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
-          ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
-             u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
-          ENDIF
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-
-c   detection des points ou on advecte plus que la masse de la
-c   maille
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb,ije-1
-            IF(zdum(ij,l)<0) THEN
-               iadvplus(ij,l)=1
-               u_mq(ij,l)=0.
-            ENDIF
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       DO ij=ijb+iip1-1,ije,iip1
-          iadvplus(ij,l)=iadvplus(ij-iim,l)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-
-
-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   pas d'influence de la pression saturante (pour l'instant)
-
-c  calcul du nombre de maille sur lequel on advecte plus que la maille.
-
-      n0=0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         nl(l)=0
-         DO ij=ijb,ije
-            nl(l)=nl(l)+iadvplus(ij,l)
-         ENDDO
-         n0=n0+nl(l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-cym ATTENTION ICI en OpenMP reduction pas forcement necessaire
-cym      IF(n0.gt.1) THEN
-cym        IF(n0.gt.0) THEN
-ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
-ccc     &       ,'contenu de la maille : ',n0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-            IF(nl(l)>0) THEN
-               iju=0
-c   indicage des mailles concernees par le traitement special
-               DO ij=ijb,ije
-                  IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
-                     iju=iju+1
-                     indu(iju)=ij
-                  ENDIF
-               ENDDO
-               niju=iju
-               !PRINT*,'vlxqs 280: 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>0.) THEN
-                     ijq=ij
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(zu_m>masse(ijq,l,iq))
-                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
-     &                     *masse(ijq,l,iq) 
-                        zu_m=zu_m-masse(ijq,l,iq)
-                        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,iq)
-     &                 +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
-                  ELSE
-                     ijq=ij+1
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(-zu_m>masse(ijq,l,iq))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
-     &                   *masse(ijq,l,iq)
-                        zu_m=zu_m+masse(ijq,l,iq)
-                        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,iq)-
-     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
-                  ENDIF
-               ENDDO
-            ENDIF
-         ENDDO
-c$OMP END DO NOWAIT
-cym      ENDIF  ! n0.gt.0 
-
-
-
-c   bouclage en latitude
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        DO ij=ijb+iip1-1,ije,iip1
-           u_mq(ij,l)=u_mq(ij-iim,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! CRisi: appel recursif de l'advection sur les fils.
-! Il faut faire ca avant d'avoir mis a jour q et masse
-      !write(*,*) 'vlspltqs 336: iq,ijb_x,nqChildren(iq)=',
-!     &     iq,ijb_x,tracers(iq)%nqChildren
-
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          DO ij=ijb,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-            if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio
-            endif 
-          enddo   
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
-        CALL vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
-      enddo
-! end CRisi
-
-      !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x   
-
-c   calcul des tendances
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb+1,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
-     &      u_mq(ij-1,l)-u_mq(ij,l))
-     &      /new_m
-            masse(ij,l,iq)=new_m
-         ENDDO
-c   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
-         DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l,iq)=q(ij,l,iq)
-            masse(ij-iim,l,iq)=masse(ij,l,iq)
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          DO ij=ijb+1,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
-          enddo
-          DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l,iq2)=q(ij,l,iq2)
-          enddo ! DO ij=ijb+iip1-1,ije,iip1
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-      !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
-
-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,iq),iip1,masse(iip2,1,iq),iip1)
-
-
-      RETURN
-      END
-      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
-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     qsat                est   un argument de sortie pour le s-pg ....
-c
-c
-c   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE infotrac, ONLY: nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
-      USE comconst_mod, ONLY: pi
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "iniprint.h"  
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL masse_adv_v( ijb_v:ije_v,llm)
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      REAL qsat(ijb_u:ije_u,llm)
-      INTEGER iq ! CRisi
-c
-c      Local 
-c   ---------
-c
-      INTEGER i,ij,l
-c
-      REAL airej2,airejjm,airescb(iim),airesch(iim)
-      REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
-      REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
-      REAL qbyv(ijb_v:ije_v,llm,nqtot)
-
-      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
-c     REAL newq,oldmasse
-      Logical first
-      SAVE first
-c$OMP THREADPRIVATE(first)
-      REAL convpn,convps,convmpn,convmps
-      REAL sinlon(iip1),sinlondlon(iip1)
-      REAL coslon(iip1),coslondlon(iip1)
-      SAVE sinlon,coslon,sinlondlon,coslondlon
-      SAVE airej2,airejjm
-c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
-c$OMP THREADPRIVATE(airej2,airejjm)
-c
-c
-      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      INTEGER ifils,iq2 ! CRisi
-
-      DATA first/.TRUE./
-      INTEGER ijb,ije
-      INTEGER ijbm,ijem
-
-      REAL ssum
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1  
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-      ij=3525
-      l=3
-      if ((ij>=ijb).and.(ij<=ije)) then
-        !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
-!     &             ij,l,iq,ijb,q(ij,l,:)
-      endif  
-
-      IF(first) THEN
-         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
-         PRINT*,'vlyqs_loc, iq=',iq
-         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
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      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.
-
-      if (pole_nord) then
-        DO i = 1, iim
-          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
-        ENDDO
-        qpns   = SSUM( iim,  airescb ,1 ) / airej2
-      endif
-      
-      if (pole_sud) then
-        DO i = 1, iim
-          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
-        ENDDO
-        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
-      endif
-
-
-c   calcul des pentes aux points v
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij=ijb,ije
-         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
-         adyqv(ij)=abs(dyqv(ij))
-      ENDDO
-
-
-c   calcul des pentes aux points scalaires
-
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij=ijb,ije
-         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
-         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
-         dyqmax(ij)=pente_max*dyqmax(ij)
-      ENDDO
-      
-      IF (pole_nord) THEN
-
-c   calcul des pentes aux poles
-        DO ij=1,iip1
-           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
-        ENDDO
-
-c   filtrage de la derivee        
-        dyn1=0.
-        dyn2=0.
-        DO ij=1,iim
-          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
-          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
-        ENDDO
-        DO ij=1,iip1
-          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
-        ENDDO
-
-c   calcul des pentes limites aux poles
-        fn=1.
-        DO ij=1,iim
-          IF(pente_max*adyqv(ij)<abs(dyq(ij,l))) THEN
-            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
-          ENDIF
-        ENDDO
-      
-        DO ij=1,iip1
-         dyq(ij,l)=fn*dyq(ij,l)
-        ENDDO
-          
-      ENDIF
-      
-      IF (pole_sud) THEN
-
-        DO ij=1,iip1
-           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
-        ENDDO
-
-        dys1=0.
-        dys2=0.
-
-        DO ij=1,iim
-          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
-          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
-        ENDDO
-
-        DO ij=1,iip1
-          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
-        ENDDO
-        
-c   calcul des pentes limites aux poles        
-        fs=1.
-        DO ij=1,iim
-        IF(pente_max*adyqv(ij+ip1jm-iip1)<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(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
-        ENDDO
-        
-      ENDIF
-
-
-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     appn=abs(dyq(1)/dyqv(iip1+1))
-C     PRINT*,dyq(ip1jm+1)
-C     PRINT*,dyqv(ip1jm-iip1+1)
-C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
-C     DO ij=2,iim
-C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
-C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
-C     ENDDO
-C     appn=min(pente_max/appn,1.)
-C     apps=min(pente_max/apps,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    &   appn=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    &   apps=0.
-C
-C   limitation des pentes aux poles
-C     DO ij=1,iip1
-C        dyq(ij)=appn*dyq(ij)
-C        dyq(ip1jm+ij)=apps*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
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-      DO ij=ijb,ije
-         IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
-            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
-         ELSE
-            dyq(ij,l)=0.
-         ENDIF
-      ENDDO
-
-      ENDDO
-c$OMP END DO NOWAIT
-
-      ijb=ij_begin-iip1
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       DO ij=ijb,ije
-         IF( masse_adv_v(ij,l)>0. ) THEN
-           qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
-     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
-     ,      /masse(ij+iip1,l,iq)))
-         ELSE
-              qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
-         ENDIF
-          qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! CRisi: appel recursif de l'advection sur les fils.
-! Il faut faire ca avant d'avoir mis a jour q et masse
-!     write(*,*)'vlyqs 689: iq,nqChildren(iq)=',iq,
-!    &             tracers(iq)%nqChildren
-      
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1
-      ijbm=ij_begin-iip1
-      ijem=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end  
-      if (pole_nord) ijbm=ij_begin
-      if (pole_sud)  ijem=ij_end
-
-      !write(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
-      !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
-      !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          ! modif des bornes: CRisi 16 nov 2020
-          ! d'abord masse avec bornes corrigees
-          DO ij=ijbm,ijem 
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-          enddo !DO ij=ijbm,ijem 
-
-          ! ensuite Ratio avec anciennes bornes
-          DO ij=ijb,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            !write(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
-            if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio   
-            endif
-          enddo !DO ij=ijbm,ijem
-        enddo !DO l=1,llm
-c$OMP END DO NOWAIT
-      enddo
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
-        CALL vly_loc(Ratio,pente_max,masse,qbyv,iq2)
-      enddo
-
-        
-! end CRisi
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-         DO ij=ijb,ije
-            newmasse=masse(ij,l,iq)
-     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq)
-     &         -qbyv(ij-iip1,l,iq))/newmasse
-            masse(ij,l,iq)=newmasse
-         ENDDO
-c.-. ancienne version
-
-         IF (pole_nord) THEN
-
-           convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
-           convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
-           DO ij = 1,iip1
-              newmasse=masse(ij,l,iq)+convmpn*aire(ij)
-              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
-     &                 newmasse
-              masse(ij,l,iq)=newmasse
-           ENDDO
-         
-         ENDIF
-         
-         IF (pole_sud) THEN
-         
-           convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),iq,1)/apols  ! /!\ called with 4 args ???
-           convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
-           DO ij = ip1jm+1,ip1jmp1
-              newmasse=masse(ij,l,iq)+convmps*aire(ij)
-              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
-     &                 newmasse
-              masse(ij,l,iq)=newmasse
-           ENDDO
-         
-         ENDIF
-c.-. fin ancienne version
-
-c._. nouvelle version
-c        convpn=SSUM(iim,qbyv(1,l,iq),1)
-c        convmpn=ssum(iim,masse_adv_v(1,l),1)
-c        oldmasse=ssum(iim,masse(1,l,iq),1)
-c        newmasse=oldmasse+convmpn
-c        newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
-c        newmasse=newmasse/apoln
-c        DO ij = 1,iip1
-c           q(ij,l,iq)=newq
-c           masse(ij,l,iq)=newmasse*aire(ij)
-c        ENDDO
-c        convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
-c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
-c        oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
-c        newmasse=oldmasse+convmps
-c        newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
-c        newmasse=newmasse/apols
-c        DO ij = ip1jm+1,ip1jmp1
-c           q(ij,l,iq)=newq
-c           masse(ij,l,iq)=newmasse*aire(ij)
-c        ENDDO
-c._. fin nouvelle version
-      ENDDO
-c$OMP END DO NOWAIT
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      ijb=ij_begin
-      ije=ij_end
-!      if (pole_nord) ijb=ij_begin+iip1
-!      if (pole_sud)  ije=ij_end-iip1
-  
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          DO ij=ijb,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltqs_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltqs_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltqs_loc.f90	(revision 5105)
@@ -0,0 +1,838 @@
+
+! $Id$
+
+SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d''advection " pseudo amont " .
+  !    ********************************************************************
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY: nqtot,tracers, & ! CRisi                 &
+        min_qParent,min_qMass,min_ratio ! MVals et CRisi7
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
+  REAL :: u_m( ijb_u:ije_u,llm )
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: qsat(ijb_u:ije_u,llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l,j,i,iju,ijq,indu(ijnb_u),niju
+  INTEGER :: n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
+  !
+  REAL :: new_m,zu_m,zdum(ijb_u:ije_u,llm)
+  REAL :: dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
+  REAL :: zz(ijb_u:ije_u)
+  REAL :: adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
+  REAL :: u_mq(ijb_u:ije_u,llm)
+  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  INTEGER :: ifils,iq2 ! CRisi
+
+
+  REAL :: SSUM
+
+
+  INTEGER :: ijb,ije,ijb_x,ije_x
+
+  ! !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
+  ! &   iq,ijb_x
+
+  !   calcul de la pente a droite et a gauche de la maille
+
+  !  ijb=ij_begin
+  !  ije=ij_end
+
+  ijb=ijb_x
+  ije=ije_x
+
+  if (pole_nord.and.ijb==1) ijb=ijb+iip1
+  if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+
+  IF (pente_max>-1.e-5) THEN
+  ! IF (pente_max.gt.10) THEN
+
+  !   calcul des pentes avec limitation, Van Leer scheme I:
+  !   -----------------------------------------------------
+
+  !   calcul de la pente aux points u
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        DO ij=ijb,ije-1
+           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
+        ENDDO
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqu(ij)=dxqu(ij-iim)
+           ! sigu(ij)=sigu(ij-iim)
+        ENDDO
+
+        DO ij=ijb,ije
+           adxqu(ij)=abs(dxqu(ij))
+        ENDDO
+
+  !   calcul de la pente maximum dans la maille en valeur absolue
+
+        DO ij=ijb+1,ije
+           dxqmax(ij,l)=pente_max* &
+                 min(adxqu(ij-1),adxqu(ij))
+  ! limitation subtile
+  !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+
+
+        ENDDO
+
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqmax(ij-iim,l)=dxqmax(ij,l)
+        ENDDO
+
+        DO ij=ijb+1,ije
+           IF(dxqu(ij-1)*dxqu(ij)>0) THEN
+              dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+           ELSE
+  !   extremum local
+              dxq(ij,l)=0.
+           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
+!$OMP END DO NOWAIT
+
+  ELSE ! (pente_max.lt.-1.e-5)
+
+  !   Pentes produits:
+  !   ----------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        DO ij=ijb,ije-1
+           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
+        ENDDO
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqu(ij)=dxqu(ij-iim)
+        ENDDO
+
+        DO ij=ijb+1,ije
+           zz(ij)=dxqu(ij-1)*dxqu(ij)
+           zz(ij)=zz(ij)+zz(ij)
+           IF(zz(ij)>0) THEN
+              dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+           ELSE
+  !   extremum local
+              dxq(ij,l)=0.
+           ENDIF
+        ENDDO
+
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDIF ! (pente_max.lt.-1.e-5)
+
+  !   bouclage de la pente en iip1:
+  !   -----------------------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb+iip1-1,ije,iip1
+        dxq(ij-iim,l)=dxq(ij,l)
+     ENDDO
+
+     DO ij=ijb,ije
+        iadvplus(ij,l)=0
+     ENDDO
+
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_nord) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      iadvplus(1:iip1,l)=0
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  if (pole_sud)  THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      iadvplus(ip1jm+1:ip1jmp1,l)=0
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  !   calcul des flux a gauche et a droite
+  !   on cumule le flux correspondant a toutes les mailles dont la masse
+  !   au travers de la paroi pENDant le pas de temps.
+  !   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije-1
+      IF (u_m(ij,l)>0.) THEN
+         zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
+         u_mq(ij,l)=u_m(ij,l)* &
+               min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+      ELSE
+         zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
+         u_mq(ij,l)=u_m(ij,l)* &
+               min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+      ENDIF
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+
+  !   detection des points ou on advecte plus que la masse de la
+  !   maille
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije-1
+        IF(zdum(ij,l)<0) THEN
+           iadvplus(ij,l)=1
+           u_mq(ij,l)=0.
+        ENDIF
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb+iip1-1,ije,iip1
+      iadvplus(ij,l)=iadvplus(ij-iim,l)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+
+
+  !   traitement special pour le cas ou on advecte en longitude plus que le
+  !   contenu de la maille.
+  !   cette partie est mal vectorisee.
+
+  !   pas d'influence de la pression saturante (pour l'instant)
+
+  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+  n0=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     nl(l)=0
+     DO ij=ijb,ije
+        nl(l)=nl(l)+iadvplus(ij,l)
+     ENDDO
+     n0=n0+nl(l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !ym ATTENTION ICI en OpenMP reduction pas forcement necessaire
+  !ym      IF(n0.gt.1) THEN
+  !ym        IF(n0.gt.0) THEN
+  !cc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+  !cc     &       ,'contenu de la maille : ',n0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llm
+        IF(nl(l)>0) THEN
+           iju=0
+  !   indicage des mailles concernees par le traitement special
+           DO ij=ijb,ije
+              IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
+                 iju=iju+1
+                 indu(iju)=ij
+              ENDIF
+           ENDDO
+           niju=iju
+           ! !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
+
+  !  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>0.) THEN
+                 ijq=ij
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(zu_m>masse(ijq,l,iq))
+                    u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) &
+                          *masse(ijq,l,iq)
+                    zu_m=zu_m-masse(ijq,l,iq)
+                    i=mod(i-2+iim,iim)+1
+                    ijq=(j-1)*iip1+i
+                 ENDDO
+  !   ajout de la maille non completement advectee
+                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq) &
+                       +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+              ELSE
+                 ijq=ij+1
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(-zu_m>masse(ijq,l,iq))
+                    u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
+                          *masse(ijq,l,iq)
+                    zu_m=zu_m+masse(ijq,l,iq)
+                    i=mod(i,iim)+1
+                    ijq=(j-1)*iip1+i
+                 ENDDO
+  !   ajout de la maille non completement advectee
+                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
+                       0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+              ENDIF
+           ENDDO
+        ENDIF
+     ENDDO
+!$OMP END DO NOWAIT
+  !ym      ENDIF  ! n0.gt.0
+
+
+
+  !   bouclage en latitude
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb+iip1-1,ije,iip1
+       u_mq(ij,l)=u_mq(ij-iim,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! CRisi: appel recursif de l'advection sur les fils.
+  ! Il faut faire ca avant d'avoir mis a jour q et masse
+  ! !write(*,*) 'vlspltqs 336: iq,ijb_x,nqChildren(iq)=',
+  ! &     iq,ijb_x,tracers(iq)%nqChildren
+
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+        if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
+          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+        else
+          Ratio(ij,l,iq2)=min_ratio
+        endif
+      enddo
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+  do ifils=1,tracers(iq)%nqChildren
+    iq2=tracers(iq)%iqDescen(ifils)
+    ! !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
+    CALL vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
+  enddo
+  ! end CRisi
+
+  ! !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x
+
+  !   calcul des tendances
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb+1,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
+        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
+              u_mq(ij-1,l)-u_mq(ij,l)) &
+              /new_m
+        masse(ij,l,iq)=new_m
+     ENDDO
+  !   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
+     DO ij=ijb+iip1-1,ije,iip1
+        q(ij-iim,l,iq)=q(ij,l,iq)
+        masse(ij-iim,l,iq)=masse(ij,l,iq)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb+1,ije
+        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+      enddo
+      DO ij=ijb+iip1-1,ije,iip1
+        q(ij-iim,l,iq2)=q(ij,l,iq2)
+      enddo ! DO ij=ijb+iip1-1,ije,iip1
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+
+  ! !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
+
+  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
+
+
+
+END SUBROUTINE vlxqs_loc
+SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+  ! qsat                est   un argument de sortie pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY: nqtot,tracers, & ! CRisi                 &
+        min_qParent,min_qMass,min_ratio ! MVals et CRisi
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
+  REAL :: masse_adv_v( ijb_v:ije_v,llm)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: qsat(ijb_u:ije_u,llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i,ij,l
+  !
+  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
+  REAL :: dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
+  REAL :: adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
+  REAL :: qbyv(ijb_v:ije_v,llm,nqtot)
+
+  REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+  ! REAL newq,oldmasse
+  Logical :: first
+  SAVE first
+!$OMP THREADPRIVATE(first)
+  REAL :: convpn,convps,convmpn,convmps
+  REAL :: sinlon(iip1),sinlondlon(iip1)
+  REAL :: coslon(iip1),coslondlon(iip1)
+  SAVE sinlon,coslon,sinlondlon,coslondlon
+  SAVE airej2,airejjm
+!$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+!$OMP THREADPRIVATE(airej2,airejjm)
+  !
+  !
+  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  INTEGER :: ifils,iq2 ! CRisi
+
+  DATA first/.TRUE./
+  INTEGER :: ijb,ije
+  INTEGER :: ijbm,ijem
+
+  REAL :: ssum
+
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  ij=3525
+  l=3
+  if ((ij>=ijb).and.(ij<=ije)) then
+    ! !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
+  ! &             ij,l,iq,ijb,q(ij,l,:)
+  endif
+
+  IF(first) THEN
+     PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+     PRINT*,'vlyqs_loc, iq=',iq
+     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
+
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+  !
+  !   --------------------------------
+  !  CALCUL EN LATITUDE
+  !   --------------------------------
+
+  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+  if (pole_nord) then
+    DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+    ENDDO
+    qpns   = SSUM( iim,  airescb ,1 ) / airej2
+  endif
+
+  if (pole_sud) then
+    DO i = 1, iim
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
+    ENDDO
+    qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+  endif
+
+
+  !   calcul des pentes aux points v
+
+  ijb=ij_begin-2*iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+     dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
+     adyqv(ij)=abs(dyqv(ij))
+  ENDDO
+
+
+  !   calcul des pentes aux points scalaires
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+     dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+     dyqmax(ij)=pente_max*dyqmax(ij)
+  ENDDO
+
+  IF (pole_nord) THEN
+
+  !   calcul des pentes aux poles
+    DO ij=1,iip1
+       dyq(ij,l)=qpns-q(ij+iip1,l,iq)
+    ENDDO
+
+  !   filtrage de la derivee
+    dyn1=0.
+    dyn2=0.
+    DO ij=1,iim
+      dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+      dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+    ENDDO
+    DO ij=1,iip1
+      dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+    ENDDO
+
+  !   calcul des pentes limites aux poles
+    fn=1.
+    DO ij=1,iim
+      IF(pente_max*adyqv(ij)<abs(dyq(ij,l))) THEN
+        fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+      ENDIF
+    ENDDO
+
+    DO ij=1,iip1
+     dyq(ij,l)=fn*dyq(ij,l)
+    ENDDO
+
+  ENDIF
+
+  IF (pole_sud) THEN
+
+    DO ij=1,iip1
+       dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
+    ENDDO
+
+    dys1=0.
+    dys2=0.
+
+    DO ij=1,iim
+      dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+      dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+    ENDDO
+
+    DO ij=1,iip1
+      dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+    ENDDO
+
+  !   calcul des pentes limites aux poles
+    fs=1.
+    DO ij=1,iim
+    IF(pente_max*adyqv(ij+ip1jm-iip1)<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(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+    ENDDO
+
+  ENDIF
+
+
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !  En memoire de dIFferents tests sur la
+  !  limitation des pentes aux poles.
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  ! PRINT*,dyq(1)
+  ! PRINT*,dyqv(iip1+1)
+  ! appn=abs(dyq(1)/dyqv(iip1+1))
+  ! PRINT*,dyq(ip1jm+1)
+  ! PRINT*,dyqv(ip1jm-iip1+1)
+  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+  ! DO ij=2,iim
+  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+  ! ENDDO
+  ! appn=min(pente_max/appn,1.)
+  ! apps=min(pente_max/apps,1.)
+  !
+  !
+  !   cas ou on a un extremum au pole
+  !
+  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   appn=0.
+  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &   apps=0.
+  !
+  !   limitation des pentes aux poles
+  ! DO ij=1,iip1
+  !    dyq(ij)=appn*dyq(ij)
+  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+  ! ENDDO
+  !
+  !   test
+  !  DO ij=1,iip1
+  !     dyq(iip1+ij)=0.
+  !     dyq(ip1jm+ij-iip1)=0.
+  !  ENDDO
+  !  DO ij=1,ip1jmp1
+  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+  !  ENDDO
+  !
+  ! changement 10 07 96
+  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   THEN
+  !    DO ij=1,iip1
+  !       dyqmax(ij)=0.
+  !    ENDDO
+  ! ELSE
+  !    DO ij=1,iip1
+  !       dyqmax(ij)=pente_max*abs(dyqv(ij))
+  !    ENDDO
+  ! ENDIF
+  !
+  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &THEN
+  !    DO ij=ip1jm+1,ip1jmp1
+  !       dyqmax(ij)=0.
+  !    ENDDO
+  ! ELSE
+  !    DO ij=ip1jm+1,ip1jmp1
+  !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+  !    ENDDO
+  ! ENDIF
+  !   fin changement 10 07 96
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+  !   calcul des pentes limitees
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+     IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
+        dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+     ELSE
+        dyq(ij,l)=0.
+     ENDIF
+  ENDDO
+
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije
+     IF( masse_adv_v(ij,l)>0. ) THEN
+       qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  + &
+             dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l) &
+             /masse(ij+iip1,l,iq)))
+     ELSE
+          qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) * &
+                0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
+     ENDIF
+      qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! CRisi: appel recursif de l'advection sur les fils.
+  ! Il faut faire ca avant d'avoir mis a jour q et masse
+  ! write(*,*)'vlyqs 689: iq,nqChildren(iq)=',iq,
+  !    &             tracers(iq)%nqChildren
+
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  ijbm=ij_begin-iip1
+  ijem=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  if (pole_nord) ijbm=ij_begin
+  if (pole_sud)  ijem=ij_end
+
+  ! !write(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
+  ! !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
+  ! !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      ! ! modif des bornes: CRisi 16 nov 2020
+      ! ! d'abord masse avec bornes corrigees
+      DO ij=ijbm,ijem
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+      enddo !DO ij=ijbm,ijem
+
+      ! ! ensuite Ratio avec anciennes bornes
+      DO ij=ijb,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        ! !write(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
+        if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
+          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+        else
+          Ratio(ij,l,iq2)=min_ratio
+        endif
+      enddo !DO ij=ijbm,ijem
+    enddo !DO l=1,llm
+!$OMP END DO NOWAIT
+  enddo
+  do ifils=1,tracers(iq)%nqChildren
+    iq2=tracers(iq)%iqDescen(ifils)
+    ! !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
+    CALL vly_loc(Ratio,pente_max,masse,qbyv,iq2)
+  enddo
+
+
+  ! end CRisi
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        newmasse=masse(ij,l,iq) &
+              +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq) &
+              -qbyv(ij-iip1,l,iq))/newmasse
+        masse(ij,l,iq)=newmasse
+     ENDDO
+  !.-. ancienne version
+
+     IF (pole_nord) THEN
+
+       convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
+       convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+       DO ij = 1,iip1
+          newmasse=masse(ij,l,iq)+convmpn*aire(ij)
+          q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/ &
+                newmasse
+          masse(ij,l,iq)=newmasse
+       ENDDO
+
+     ENDIF
+
+     IF (pole_sud) THEN
+
+       convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),iq,1)/apols  ! /!\ called with 4 args ???
+       convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+       DO ij = ip1jm+1,ip1jmp1
+          newmasse=masse(ij,l,iq)+convmps*aire(ij)
+          q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/ &
+                newmasse
+          masse(ij,l,iq)=newmasse
+       ENDDO
+
+     ENDIF
+  !.-. fin ancienne version
+
+  !._. nouvelle version
+     ! convpn=SSUM(iim,qbyv(1,l,iq),1)
+     ! convmpn=ssum(iim,masse_adv_v(1,l),1)
+     ! oldmasse=ssum(iim,masse(1,l,iq),1)
+     ! newmasse=oldmasse+convmpn
+     ! newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
+     ! newmasse=newmasse/apoln
+     ! DO ij = 1,iip1
+     !    q(ij,l,iq)=newq
+     !    masse(ij,l,iq)=newmasse*aire(ij)
+     ! ENDDO
+     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
+     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+     ! oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
+     ! newmasse=oldmasse+convmps
+     ! newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
+     ! newmasse=newmasse/apols
+     ! DO ij = ip1jm+1,ip1jmp1
+     !    q(ij,l,iq)=newq
+     !    masse(ij,l,iq)=newmasse*aire(ij)
+     ! ENDDO
+  !._. fin nouvelle version
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  ijb=ij_begin
+  ije=ij_end
+   ! if (pole_nord) ijb=ij_begin+iip1
+   ! if (pole_sud)  ije=ij_end-iip1
+
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb,ije
+        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+      enddo
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+
+
+
+END SUBROUTINE vlyqs_loc
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/wrgrads.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/wrgrads.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/wrgrads.f90	(revision 5105)
@@ -120,5 +120,5 @@
   endif ! writectl
 
-  return
+
 
 END SUBROUTINE wrgrads
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/writedynav_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writedynav_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,218 +1,0 @@
-
-! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-
-      SUBROUTINE writedynav_loc( time, vcov, ucov,teta,ppk,phi,q,
-     .                           masse,ps,phis)
-
-! This routine needs IOIPSL
-      USE ioipsl
-      USE parallel_lmdz
-      USE misc_mod
-      USE infotrac, ONLY: nqtot
-      use com_io_dyn_mod, ONLY: histaveid,histvaveid,histuaveid
-      USE comconst_mod, ONLY: cpp
-      USE temps_mod, ONLY: itau_dyn
-      
-      implicit none
-
-C
-C   Ecriture du fichier histoire au format IOIPSL
-C
-C   Appels succesifs des routines: histwrite
-C
-C   Entree:
-C      histid: ID du fichier histoire
-C      time: temps de l'ecriture
-C      vcov: vents v covariants
-C      ucov: vents u covariants
-C      teta: temperature potentielle
-C      phi : geopotentiel instantane
-C      q   : traceurs
-C      masse: masse
-C      ps   :pression au sol
-C      phis : geopotentiel au sol
-C      
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C
-C   Arguments
-C
-
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
-      REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-      REAL ppk(ijb_u:ije_u,llm)                  
-      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
-      REAL phis(ijb_u:ije_u)                  
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      integer time
-
-
-! This routine needs IOIPSL
-C   Variables locales
-C
-      INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
-      INTEGER :: iq, ii, ll
-      REAL,SAVE,ALLOCATABLE :: tm(:,:)
-      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
-      logical ok_sync
-      integer itau_w
-      integer :: ijb,ije,jjn
-      LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-C
-C  Initialisations
-C
-      if (adjust) return
-
-      IF (first) THEN
-!$OMP BARRIER
-!$OMP MASTER
-        ALLOCATE(unat(ijb_u:ije_u,llm))
-        ALLOCATE(vnat(ijb_v:ije_v,llm))
-        ALLOCATE(tm(ijb_u:ije_u,llm))
-        ALLOCATE(ndex2d(ijnb_u*llm))
-        ALLOCATE(ndexu(ijnb_u*llm))
-        ALLOCATE(ndexv(ijnb_v*llm))
-        ndex2d = 0
-        ndexu = 0
-        ndexv = 0
-!$OMP END MASTER
-!$OMP BARRIER
-        first=.FALSE.
-      ENDIF
-
-      ok_sync = .TRUE.
-      itau_w = itau_dyn + time
-
-C Passage aux composantes naturelles du vent
-      CALL covnat_loc(llm, ucov, vcov, unat, vnat)
-
-C
-C  Appels a histwrite pour l'ecriture des variables a sauvegarder
-C
-C  Vents U
-C
-
-!$OMP BARRIER
-!$OMP MASTER
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-
-      CALL histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:),
-     .               iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-C
-C  Vents V
-C
-      ije=ij_end
-      if (pole_sud) jjn=jj_nb-1
-      if (pole_sud) ije=ij_end-iip1
-!$OMP BARRIER
-!$OMP MASTER
-      CALL histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:),
-     .               iip1*jjn*llm, ndexv)
-!$OMP END MASTER
-
-
-C
-C  Temperature potentielle moyennee
-C
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-!$OMP MASTER
-      CALL histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-C
-C  Temperature moyennee
-C
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do ll=1,llm
-        do ii = ijb, ije
-          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-        enddo
-      enddo
-!$OMP ENDDO
-
-!$OMP MASTER
-      CALL histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Geopotentiel
-C
-!$OMP MASTER
-      CALL histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Traceurs
-C
-!!$OMP MASTER
-!        DO iq=1,nqtot
-!          CALL histwrite(histaveid, tracers(iq)%longName, itau_w, &
-!     .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
-!        enddo
-!!$OMP END MASTER
-
-
-C
-C  Masse
-C
-!$OMP MASTER
-       CALL histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Pression au sol
-C
-!$OMP MASTER
-
-       CALL histwrite(histaveid, 'ps', itau_w, ps(ijb:ije),
-     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Geopotentiel au sol
-C
-!$OMP MASTER
-!       CALL histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
-!     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Fin
-C
-!$OMP MASTER
-      if (ok_sync) then
-          CALL histsync(histaveid)
-          CALL histsync(histvaveid)
-          CALL histsync(histuaveid)
-      ENDIF
-!$OMP END MASTER
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writedynav_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writedynav_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writedynav_loc.f90	(revision 5105)
@@ -0,0 +1,218 @@
+
+! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+
+SUBROUTINE writedynav_loc( time, vcov, ucov,teta,ppk,phi,q, &
+        masse,ps,phis)
+
+  ! This routine needs IOIPSL
+  USE ioipsl
+  USE parallel_lmdz
+  USE misc_mod
+  USE infotrac, ONLY: nqtot
+  use com_io_dyn_mod, ONLY: histaveid,histvaveid,histuaveid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
+
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  CALL covnat_loc(llm, ucov, vcov, unat, vnat)
+
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+
+  CALL histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  CALL histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+
+
+  !
+  !  Temperature potentielle moyennee
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  CALL histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Temperature moyennee
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
+!$OMP ENDDO
+
+!$OMP MASTER
+  CALL histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  CALL histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      CALL histwrite(histaveid, tracers(iq)%longName, itau_w, &
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+
+
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   CALL histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+
+   CALL histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! CALL histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+      CALL histsync(histaveid)
+      CALL histsync(histvaveid)
+      CALL histsync(histuaveid)
+  ENDIF
+!$OMP END MASTER
+end subroutine writedynav_loc
Index: DZ6/branches/Amaury_dev/libf/dyn3dmem/writehist_loc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writehist_loc.F	(revision 5104)
+++ 	(revision )
@@ -1,217 +1,0 @@
-
-! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-
-      SUBROUTINE writehist_loc( time, vcov, ucov,teta,ppk,phi,q,
-     .                          masse,ps,phis)
-
-! This routine needs IOIPSL
-      USE ioipsl
-      USE parallel_lmdz
-      USE misc_mod
-      USE infotrac, ONLY: nqtot
-      use com_io_dyn_mod, ONLY: histid,histvid,histuid
-      USE comconst_mod, ONLY: cpp
-      USE temps_mod, ONLY: itau_dyn
-      
-      implicit none
-
-C
-C   Ecriture du fichier histoire au format IOIPSL
-C
-C   Appels succesifs des routines: histwrite
-C
-C   Entree:
-C      histid: ID du fichier histoire
-C      time: temps de l'ecriture
-C      vcov: vents v covariants
-C      ucov: vents u covariants
-C      teta: temperature potentielle
-C      phi : geopotentiel instantane
-C      q   : traceurs
-C      masse: masse
-C      ps   :pression au sol
-C      phis : geopotentiel au sol
-C      
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C
-C   Arguments
-C
-
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
-      REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-      REAL ppk(ijb_u:ije_u,llm)                  
-      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
-      REAL phis(ijb_u:ije_u)                  
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      integer time
-
-
-! This routine needs IOIPSL
-C   Variables locales
-C
-      INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
-      INTEGER :: iq, ii, ll
-      REAL,SAVE,ALLOCATABLE :: tm(:,:)
-      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
-      logical ok_sync
-      integer itau_w
-      integer :: ijb,ije,jjn
-      LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-C
-C  Initialisations
-C
-      if (adjust) return
-
-      IF (first) THEN
-!$OMP BARRIER
-!$OMP MASTER
-        ALLOCATE(unat(ijb_u:ije_u,llm))
-        ALLOCATE(vnat(ijb_v:ije_v,llm))
-        ALLOCATE(tm(ijb_u:ije_u,llm))
-        ALLOCATE(ndex2d(ijnb_u*llm))
-        ALLOCATE(ndexu(ijnb_u*llm))
-        ALLOCATE(ndexv(ijnb_v*llm))
-        ndex2d = 0
-        ndexu = 0
-        ndexv = 0
-!$OMP END MASTER
-!$OMP BARRIER
-        first=.FALSE.
-      ENDIF
-
-      ok_sync = .TRUE.
-      itau_w = itau_dyn + time
-
-C Passage aux composantes naturelles du vent
-      CALL covnat_loc(llm, ucov, vcov, unat, vnat)
-
-C
-C  Appels a histwrite pour l'ecriture des variables a sauvegarder
-C
-C  Vents U
-C
-
-!$OMP BARRIER
-!$OMP MASTER
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-
-      CALL histwrite(histuid, 'u', itau_w, unat(ijb:ije,:),
-     .               iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-C
-C  Vents V
-C
-      ije=ij_end
-      if (pole_sud) jjn=jj_nb-1
-      if (pole_sud) ije=ij_end-iip1
-!$OMP BARRIER
-!$OMP MASTER
-      CALL histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:),
-     .               iip1*jjn*llm, ndexv)
-!$OMP END MASTER
-
-
-C
-C  Temperature potentielle
-C
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-!$OMP MASTER
-      CALL histwrite(histid, 'theta', itau_w, teta(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-C
-C  Temperature
-C
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do ll=1,llm
-        do ii = ijb, ije
-          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-        enddo
-      enddo
-!$OMP ENDDO
-
-!$OMP MASTER
-      CALL histwrite(histid, 'temp', itau_w, tm(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Geopotentiel
-C
-!$OMP MASTER
-      CALL histwrite(histid, 'phi', itau_w, phi(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Traceurs
-C
-!!$OMP MASTER
-!        DO iq=1,nqtot
-!          CALL histwrite(histid, tracers(iq)%longName, itau_w,
-!     .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
-!        enddo
-!!$OMP END MASTER
-
-
-C
-C  Masse
-C
-!$OMP MASTER
-       CALL histwrite(histid, 'masse', itau_w, masse(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Pression au sol
-C
-!$OMP MASTER
-       CALL histwrite(histid, 'ps', itau_w, ps(ijb:ije),
-     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Geopotentiel au sol
-C
-!$OMP MASTER
-!       CALL histwrite(histid, 'phis', itau_w, phis(ijb:ije),
-!     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Fin
-C
-!$OMP MASTER
-      if (ok_sync) then
-        CALL histsync(histid)
-        CALL histsync(histvid)
-        CALL histsync(histuid)
-      endif
-!$OMP END MASTER
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writehist_loc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writehist_loc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writehist_loc.f90	(revision 5105)
@@ -0,0 +1,217 @@
+
+! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+
+SUBROUTINE writehist_loc( time, vcov, ucov,teta,ppk,phi,q, &
+        masse,ps,phis)
+
+  ! This routine needs IOIPSL
+  USE ioipsl
+  USE parallel_lmdz
+  USE misc_mod
+  USE infotrac, ONLY: nqtot
+  use com_io_dyn_mod, ONLY: histid,histvid,histuid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
+
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  CALL covnat_loc(llm, ucov, vcov, unat, vnat)
+
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+
+  CALL histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  CALL histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+
+
+  !
+  !  Temperature potentielle
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  CALL histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Temperature
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
+!$OMP ENDDO
+
+!$OMP MASTER
+  CALL histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  CALL histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      CALL histwrite(histid, tracers(iq)%longName, itau_w,
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+
+
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   CALL histwrite(histid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+   CALL histwrite(histid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! CALL histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+    CALL histsync(histid)
+    CALL histsync(histvid)
+    CALL histsync(histuid)
+  endif
+!$OMP END MASTER
+end subroutine writehist_loc
Index: DZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.F	(revision 5104)
+++ 	(revision )
@@ -1,681 +1,0 @@
-
-! $Id$
-
-C
-C
-      SUBROUTINE calfis(lafin,
-     $                  jD_cur, jH_cur,
-     $                  pucov,
-     $                  pvcov,
-     $                  pteta,
-     $                  pq,
-     $                  pmasse,
-     $                  pps,
-     $                  pp,
-     $                  ppk,
-     $                  pphis,
-     $                  pphi,
-     $                  pducov,
-     $                  pdvcov,
-     $                  pdteta,
-     $                  pdq,
-     $                  flxw,
-     $                  pdufi,
-     $                  pdvfi,
-     $                  pdhfi,
-     $                  pdqfi,
-     $                  pdpsfi)
-c
-c    Auteur :  P. Le Van, F. Hourdin
-c   .........
-      USE infotrac, ONLY: nqtot, tracers
-      USE control_mod, ONLY: planet_type, nsplit_phys
-      USE callphysiq_mod, ONLY: call_physiq
-      USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
-      USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, kappa, pi
-      USE comvert_mod, ONLY: preff, presnivs
-
-      IMPLICIT NONE
-c=======================================================================
-c
-c   1. rearrangement des tableaux et transformation
-c      variables dynamiques  >  variables physiques
-c   2. calcul des termes physiques
-c   3. retransformation des tendances physiques en tendances dynamiques
-c
-c   remarques:
-c   ----------
-c
-c    - les vents sont donnes dans la physique par leurs composantes
-c      naturelles.
-c    - la variable thermodynamique de la physique est une variable
-c      intensive :   T
-c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
-c    - les deux seules variables dependant de la geometrie necessaires
-c      pour la physique sont la latitude pour le rayonnement et
-c      l'aire de la maille quand on veut integrer une grandeur
-c      horizontalement.
-c    - les points de la physique sont les points scalaires de la
-c      la dynamique; numerotation:
-c          1 pour le pole nord
-c          (jjm-1)*iim pour l'interieur du domaine
-c          ngridmx pour le pole sud
-c      ---> ngridmx=2+(jjm-1)*iim
-c
-c     Input :
-c     -------
-c       pucov           covariant zonal velocity
-c       pvcov           covariant meridional velocity
-c       pteta           potential temperature
-c       pps             surface pressure
-c       pmasse          masse d'air dans chaque maille
-c       pts             surface temperature  (K)
-c       callrad         clef d'appel au rayonnement
-c
-c    Output :
-c    --------
-c        pdufi          tendency for the natural zonal velocity (ms-1)
-c        pdvfi          tendency for the natural meridional velocity
-c        pdhfi          tendency for the potential temperature
-c        pdtsfi         tendency for the surface temperature
-c
-c        pdtrad         radiative tendencies  \  both input
-c        pfluxrad       radiative fluxes      /  and output
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c
-c    0.  Declarations :
-c    ------------------
-
-      include "dimensions.h"
-      include "paramet.h"
-
-      INTEGER ngridmx
-      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
-
-      include "comgeom2.h"
-      include "iniprint.h"
-
-c    Arguments :
-c    -----------
-      LOGICAL,INTENT(IN) ::  lafin ! .TRUE. for the very last CALL to physics
-      REAL,INTENT(IN):: jD_cur, jH_cur
-      REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
-      REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
-      REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
-      REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
-      REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
-      REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
-      REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
-
-      REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
-      REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
-      REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
-      ! NB: pdteta is used only to compute pcvgt which is in fact not used...
-      REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
-      ! NB: pdq is only used to compute pcvgq which is in fact not used...
-
-      REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
-      REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
-      REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
-      REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0)
-
-      ! tendencies (in */s) from the physics
-      REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
-      REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
-      REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
-      REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
-      REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
-
-
-c    Local variables :
-c    -----------------
-
-      INTEGER i,j,l,ig0,ig,iq,itr
-      REAL zpsrf(ngridmx)
-      REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm)
-      REAL zphi(ngridmx,llm),zphis(ngridmx)
-c
-      REAL zrot(iip1,jjm,llm) ! AdlC May 2014
-      REAL zufi(ngridmx,llm), zvfi(ngridmx,llm)
-      REAL zrfi(ngridmx,llm) ! relative wind vorticity
-      REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
-      REAL zpk(ngridmx,llm)
-c
-      REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
-      REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
-c
-      REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
-      REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
-      REAL zdpsrf(ngridmx)
-c
-      REAL zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
-      REAL zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
-      REAL jH_cur_split,zdt_split
-      LOGICAL debut_split,lafin_split
-      INTEGER isplit
-
-      REAL zsin(iim),zcos(iim),z1(iim)
-      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
-      REAL unskap, pksurcp
-c
-      REAL flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
-c
-
-      REAL SSUM
-
-      LOGICAL,SAVE :: firstcal=.TRUE., debut=.TRUE.
-!      REAL rdayvrai
-
-c
-c-----------------------------------------------------------------------
-c
-c    1. Initialisations :
-c    --------------------
-c
-c
-      IF ( firstcal )  THEN
-        debut = .TRUE.
-        IF (ngridmx/=2+(jjm-1)*iim) THEN
-         write(lunout,*) 'STOP dans calfis'
-         write(lunout,*)
-     &   'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
-         write(lunout,*) '  ngridmx  jjm   iim   '
-         write(lunout,*) ngridmx,jjm,iim
-         CALL abort_gcm("calfis", "", 1)
-        ENDIF
-      ELSE
-        debut = .FALSE.
-      ENDIF ! of IF (firstcal)
-
-c
-c
-c-----------------------------------------------------------------------
-c   40. transformation des variables dynamiques en variables physiques:
-c   ---------------------------------------------------------------
-
-c   41. pressions au sol (en Pascals)
-c   ----------------------------------
-
-
-      zpsrf(1) = pps(1,1)
-
-      ig0  = 2
-      DO j = 2,jjm
-         CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
-         ig0 = ig0+iim
-      ENDDO
-
-      zpsrf(ngridmx) = pps(1,jjp1)
-
-
-c   42. pression intercouches et fonction d'Exner:
-c
-c   -----------------------------------------------------------------
-c     .... zplev  definis aux (llm +1) interfaces des couches  ....
-c     .... zplay  definis aux (  llm )    milieux des couches  ....
-c   -----------------------------------------------------------------
-
-c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
-c
-       unskap   = 1./ kappa
-c
-      DO l = 1, llm
-        zpk(   1,l ) = ppk(1,1,l)
-        zplev( 1,l ) = pp(1,1,l)
-        ig0 = 2
-          DO j = 2, jjm
-             DO i =1, iim
-              zpk(   ig0,l ) = ppk(i,j,l)
-              zplev( ig0,l ) = pp(i,j,l)
-              ig0 = ig0 +1
-             ENDDO
-          ENDDO
-        zpk(   ngridmx,l ) = ppk(1,jjp1,l)
-        zplev( ngridmx,l ) = pp(1,jjp1,l)
-      ENDDO
-        zplev( 1,llmp1 ) = pp(1,1,llmp1)
-        ig0 = 2
-          DO j = 2, jjm
-             DO i =1, iim
-              zplev( ig0,llmp1 ) = pp(i,j,llmp1)
-              ig0 = ig0 +1
-             ENDDO
-          ENDDO
-        zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1)
-c
-c
-
-c   43. temperature naturelle (en K) et pressions milieux couches .
-c   ---------------------------------------------------------------
-
-      DO l=1,llm
-
-         pksurcp     =  ppk(1,1,l) / cpp
-         zplay(1,l)  =  preff * pksurcp ** unskap
-         ztfi(1,l)   =  pteta(1,1,l) *  pksurcp
-         pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
-         ig0         = 2
-
-         DO j = 2, jjm
-            DO i = 1, iim
-              pksurcp        = ppk(i,j,l) / cpp
-              zplay(ig0,l)   = preff * pksurcp ** unskap
-              ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
-              pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
-              ig0            = ig0 + 1
-            ENDDO
-         ENDDO
-
-         pksurcp       = ppk(1,jjp1,l) / cpp
-         zplay(ig0,l)  = preff * pksurcp ** unskap
-         ztfi (ig0,l)  = pteta(1,jjp1,l)  * pksurcp
-         pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
-
-      ENDDO
-
-c   43.bis traceurs
-c   ---------------
-c
-      itr=0
-      DO iq=1,nqtot
-         IF(.NOT.tracers(iq)%isAdvected) CYCLE
-         itr = itr + 1
-         DO l=1,llm
-            zqfi(1,l,itr) = pq(1,1,l,iq)
-            ig0           = 2
-            DO j=2,jjm
-               DO i = 1, iim
-                  zqfi(ig0,l,itr) = pq(i,j,l,iq)
-                  ig0             = ig0 + 1
-               ENDDO
-            ENDDO
-            zqfi(ig0,l,itr) = pq(1,jjp1,l,iq)
-         ENDDO
-      ENDDO
-
-c   convergence dynamique pour les traceurs "EAU"
-! Earth-specific treatment of first 2 tracers (water)
-       if (planet_type=="earth") then
-        DO iq=1,2
-         DO l=1,llm
-            pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
-            ig0          = 2
-            DO j=2,jjm
-               DO i = 1, iim
-                  pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
-                  ig0             = ig0 + 1
-               ENDDO
-            ENDDO
-            pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
-         ENDDO
-        ENDDO
-       endif ! of if (planet_type=="earth")
-
-
-c   Geopotentiel calcule par rapport a la surface locale:
-c   -----------------------------------------------------
-
-      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
-      DO l=1,llm
-         DO ig=1,ngridmx
-           zphi(ig,l)=zphi(ig,l)-zphis(ig)
-         ENDDO
-      ENDDO
-
-c   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
-c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux
-c    de masse est calclue dans advtrac.F
-c      DO l=1,llm
-c        pvervel(1,l)=pw(1,1,l) * g /apoln
-c        ig0=2
-c       DO j=2,jjm
-c           DO i = 1, iim
-c              pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
-c              ig0 = ig0 + 1
-c           ENDDO
-c       ENDDO
-c        pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
-c      ENDDO
-
-c
-c   45. champ u:
-c   ------------
-
-      DO l=1,llm
-
-         DO j=2,jjm
-            ig0 = 1+(j-2)*iim
-            zufi(ig0+1,l)= 0.5 *
-     $      ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
-            pcvgu(ig0+1,l)= 0.5 *
-     $      ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
-            DO i=2,iim
-               zufi(ig0+i,l)= 0.5 *
-     $         ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
-               pcvgu(ig0+i,l)= 0.5 *
-     $         ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
-      END DO
-      END DO
-
-      END DO
-
-
-C  Alvaro de la Camara (May 2014)
-C  46.1 Calcul de la vorticite et passage sur la grille physique
-C  --------------------------------------------------------------
-      DO l=1,llm
-        do i=1,iim
-          do j=1,jjm
-            zrot(i,j,l) = (pvcov(i+1,j,l) - pvcov(i,j,l)
-     $                   + pucov(i,j+1,l) - pucov(i,j,l))
-     $                   / (cu(i,j)+cu(i,j+1))
-     $                   / (cv(i+1,j)+cv(i,j)) *4
-          enddo
-        enddo
-      ENDDO
-
-c   46.champ v:
-c   -----------
-
-      DO l=1,llm
-         DO j=2,jjm
-            ig0=1+(j-2)*iim
-            DO i=1,iim
-               zvfi(ig0+i,l)= 0.5 *
-     $         ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
-               pcvgv(ig0+i,l)= 0.5 *
-     $         ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
-            ENDDO
-               zrfi(ig0 + 1,l)= 0.25 *(zrot(iim,j-1,l)+zrot(iim,j,l)
-     &                                +zrot(1,j-1,l)+zrot(1,j,l))
-            DO i=2,iim
-               zrfi(ig0 + i,l)= 0.25 *(zrot(i-1,j-1,l)+zrot(i-1,j,l)
-     $                   +zrot(i,j-1,l)+zrot(i,j,l))   !  AdlC MAY 2014
-            ENDDO
-         ENDDO
-      ENDDO
-
-
-c   47. champs de vents aux pole nord
-c   ------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-      DO l=1,llm
-
-         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
-         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
-         DO i=2,iim
-            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
-            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
-         ENDDO
-
-         DO i=1,iim
-            zcos(i)   = COS(rlonv(i))*z1(i)
-            zcosbis(i)= COS(rlonv(i))*z1bis(i)
-            zsin(i)   = SIN(rlonv(i))*z1(i)
-            zsinbis(i)= SIN(rlonv(i))*z1bis(i)
-         ENDDO
-
-         zufi(1,l)  = SSUM(iim,zcos,1)/pi
-         pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
-         zvfi(1,l)  = SSUM(iim,zsin,1)/pi
-         pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
-         zrfi(1, l) = 0.
-      ENDDO
-
-
-c   48. champs de vents aux pole sud:
-c   ---------------------------------
-c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-      DO l=1,llm
-
-         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
-         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
-         DO i=2,iim
-            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
-            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
-         ENDDO
-
-         DO i=1,iim
-            zcos(i)    = COS(rlonv(i))*z1(i)
-            zcosbis(i) = COS(rlonv(i))*z1bis(i)
-            zsin(i)    = SIN(rlonv(i))*z1(i)
-            zsinbis(i) = SIN(rlonv(i))*z1bis(i)
-         ENDDO
-
-         zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
-         pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
-         zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
-         pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
-         zrfi(ngridmx, l) = 0.
-      ENDDO
-c
-c On change de grille, dynamique vers physiq, pour le flux de masse verticale
-      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
-
-c-----------------------------------------------------------------------
-c   Appel de la physique:
-c   ---------------------
-
-
-
-!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
-      zdt_split=dtphys/nsplit_phys
-      zdufic(:,:)=0.
-      zdvfic(:,:)=0.
-      zdtfic(:,:)=0.
-      zdqfic(:,:,:)=0.
-
-       IF (CPPKEY_PHYS) THEN
-
-       do isplit=1,nsplit_phys
-
-         jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
-         debut_split=debut.and.isplit==1
-         lafin_split=lafin.and.isplit==nsplit_phys
-
-!      if (planet_type=="earth") then
-        CALL call_physiq(ngridmx,llm,nqtot,tracers(:)%name,
-     &                   debut_split,lafin_split,
-     &                   jD_cur,jH_cur_split,zdt_split,
-     &                   zplev,zplay,
-     &                   zpk,zphi,zphis,
-     &                   presnivs,
-     &                   zufi,zvfi,zrfi,ztfi,zqfi,
-     &                   flxwfi,pducov,
-     &                   zdufi,zdvfi,zdtfi,zdqfi,zdpsrf)
-
-!      else if ( planet_type=="generic" ) then
-
-!         CALL physiq (ngridmx,     !! ngrid
-!     .             llm,            !! nlayer
-!     .             nqtot,          !! nq
-!     .             tracers(:)%name,!! tracer names from dynamical core (given in infotrac)
-!     .             debut_split,    !! firstcall
-!     .             lafin_split,    !! lastcall
-!     .             jD_cur,         !! pday. see leapfrog
-!     .             jH_cur_split,   !! ptime "fraction of day"
-!     .             zdt_split,      !! ptimestep
-!     .             zplev,          !! pplev
-!     .             zplay,          !! pplay
-!     .             zphi,           !! pphi
-!     .             zufi,           !! pu
-!     .             zvfi,           !! pv
-!     .             ztfi,           !! pt
-!     .             zqfi,           !! pq
-!     .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
-!     .             zdufi,          !! pdu
-!     .             zdvfi,          !! pdv
-!     .             zdtfi,          !! pdt
-!     .             zdqfi,          !! pdq
-!     .             zdpsrf,         !! pdpsrf
-!     .             tracerdyn)      !! tracerdyn <-- utilite ???
-
-!      endif ! of if (planet_type=="earth")
-
-         zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
-         zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
-         ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
-         zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
-
-         zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
-         zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
-         zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
-         zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
-
-       enddo ! of do isplit=1,nsplit_phys
-
-       END IF
-
-      zdufi(:,:)=zdufic(:,:)/nsplit_phys
-      zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
-      zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
-      zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
-
-c-----------------------------------------------------------------------
-c   transformation des tendances physiques en tendances dynamiques:
-c   ---------------------------------------------------------------
-
-c  tendance sur la pression :
-c  -----------------------------------
-
-      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
-c
-c   62. enthalpie potentielle
-c   ---------------------
-
-      DO l=1,llm
-
-         DO i=1,iip1
-          pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
-          pdhfi(i,jjp1,l) = cpp *  zdtfi(ngridmx,l)/ ppk(i,jjp1,l)
-         ENDDO
-
-         DO j=2,jjm
-            ig0=1+(j-2)*iim
-            DO i=1,iim
-               pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l)
-            ENDDO
-               pdhfi(iip1,j,l) =  pdhfi(1,j,l)
-         ENDDO
-
-      ENDDO
-
-
-c   62. humidite specifique
-c   ---------------------
-! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
-!      DO iq=1,nqtot
-!         DO l=1,llm
-!            DO i=1,iip1
-!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
-!               pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
-!            ENDDO
-!            DO j=2,jjm
-!               ig0=1+(j-2)*iim
-!               DO i=1,iim
-!                  pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
-!               ENDDO
-!               pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
-!            ENDDO
-!         ENDDO
-!      ENDDO
-
-c   63. traceurs
-c   ------------
-C     initialisation des tendances
-      pdqfi(:,:,:,:)=0.
-C
-      itr = 0
-      DO iq=1,nqtot
-         IF(.NOT.tracers(iq)%isAdvected) CYCLE
-         itr = itr + 1
-         DO l=1,llm
-            DO i=1,iip1
-               pdqfi(i,1,l,iq)    = zdqfi(1,l,itr)
-               pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,itr)
-            ENDDO
-            DO j=2,jjm
-               ig0=1+(j-2)*iim
-               DO i=1,iim
-                  pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,itr)
-               ENDDO
-               pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,itr)
-            ENDDO
-         ENDDO
-      ENDDO
-
-c   65. champ u:
-c   ------------
-
-      DO l=1,llm
-
-         DO i=1,iip1
-            pdufi(i,1,l)    = 0.
-            pdufi(i,jjp1,l) = 0.
-         ENDDO
-
-         DO j=2,jjm
-            ig0=1+(j-2)*iim
-            DO i=1,iim-1
-               pdufi(i,j,l)=
-     $         0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
-            ENDDO
-            pdufi(iim,j,l)=
-     $      0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
-            pdufi(iip1,j,l)=pdufi(1,j,l)
-         ENDDO
-
-      ENDDO
-
-
-c   67. champ v:
-c   ------------
-
-      DO l=1,llm
-
-         DO j=2,jjm-1
-            ig0=1+(j-2)*iim
-            DO i=1,iim
-               pdvfi(i,j,l)=
-     $         0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
-            ENDDO
-            pdvfi(iip1,j,l) = pdvfi(1,j,l)
-         ENDDO
-      ENDDO
-
-
-c   68. champ v pres des poles:
-c   ---------------------------
-c      v = U * cos(long) + V * SIN(long)
-
-      DO l=1,llm
-
-         DO i=1,iim
-            pdvfi(i,1,l)=
-     $      zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
-            pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i))
-     $      +zdvfi(ngridmx,l)*SIN(rlonv(i))
-            pdvfi(i,1,l)=
-     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
-            pdvfi(i,jjm,l)=
-     $      0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
-          ENDDO
-
-         pdvfi(iip1,1,l)  = pdvfi(1,1,l)
-         pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
-
-      ENDDO
-
-c-----------------------------------------------------------------------
-      firstcal = .FALSE.
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.f90	(revision 5105)
@@ -0,0 +1,681 @@
+
+! $Id$
+
+!
+!
+SUBROUTINE calfis(lafin, &
+        jD_cur, jH_cur, &
+        pucov, &
+        pvcov, &
+        pteta, &
+        pq, &
+        pmasse, &
+        pps, &
+        pp, &
+        ppk, &
+        pphis, &
+        pphi, &
+        pducov, &
+        pdvcov, &
+        pdteta, &
+        pdq, &
+        flxw, &
+        pdufi, &
+        pdvfi, &
+        pdhfi, &
+        pdqfi, &
+        pdpsfi)
+  !
+  !    Auteur :  P. Le Van, F. Hourdin
+  !   .........
+  USE infotrac, ONLY: nqtot, tracers
+  USE control_mod, ONLY: planet_type, nsplit_phys
+  USE callphysiq_mod, ONLY: call_physiq
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
+  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, kappa, pi
+  USE comvert_mod, ONLY: preff, presnivs
+
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   1. rearrangement des tableaux et transformation
+  !  variables dynamiques  >  variables physiques
+  !   2. calcul des termes physiques
+  !   3. retransformation des tendances physiques en tendances dynamiques
+  !
+  !   remarques:
+  !   ----------
+  !
+  !    - les vents sont donnes dans la physique par leurs composantes
+  !  naturelles.
+  !    - la variable thermodynamique de la physique est une variable
+  !  intensive :   T
+  !  pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+  !    - les deux seules variables dependant de la geometrie necessaires
+  !  pour la physique sont la latitude pour le rayonnement et
+  !  l'aire de la maille quand on veut integrer une grandeur
+  !  horizontalement.
+  !    - les points de la physique sont les points scalaires de la
+  !  la dynamique; numerotation:
+  !      1 pour le pole nord
+  !      (jjm-1)*iim pour l'interieur du domaine
+  !      ngridmx pour le pole sud
+  !  ---> ngridmx=2+(jjm-1)*iim
+  !
+  ! Input :
+  ! -------
+  !   pucov           covariant zonal velocity
+  !   pvcov           covariant meridional velocity
+  !   pteta           potential temperature
+  !   pps             surface pressure
+  !   pmasse          masse d'air dans chaque maille
+  !   pts             surface temperature  (K)
+  !   callrad         clef d'appel au rayonnement
+  !
+  !    Output :
+  !    --------
+  !    pdufi          tendency for the natural zonal velocity (ms-1)
+  !    pdvfi          tendency for the natural meridional velocity
+  !    pdhfi          tendency for the potential temperature
+  !    pdtsfi         tendency for the surface temperature
+  !
+  !    pdtrad         radiative tendencies  \  both input
+  !    pfluxrad       radiative fluxes      /  and output
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    0.  Declarations :
+  !    ------------------
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  INTEGER :: ngridmx
+  PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+  include "comgeom2.h"
+  include "iniprint.h"
+
+  !    Arguments :
+  !    -----------
+  LOGICAL,INTENT(IN) ::  lafin ! .TRUE. for the very last CALL to physics
+  REAL,INTENT(IN):: jD_cur, jH_cur
+  REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
+  REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
+  REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
+  REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
+  REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
+  REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
+  REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
+
+  REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
+  REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
+  REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
+  ! ! NB: pdteta is used only to compute pcvgt which is in fact not used...
+  REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
+  ! ! NB: pdq is only used to compute pcvgq which is in fact not used...
+
+  REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
+  REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
+  REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
+  REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0)
+
+  ! ! tendencies (in */s) from the physics
+  REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
+  REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
+  REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
+  REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
+  REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
+
+
+  !    Local variables :
+  !    -----------------
+
+  INTEGER :: i,j,l,ig0,ig,iq,itr
+  REAL :: zpsrf(ngridmx)
+  REAL :: zplev(ngridmx,llm+1),zplay(ngridmx,llm)
+  REAL :: zphi(ngridmx,llm),zphis(ngridmx)
+  !
+  REAL :: zrot(iip1,jjm,llm) ! AdlC May 2014
+  REAL :: zufi(ngridmx,llm), zvfi(ngridmx,llm)
+  REAL :: zrfi(ngridmx,llm) ! relative wind vorticity
+  REAL :: ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
+  REAL :: zpk(ngridmx,llm)
+  !
+  REAL :: pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
+  REAL :: pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
+  !
+  REAL :: zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
+  REAL :: zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
+  REAL :: zdpsrf(ngridmx)
+  !
+  REAL :: zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
+  REAL :: zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
+  REAL :: jH_cur_split,zdt_split
+  LOGICAL :: debut_split,lafin_split
+  INTEGER :: isplit
+
+  REAL :: zsin(iim),zcos(iim),z1(iim)
+  REAL :: zsinbis(iim),zcosbis(iim),z1bis(iim)
+  REAL :: unskap, pksurcp
+  !
+  REAL :: flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
+  !
+
+  REAL :: SSUM
+
+  LOGICAL,SAVE :: firstcal=.TRUE., debut=.TRUE.
+   ! REAL rdayvrai
+
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    1. Initialisations :
+  !    --------------------
+  !
+  !
+  IF ( firstcal )  THEN
+    debut = .TRUE.
+    IF (ngridmx/=2+(jjm-1)*iim) THEN
+     write(lunout,*) 'STOP dans calfis'
+     write(lunout,*) &
+           'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+     write(lunout,*) '  ngridmx  jjm   iim   '
+     write(lunout,*) ngridmx,jjm,iim
+     CALL abort_gcm("calfis", "", 1)
+    ENDIF
+  ELSE
+    debut = .FALSE.
+  ENDIF ! of IF (firstcal)
+
+  !
+  !
+  !-----------------------------------------------------------------------
+  !   40. transformation des variables dynamiques en variables physiques:
+  !   ---------------------------------------------------------------
+
+  !   41. pressions au sol (en Pascals)
+  !   ----------------------------------
+
+
+  zpsrf(1) = pps(1,1)
+
+  ig0  = 2
+  DO j = 2,jjm
+     CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
+     ig0 = ig0+iim
+  ENDDO
+
+  zpsrf(ngridmx) = pps(1,jjp1)
+
+
+  !   42. pression intercouches et fonction d'Exner:
+  !
+  !   -----------------------------------------------------------------
+  ! .... zplev  definis aux (llm +1) interfaces des couches  ....
+  ! .... zplay  definis aux (  llm )    milieux des couches  ....
+  !   -----------------------------------------------------------------
+
+  !    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+  !
+   unskap   = 1./ kappa
+  !
+  DO l = 1, llm
+    zpk(   1,l ) = ppk(1,1,l)
+    zplev( 1,l ) = pp(1,1,l)
+    ig0 = 2
+      DO j = 2, jjm
+         DO i =1, iim
+          zpk(   ig0,l ) = ppk(i,j,l)
+          zplev( ig0,l ) = pp(i,j,l)
+          ig0 = ig0 +1
+         ENDDO
+      ENDDO
+    zpk(   ngridmx,l ) = ppk(1,jjp1,l)
+    zplev( ngridmx,l ) = pp(1,jjp1,l)
+  ENDDO
+    zplev( 1,llmp1 ) = pp(1,1,llmp1)
+    ig0 = 2
+      DO j = 2, jjm
+         DO i =1, iim
+          zplev( ig0,llmp1 ) = pp(i,j,llmp1)
+          ig0 = ig0 +1
+         ENDDO
+      ENDDO
+    zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1)
+  !
+  !
+
+  !   43. temperature naturelle (en K) et pressions milieux couches .
+  !   ---------------------------------------------------------------
+
+  DO l=1,llm
+
+     pksurcp     =  ppk(1,1,l) / cpp
+     zplay(1,l)  =  preff * pksurcp ** unskap
+     ztfi(1,l)   =  pteta(1,1,l) *  pksurcp
+     pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
+     ig0         = 2
+
+     DO j = 2, jjm
+        DO i = 1, iim
+          pksurcp        = ppk(i,j,l) / cpp
+          zplay(ig0,l)   = preff * pksurcp ** unskap
+          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
+          pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
+          ig0            = ig0 + 1
+        ENDDO
+     ENDDO
+
+     pksurcp       = ppk(1,jjp1,l) / cpp
+     zplay(ig0,l)  = preff * pksurcp ** unskap
+     ztfi (ig0,l)  = pteta(1,jjp1,l)  * pksurcp
+     pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
+
+  ENDDO
+
+  !   43.bis traceurs
+  !   ---------------
+  !
+  itr=0
+  DO iq=1,nqtot
+     IF(.NOT.tracers(iq)%isAdvected) CYCLE
+     itr = itr + 1
+     DO l=1,llm
+        zqfi(1,l,itr) = pq(1,1,l,iq)
+        ig0           = 2
+        DO j=2,jjm
+           DO i = 1, iim
+              zqfi(ig0,l,itr) = pq(i,j,l,iq)
+              ig0             = ig0 + 1
+           ENDDO
+        ENDDO
+        zqfi(ig0,l,itr) = pq(1,jjp1,l,iq)
+     ENDDO
+  ENDDO
+
+  !   convergence dynamique pour les traceurs "EAU"
+  ! Earth-specific treatment of first 2 tracers (water)
+   if (planet_type=="earth") then
+    DO iq=1,2
+     DO l=1,llm
+        pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
+        ig0          = 2
+        DO j=2,jjm
+           DO i = 1, iim
+              pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
+              ig0             = ig0 + 1
+           ENDDO
+        ENDDO
+        pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
+     ENDDO
+    ENDDO
+   endif ! of if (planet_type=="earth")
+
+
+  !   Geopotentiel calcule par rapport a la surface locale:
+  !   -----------------------------------------------------
+
+  CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
+  CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
+  DO l=1,llm
+     DO ig=1,ngridmx
+       zphi(ig,l)=zphi(ig,l)-zphis(ig)
+     ENDDO
+  ENDDO
+
+  !   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
+  ! JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux
+  !    de masse est calclue dans advtrac.F
+   ! DO l=1,llm
+   !   pvervel(1,l)=pw(1,1,l) * g /apoln
+   !   ig0=2
+   !  DO j=2,jjm
+   !      DO i = 1, iim
+   !         pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
+   !         ig0 = ig0 + 1
+   !      ENDDO
+  !       ENDDO
+   !   pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
+   ! ENDDO
+
+  !
+  !   45. champ u:
+  !   ------------
+
+  DO l=1,llm
+
+     DO j=2,jjm
+        ig0 = 1+(j-2)*iim
+        zufi(ig0+1,l)= 0.5 * &
+              ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
+        pcvgu(ig0+1,l)= 0.5 * &
+              ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
+        DO i=2,iim
+           zufi(ig0+i,l)= 0.5 * &
+                 ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
+           pcvgu(ig0+i,l)= 0.5 * &
+                 ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
+  END DO
+  END DO
+
+  END DO
+
+
+  !  Alvaro de la Camara (May 2014)
+  !  46.1 Calcul de la vorticite et passage sur la grille physique
+  !  --------------------------------------------------------------
+  DO l=1,llm
+    do i=1,iim
+      do j=1,jjm
+        zrot(i,j,l) = (pvcov(i+1,j,l) - pvcov(i,j,l) &
+              + pucov(i,j+1,l) - pucov(i,j,l)) &
+              / (cu(i,j)+cu(i,j+1)) &
+              / (cv(i+1,j)+cv(i,j)) *4
+      enddo
+    enddo
+  ENDDO
+
+  !   46.champ v:
+  !   -----------
+
+  DO l=1,llm
+     DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+           zvfi(ig0+i,l)= 0.5 * &
+                 ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
+           pcvgv(ig0+i,l)= 0.5 * &
+                 ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
+        ENDDO
+           zrfi(ig0 + 1,l)= 0.25 *(zrot(iim,j-1,l)+zrot(iim,j,l) &
+                 +zrot(1,j-1,l)+zrot(1,j,l))
+        DO i=2,iim
+           zrfi(ig0 + i,l)= 0.25 *(zrot(i-1,j-1,l)+zrot(i-1,j,l) &
+                 +zrot(i,j-1,l)+zrot(i,j,l))   !  AdlC MAY 2014
+        ENDDO
+     ENDDO
+  ENDDO
+
+
+  !   47. champs de vents aux pole nord
+  !   ------------------------------
+     ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+     ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+  DO l=1,llm
+
+     z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+     z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
+     DO i=2,iim
+        z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+        z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
+     ENDDO
+
+     DO i=1,iim
+        zcos(i)   = COS(rlonv(i))*z1(i)
+        zcosbis(i)= COS(rlonv(i))*z1bis(i)
+        zsin(i)   = SIN(rlonv(i))*z1(i)
+        zsinbis(i)= SIN(rlonv(i))*z1bis(i)
+     ENDDO
+
+     zufi(1,l)  = SSUM(iim,zcos,1)/pi
+     pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
+     zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+     pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
+     zrfi(1, l) = 0.
+  ENDDO
+
+
+  !   48. champs de vents aux pole sud:
+  !   ---------------------------------
+     ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+     ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+  DO l=1,llm
+
+     z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+     z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
+     DO i=2,iim
+        z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+        z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
+     ENDDO
+
+     DO i=1,iim
+        zcos(i)    = COS(rlonv(i))*z1(i)
+        zcosbis(i) = COS(rlonv(i))*z1bis(i)
+        zsin(i)    = SIN(rlonv(i))*z1(i)
+        zsinbis(i) = SIN(rlonv(i))*z1bis(i)
+     ENDDO
+
+     zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
+     pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
+     zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
+     pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
+     zrfi(ngridmx, l) = 0.
+  ENDDO
+  !
+  ! On change de grille, dynamique vers physiq, pour le flux de masse verticale
+  CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
+
+  !-----------------------------------------------------------------------
+  !   Appel de la physique:
+  !   ---------------------
+
+
+
+   ! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
+  zdt_split=dtphys/nsplit_phys
+  zdufic(:,:)=0.
+  zdvfic(:,:)=0.
+  zdtfic(:,:)=0.
+  zdqfic(:,:,:)=0.
+
+   IF (CPPKEY_PHYS) THEN
+
+   do isplit=1,nsplit_phys
+
+     jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
+     debut_split=debut.and.isplit==1
+     lafin_split=lafin.and.isplit==nsplit_phys
+
+   ! if (planet_type=="earth") then
+    CALL call_physiq(ngridmx,llm,nqtot,tracers(:)%name, &
+          debut_split,lafin_split, &
+          jD_cur,jH_cur_split,zdt_split, &
+          zplev,zplay, &
+          zpk,zphi,zphis, &
+          presnivs, &
+          zufi,zvfi,zrfi,ztfi,zqfi, &
+          flxwfi,pducov, &
+          zdufi,zdvfi,zdtfi,zdqfi,zdpsrf)
+
+   ! else if ( planet_type=="generic" ) then
+
+   !    CALL physiq (ngridmx,     !! ngrid
+  ! .             llm,            !! nlayer
+  ! .             nqtot,          !! nq
+  ! .             tracers(:)%name,!! tracer names from dynamical core (given in infotrac)
+  ! .             debut_split,    !! firstcall
+  ! .             lafin_split,    !! lastcall
+  ! .             jD_cur,         !! pday. see leapfrog
+  ! .             jH_cur_split,   !! ptime "fraction of day"
+  ! .             zdt_split,      !! ptimestep
+  ! .             zplev,          !! pplev
+  ! .             zplay,          !! pplay
+  ! .             zphi,           !! pphi
+  ! .             zufi,           !! pu
+  ! .             zvfi,           !! pv
+  ! .             ztfi,           !! pt
+  ! .             zqfi,           !! pq
+  ! .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
+  ! .             zdufi,          !! pdu
+  ! .             zdvfi,          !! pdv
+  ! .             zdtfi,          !! pdt
+  ! .             zdqfi,          !! pdq
+  ! .             zdpsrf,         !! pdpsrf
+  ! .             tracerdyn)      !! tracerdyn <-- utilite ???
+
+  !  endif ! of if (planet_type=="earth")
+
+     zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
+     zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
+     ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
+     zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
+
+     zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
+     zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
+     zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
+     zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
+
+   enddo ! of do isplit=1,nsplit_phys
+
+   END IF
+
+  zdufi(:,:)=zdufic(:,:)/nsplit_phys
+  zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
+  zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
+  zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
+
+  !-----------------------------------------------------------------------
+  !   transformation des tendances physiques en tendances dynamiques:
+  !   ---------------------------------------------------------------
+
+  !  tendance sur la pression :
+  !  -----------------------------------
+
+  CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
+  !
+  !   62. enthalpie potentielle
+  !   ---------------------
+
+  DO l=1,llm
+
+     DO i=1,iip1
+      pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+      pdhfi(i,jjp1,l) = cpp *  zdtfi(ngridmx,l)/ ppk(i,jjp1,l)
+     ENDDO
+
+     DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+           pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l)
+        ENDDO
+           pdhfi(iip1,j,l) =  pdhfi(1,j,l)
+     ENDDO
+
+  ENDDO
+
+
+  !   62. humidite specifique
+  !   ---------------------
+  ! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+   ! DO iq=1,nqtot
+   !    DO l=1,llm
+   !       DO i=1,iip1
+   !          pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
+   !          pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
+   !       ENDDO
+   !       DO j=2,jjm
+   !          ig0=1+(j-2)*iim
+   !          DO i=1,iim
+   !             pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
+   !          ENDDO
+   !          pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
+   !       ENDDO
+   !    ENDDO
+   ! ENDDO
+
+  !   63. traceurs
+  !   ------------
+  ! initialisation des tendances
+  pdqfi(:,:,:,:)=0.
+  !
+  itr = 0
+  DO iq=1,nqtot
+     IF(.NOT.tracers(iq)%isAdvected) CYCLE
+     itr = itr + 1
+     DO l=1,llm
+        DO i=1,iip1
+           pdqfi(i,1,l,iq)    = zdqfi(1,l,itr)
+           pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,itr)
+        ENDDO
+        DO j=2,jjm
+           ig0=1+(j-2)*iim
+           DO i=1,iim
+              pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,itr)
+           ENDDO
+           pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,itr)
+        ENDDO
+     ENDDO
+  ENDDO
+
+  !   65. champ u:
+  !   ------------
+
+  DO l=1,llm
+
+     DO i=1,iip1
+        pdufi(i,1,l)    = 0.
+        pdufi(i,jjp1,l) = 0.
+     ENDDO
+
+     DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim-1
+           pdufi(i,j,l)= &
+                 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
+        ENDDO
+        pdufi(iim,j,l)= &
+              0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
+        pdufi(iip1,j,l)=pdufi(1,j,l)
+     ENDDO
+
+  ENDDO
+
+
+  !   67. champ v:
+  !   ------------
+
+  DO l=1,llm
+
+     DO j=2,jjm-1
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+           pdvfi(i,j,l)= &
+                 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
+        ENDDO
+        pdvfi(iip1,j,l) = pdvfi(1,j,l)
+     ENDDO
+  ENDDO
+
+
+  !   68. champ v pres des poles:
+  !   ---------------------------
+   ! v = U * cos(long) + V * SIN(long)
+
+  DO l=1,llm
+
+     DO i=1,iim
+        pdvfi(i,1,l)= &
+              zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
+        pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) &
+              +zdvfi(ngridmx,l)*SIN(rlonv(i))
+        pdvfi(i,1,l)= &
+              0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+        pdvfi(i,jjm,l)= &
+              0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
+      ENDDO
+
+     pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+     pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+  ENDDO
+
+  !-----------------------------------------------------------------------
+  firstcal = .FALSE.
+
+  RETURN
+END SUBROUTINE calfis
Index: DZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_dyn_fi.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_dyn_fi.F	(revision 5104)
+++ 	(revision )
@@ -1,40 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER j,ifield,ig
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-      IF (ngrid/=2+(jm-2)*(im-1)) then
-         CALL abort_gcm("gr_dyn_fi", 'probleme de dim', 1)
-      end if
-c   traitement des poles
-      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
-      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
-
-c   traitement des point normaux
-      DO ifield=1,nfield
-         DO j=2,jm-1
-	    ig=2+(j-2)*(im-1)
-            CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
-         ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_dyn_fi.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_dyn_fi.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_dyn_fi.f90	(revision 5105)
@@ -0,0 +1,40 @@
+
+! $Header$
+
+SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
+  IMPLICIT NONE
+  !=======================================================================
+  !   passage d'un champ de la grille scalaire a la grille physique
+  !=======================================================================
+
+  !-----------------------------------------------------------------------
+  !   declarations:
+  !   -------------
+
+  INTEGER :: im,jm,ngrid,nfield
+  REAL :: pdyn(im,jm,nfield)
+  REAL :: pfi(ngrid,nfield)
+
+  INTEGER :: j,ifield,ig
+
+  !-----------------------------------------------------------------------
+  !   calcul:
+  !   -------
+
+  IF (ngrid/=2+(jm-2)*(im-1)) then
+     CALL abort_gcm("gr_dyn_fi", 'probleme de dim', 1)
+  end if
+  !   traitement des poles
+  CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
+  CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
+
+  !   traitement des point normaux
+  DO ifield=1,nfield
+     DO j=2,jm-1
+        ig=2+(j-2)*(im-1)
+        CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
+     ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE gr_dyn_fi
Index: DZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_fi_dyn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_fi_dyn.F	(revision 5104)
+++ 	(revision )
@@ -1,40 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
-      IMPLICIT NONE
-c=======================================================================
-c   passage d'un champ de la grille scalaire a la grille physique
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
-
-      INTEGER i,j,ifield,ig
-
-c-----------------------------------------------------------------------
-c   calcul:
-c   -------
-
-      DO ifield=1,nfield
-c   traitement des poles
-         DO i=1,im
-            pdyn(i,1,ifield)=pfi(1,ifield)
-            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
-         ENDDO
-
-c   traitement des point normaux
-         DO j=2,jm-1
-	    ig=2+(j-2)*(im-1)
-            CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
-	    pdyn(im,j,ifield)=pdyn(1,j,ifield)
-         ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_fi_dyn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_fi_dyn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_fi_dyn.f90	(revision 5105)
@@ -0,0 +1,40 @@
+
+! $Header$
+
+SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+  IMPLICIT NONE
+  !=======================================================================
+  !   passage d'un champ de la grille scalaire a la grille physique
+  !=======================================================================
+
+  !-----------------------------------------------------------------------
+  !   declarations:
+  !   -------------
+
+  INTEGER :: im,jm,ngrid,nfield
+  REAL :: pdyn(im,jm,nfield)
+  REAL :: pfi(ngrid,nfield)
+
+  INTEGER :: i,j,ifield,ig
+
+  !-----------------------------------------------------------------------
+  !   calcul:
+  !   -------
+
+  DO ifield=1,nfield
+  !   traitement des poles
+     DO i=1,im
+        pdyn(i,1,ifield)=pfi(1,ifield)
+        pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+     ENDDO
+
+  !   traitement des point normaux
+     DO j=2,jm-1
+        ig=2+(j-2)*(im-1)
+        CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
+        pdyn(im,j,ifield)=pdyn(1,j,ifield)
+     ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE gr_fi_dyn
Index: DZ6/branches/Amaury_dev/libf/filtrez/acc.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/acc.F	(revision 5104)
+++ 	(revision )
@@ -1,22 +1,0 @@
-
-! $Header$
-
-        SUBROUTINE acc(vec,d,im)
-        implicit none
-        integer :: im
-        real :: vec(im,im),d(im)
-        integer :: i,j
-        real ::sum
-        real,external :: ssum
-        do j=1,im
-          do i=1,im
-            d(i)=vec(i,j)*vec(i,j)
-          enddo
-          sum=ssum(im,d,1)
-          sum=sqrt(sum)
-          do i=1,im
-            vec(i,j)=vec(i,j)/sum
-          enddo
-        enddo
-        return
-        end
Index: /LMDZ6/branches/Amaury_dev/libf/filtrez/acc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/acc.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/filtrez/acc.f90	(revision 5105)
@@ -0,0 +1,22 @@
+
+! $Header$
+
+  SUBROUTINE acc(vec,d,im)
+    implicit none
+    integer :: im
+    real :: vec(im,im),d(im)
+    integer :: i,j
+    real ::sum
+    real,external :: ssum
+    do j=1,im
+      do i=1,im
+        d(i)=vec(i,j)*vec(i,j)
+      enddo
+      sum=ssum(im,d,1)
+      sum=sqrt(sum)
+      do i=1,im
+        vec(i,j)=vec(i,j)/sum
+      enddo
+    enddo
+    return
+end subroutine acc
Index: DZ6/branches/Amaury_dev/libf/filtrez/eigen.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen.F	(revision 5104)
+++ 	(revision )
@@ -1,33 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE eigen( e,d)
-      IMPLICIT NONE
-      INCLUDE "dimensions.h"
-      real :: e( iim,iim ), d( iim )
-      real :: asm( iim )
-      integer :: im,i,j
-      im=iim
-c
-      DO i = 1,im
-	 asm( i ) = d( im-i+1 )
-      END DO
-      DO i = 1,iim
-	 d( i ) = asm( i )
-      END DO
-c
-c     PRINT 70,d
- 70   FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/)
-		print *
-c
-      DO i = 1,im
-	 DO j = 1,im
-            asm( j ) = e( i , im-j+1 )
-      END DO
-	 DO j = 1,im
-	    e( i,j ) = asm( j )
-      END DO
-      END DO
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen.f90	(revision 5105)
@@ -0,0 +1,33 @@
+
+! $Header$
+
+SUBROUTINE eigen( e,d)
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  real :: e( iim,iim ), d( iim )
+  real :: asm( iim )
+  integer :: im,i,j
+  im=iim
+  !
+  DO i = 1,im
+     asm( i ) = d( im-i+1 )
+  END DO
+  DO i = 1,iim
+     d( i ) = asm( i )
+  END DO
+  !
+  ! PRINT 70,d
+ 70   FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/)
+            print *
+  !
+  DO i = 1,im
+     DO j = 1,im
+        asm( j ) = e( i , im-j+1 )
+  END DO
+     DO j = 1,im
+        e( i,j ) = asm( j )
+  END DO
+  END DO
+
+  RETURN
+END SUBROUTINE eigen
Index: DZ6/branches/Amaury_dev/libf/filtrez/eigen_sort.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen_sort.F	(revision 5104)
+++ 	(revision )
@@ -1,32 +1,0 @@
-
-! $Header$
-
-          SUBROUTINE eigen_sort(d,v,n,np)
-          INTEGER n,np
-          REAL d(np),v(np,np)
-          INTEGER i,j,k
-          REAL p
-
-       DO i=1,n-1
-          k=i
-          p=d(i)
-        DO j=i+1,n
-           IF(d(j)>=p) THEN
-            k=j
-            p=d(j)
-           ENDIF
-        ENDDO
-          
-        IF(k/=i) THEN
-          d(k)=d(i)
-          d(i)=p
-         DO j=1,n
-          p=v(j,i)
-          v(j,i)=v(j,k)
-          v(j,k)=p
-         ENDDO
-        ENDIF
-       ENDDO
-
-        RETURN
-        END
Index: /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen_sort.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen_sort.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/filtrez/eigen_sort.f90	(revision 5105)
@@ -0,0 +1,32 @@
+
+! $Header$
+
+    SUBROUTINE eigen_sort(d,v,n,np)
+      INTEGER :: n,np
+      REAL :: d(np),v(np,np)
+      INTEGER :: i,j,k
+      REAL :: p
+
+   DO i=1,n-1
+      k=i
+      p=d(i)
+    DO j=i+1,n
+       IF(d(j)>=p) THEN
+        k=j
+        p=d(j)
+       ENDIF
+    ENDDO
+
+    IF(k/=i) THEN
+      d(k)=d(i)
+      d(i)=p
+     DO j=1,n
+      p=v(j,i)
+      v(j,i)=v(j,k)
+      v(j,k)=p
+     ENDDO
+    ENDIF
+   ENDDO
+
+    RETURN
+END SUBROUTINE eigen_sort
Index: DZ6/branches/Amaury_dev/libf/filtrez/filtreg.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/filtreg.F	(revision 5104)
+++ 	(revision )
@@ -1,321 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire,
-     &     griscal ,iter)
-      
-      USE filtreg_mod
-      
-      IMPLICIT NONE
-c=======================================================================
-c
-c   Auteur: P. Le Van        07/10/97
-c   ------
-c
-c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
-c                     pour l'operateur  Filtre    .
-c   ------
-c
-c   Arguments:
-c   ----------
-c
-c      nblat                 nombre de latitudes a filtrer
-c      nbniv                 nombre de niveaux verticaux a filtrer
-c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
-c                            en sortie : champ filtre
-c      ifiltre               +1  Transformee directe
-c                            -1  Transformee inverse
-c                            +2  Filtre directe
-c                            -2  Filtre inverse
-c
-c      iaire                 1   si champ intensif
-c                            2   si champ extensif (pondere par les aires)
-c
-c      iter                  1   filtre simple
-c
-c=======================================================================
-c
-c
-c                      Variable Intensive
-c                ifiltre = 1     filtre directe
-c                ifiltre =-1     filtre inverse
-c
-c                      Variable Extensive
-c                ifiltre = 2     filtre directe
-c                ifiltre =-2     filtre inverse
-c
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "coefils.h"
-
-      INTEGER    nlat,nbniv,ifiltre,iter
-      INTEGER    i,j,l,k
-      INTEGER    iim2,immjm
-      INTEGER    jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
-
-      REAL       champ( iip1,nlat,nbniv)
-
-      REAL       eignq(iim,nlat,nbniv), sdd1(iim),sdd2(iim)
-      LOGICAL    griscal
-      INTEGER    hemisph, iaire
-
-      LOGICAL,SAVE     :: first=.TRUE.
-
-      REAL, SAVE :: sdd12(iim,4)
-
-      INTEGER, PARAMETER :: type_sddu=1
-      INTEGER, PARAMETER :: type_sddv=2
-      INTEGER, PARAMETER :: type_unsddu=3
-      INTEGER, PARAMETER :: type_unsddv=4
-
-      INTEGER :: sdd1_type, sdd2_type
-
-      if ( iim == 1 ) return ! no filtre in 2D y-z
-
-      IF (first) THEN
-         sdd12(1:iim,type_sddu) = sddu(1:iim)
-         sdd12(1:iim,type_sddv) = sddv(1:iim)
-         sdd12(1:iim,type_unsddu) = unsddu(1:iim)
-         sdd12(1:iim,type_unsddv) = unsddv(1:iim)
-
-         first=.FALSE.
-      ENDIF
-
-      IF(ifiltre==1.or.ifiltre==-1)
-     &     STOP'Pas de transformee simple dans cette version'
-      
-      IF( iter== 2 )  THEN
-         PRINT *,' Pas d iteration du filtre dans cette version !'
-     &        , ' Utiliser old_filtreg et repasser !'
-         STOP
-      ENDIF
-      
-      IF( ifiltre== -2 .AND..NOT.griscal )     THEN
-         PRINT *,' Cette routine ne calcule le filtre inverse que '
-     &        , ' sur la grille des scalaires !'
-         STOP
-      ENDIF
-      
-      IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
-         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
-     &        , ' corriger et repasser !'
-         STOP
-      ENDIF
-      
-      iim2   = iim * iim
-      immjm  = iim * jjm
-
-      IF( griscal )   THEN
-         IF( nlat. NE. jjp1 )  THEN
-            PRINT  1111
-            STOP
-         ELSE
-            
-            IF( iaire==1 )  THEN
-               sdd1_type = type_sddv
-               sdd2_type = type_unsddv
-            ELSE
-               sdd1_type = type_unsddv
-               sdd2_type = type_sddv
-            ENDIF
-
-c            IF( iaire.EQ.1 )  THEN
-c               CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 ) 
-c               CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
-c            ELSE
-c               CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
-c               CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
-c            END IF
-            
-            jdfil1 = 2
-            jffil1 = jfiltnu
-            jdfil2 = jfiltsu
-            jffil2 = jjm
-         END IF
-      ELSE
-         IF( nlat/=jjm )  THEN
-            PRINT  2222
-            STOP
-         ELSE
-            
-            IF( iaire==1 )  THEN
-               sdd1_type = type_sddu
-               sdd2_type = type_unsddu
-            ELSE
-               sdd1_type = type_unsddu
-               sdd2_type = type_sddu
-            ENDIF
-
-c            IF( iaire.EQ.1 )  THEN
-c               CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 ) 
-c               CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
-c            ELSE
-c               CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
-c               CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
-c            END IF
-            
-            jdfil1 = 1
-            jffil1 = jfiltnv
-            jdfil2 = jfiltsv
-            jffil2 = jjm
-         END IF
-      END IF
-      
-      DO hemisph = 1, 2
-         
-         IF ( hemisph==1 )  THEN
-            jdfil = jdfil1
-            jffil = jffil1
-         ELSE
-            jdfil = jdfil2
-            jffil = jffil2
-         END IF
-         
-         DO l = 1, nbniv
-            DO j = jdfil,jffil
-               DO i = 1, iim
-                  champ(i,j,l) = champ(i,j,l) * sdd12(i,sdd1_type) ! sdd1(i)
-               END DO
-            END DO
-         END DO
-         
-         IF( hemisph == 1 )      THEN
-            
-            IF( ifiltre == -2 )   THEN
-               
-               DO j = jdfil,jffil
-#ifdef BLAS
-                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
-     &                 matrinvn(1,1,j),
-     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
-     &                 eignq(1,j-jdfil+1,1), iim*nlat)
-#else
-                  eignq(:,j-jdfil+1,:)
-     $                 = matmul(matrinvn(:,:,j), champ(:iim,j,:))
-#endif
-               END DO
-               
-            ELSE IF ( griscal )     THEN
-               
-               DO j = jdfil,jffil
-#ifdef BLAS
-                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
-     &                 matriceun(1,1,j),
-     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
-     &                 eignq(1,j-jdfil+1,1), iim*nlat)
-#else
-                  eignq(:,j-jdfil+1,:)
-     $                 = matmul(matriceun(:,:,j), champ(:iim,j,:))
-#endif
-               END DO
-               
-            ELSE 
-               
-               DO j = jdfil,jffil
-#ifdef BLAS
-                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
-     &                 matricevn(1,1,j),
-     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
-     &                 eignq(1,j-jdfil+1,1), iim*nlat)
-#else
-                  eignq(:,j-jdfil+1,:)
-     $                 = matmul(matricevn(:,:,j), champ(:iim,j,:))
-#endif
-               END DO
-               
-            ENDIF
-            
-         ELSE
-            
-            IF( ifiltre == -2 )   THEN
-               
-               DO j = jdfil,jffil
-#ifdef BLAS
-                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
-     &                 matrinvs(1,1,j-jfiltsu+1),
-     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
-     &                 eignq(1,j-jdfil+1,1), iim*nlat)
-#else
-                  eignq(:,j-jdfil+1,:)
-     $                 = matmul(matrinvs(:,:,j-jfiltsu+1),
-     $                 champ(:iim,j,:))
-#endif
-               END DO
-               
-               
-            ELSE IF ( griscal )     THEN
-               
-               DO j = jdfil,jffil
-#ifdef BLAS
-                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
-     &                 matriceus(1,1,j-jfiltsu+1),
-     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
-     &                 eignq(1,j-jdfil+1,1), iim*nlat)
-#else
-                  eignq(:,j-jdfil+1,:)
-     $                 = matmul(matriceus(:,:,j-jfiltsu+1),
-     $                 champ(:iim,j,:))
-#endif
-               END DO
-                              
-            ELSE 
-               
-               DO j = jdfil,jffil
-#ifdef BLAS
-                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
-     &                 matricevs(1,1,j-jfiltsv+1),
-     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
-     &                 eignq(1,j-jdfil+1,1), iim*nlat)
-#else
-                  eignq(:,j-jdfil+1,:)
-     $                 = matmul(matricevs(:,:,j-jfiltsv+1),
-     $                 champ(:iim,j,:))
-#endif
-               END DO
-                              
-            ENDIF
-            
-         ENDIF
-         
-         IF( ifiltre== 2 )  THEN
-            
-            DO l = 1, nbniv
-               DO j = jdfil,jffil
-                  DO i = 1, iim
-                     champ( i,j,l ) = 
-     &                    (champ(i,j,l) + eignq(i,j-jdfil+1,l))
-     &                    * sdd12(i,sdd2_type) ! sdd2(i)
-                  END DO
-               END DO
-            END DO
-
-         ELSE
-
-            DO l = 1, nbniv
-               DO j = jdfil,jffil
-                  DO i = 1, iim
-                     champ( i,j,l ) = 
-     &                    (champ(i,j,l) - eignq(i,j-jdfil+1,l))
-     &                    * sdd12(i,sdd2_type) ! sdd2(i)
-                  END DO
-               END DO
-            END DO
-
-         ENDIF
-
-         DO l = 1, nbniv
-            DO j = jdfil,jffil
-               champ( iip1,j,l ) = champ( 1,j,l )
-            END DO
-         END DO
-
-     
-      ENDDO
-
-1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
-     &     filtrer, sur la grille des scalaires'/)
-2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
-     &     ltrer, sur la grille de V ou de Z'/)
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/filtrez/filtreg.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/filtreg.F90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/filtrez/filtreg.F90	(revision 5105)
@@ -0,0 +1,321 @@
+
+! $Header$
+
+SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire, &
+        griscal ,iter)
+
+  USE filtreg_mod
+
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   Auteur: P. Le Van        07/10/97
+  !   ------
+  !
+  !   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+  !                 pour l'operateur  Filtre    .
+  !   ------
+  !
+  !   Arguments:
+  !   ----------
+  !
+  !  nblat                 nombre de latitudes a filtrer
+  !  nbniv                 nombre de niveaux verticaux a filtrer
+  !  champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+  !                        en sortie : champ filtre
+  !  ifiltre               +1  Transformee directe
+  !                        -1  Transformee inverse
+  !                        +2  Filtre directe
+  !                        -2  Filtre inverse
+  !
+  !  iaire                 1   si champ intensif
+  !                        2   si champ extensif (pondere par les aires)
+  !
+  !  iter                  1   filtre simple
+  !
+  !=======================================================================
+  !
+  !
+  !                  Variable Intensive
+  !            ifiltre = 1     filtre directe
+  !            ifiltre =-1     filtre inverse
+  !
+  !                  Variable Extensive
+  !            ifiltre = 2     filtre directe
+  !            ifiltre =-2     filtre inverse
+  !
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "coefils.h"
+
+  INTEGER :: nlat,nbniv,ifiltre,iter
+  INTEGER :: i,j,l,k
+  INTEGER :: iim2,immjm
+  INTEGER :: jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+  REAL :: champ( iip1,nlat,nbniv)
+
+  REAL :: eignq(iim,nlat,nbniv), sdd1(iim),sdd2(iim)
+  LOGICAL :: griscal
+  INTEGER :: hemisph, iaire
+
+  LOGICAL,SAVE     :: first=.TRUE.
+
+  REAL, SAVE :: sdd12(iim,4)
+
+  INTEGER, PARAMETER :: type_sddu=1
+  INTEGER, PARAMETER :: type_sddv=2
+  INTEGER, PARAMETER :: type_unsddu=3
+  INTEGER, PARAMETER :: type_unsddv=4
+
+  INTEGER :: sdd1_type, sdd2_type
+
+  if ( iim == 1 ) return ! no filtre in 2D y-z
+
+  IF (first) THEN
+     sdd12(1:iim,type_sddu) = sddu(1:iim)
+     sdd12(1:iim,type_sddv) = sddv(1:iim)
+     sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+     sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+
+     first=.FALSE.
+  ENDIF
+
+  IF(ifiltre==1.or.ifiltre==-1) &
+        stop 'Pas de transformee simple dans cette version'
+
+  IF( iter== 2 )  THEN
+     PRINT *,' Pas d iteration du filtre dans cette version !'&
+           &        , ' Utiliser old_filtreg et repasser !'
+     STOP
+  ENDIF
+
+  IF( ifiltre== -2 .AND..NOT.griscal )     THEN
+     PRINT *,' Cette routine ne calcule le filtre inverse que ' &
+           , ' sur la grille des scalaires !'
+     STOP
+  ENDIF
+
+  IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
+     PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
+           , ' corriger et repasser !'
+     STOP
+  ENDIF
+
+  iim2   = iim * iim
+  immjm  = iim * jjm
+
+  IF( griscal )   THEN
+     IF( nlat /= jjp1 )  THEN
+        PRINT  1111
+        STOP
+     ELSE
+
+        IF( iaire==1 )  THEN
+           sdd1_type = type_sddv
+           sdd2_type = type_unsddv
+        ELSE
+           sdd1_type = type_unsddv
+           sdd2_type = type_sddv
+        ENDIF
+
+         ! IF( iaire.EQ.1 )  THEN
+         !    CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 )
+         !    CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
+         ! ELSE
+         !    CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
+         !    CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
+         ! END IF
+
+        jdfil1 = 2
+        jffil1 = jfiltnu
+        jdfil2 = jfiltsu
+        jffil2 = jjm
+     END IF
+  ELSE
+     IF( nlat/=jjm )  THEN
+        PRINT  2222
+        STOP
+     ELSE
+
+        IF( iaire==1 )  THEN
+           sdd1_type = type_sddu
+           sdd2_type = type_unsddu
+        ELSE
+           sdd1_type = type_unsddu
+           sdd2_type = type_sddu
+        ENDIF
+
+         ! IF( iaire.EQ.1 )  THEN
+         !    CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 )
+         !    CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
+         ! ELSE
+         !    CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
+         !    CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
+         ! END IF
+
+        jdfil1 = 1
+        jffil1 = jfiltnv
+        jdfil2 = jfiltsv
+        jffil2 = jjm
+     END IF
+  END IF
+
+  DO hemisph = 1, 2
+
+     IF ( hemisph==1 )  THEN
+        jdfil = jdfil1
+        jffil = jffil1
+     ELSE
+        jdfil = jdfil2
+        jffil = jffil2
+     END IF
+
+     DO l = 1, nbniv
+        DO j = jdfil,jffil
+           DO i = 1, iim
+              champ(i,j,l) = champ(i,j,l) * sdd12(i,sdd1_type) ! sdd1(i)
+           END DO
+        END DO
+     END DO
+
+     IF( hemisph == 1 )      THEN
+
+        IF( ifiltre == -2 )   THEN
+
+           DO j = jdfil,jffil
+#ifdef BLAS
+              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
+                    matrinvn(1,1,j), &
+                    iim, champ(1,j,1), iip1*nlat, 0.0, &
+                    eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+              eignq(:,j-jdfil+1,:) &
+                    = matmul(matrinvn(:,:,j), champ(:iim,j,:))
+#endif
+           END DO
+
+        ELSE IF ( griscal )     THEN
+
+           DO j = jdfil,jffil
+#ifdef BLAS
+              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
+                    matriceun(1,1,j), &
+                    iim, champ(1,j,1), iip1*nlat, 0.0, &
+                    eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+              eignq(:,j-jdfil+1,:) &
+                    = matmul(matriceun(:,:,j), champ(:iim,j,:))
+#endif
+           END DO
+
+        ELSE
+
+           DO j = jdfil,jffil
+#ifdef BLAS
+              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
+                    matricevn(1,1,j), &
+                    iim, champ(1,j,1), iip1*nlat, 0.0, &
+                    eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+              eignq(:,j-jdfil+1,:) &
+                    = matmul(matricevn(:,:,j), champ(:iim,j,:))
+#endif
+           END DO
+
+        ENDIF
+
+     ELSE
+
+        IF( ifiltre == -2 )   THEN
+
+           DO j = jdfil,jffil
+#ifdef BLAS
+              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
+                    matrinvs(1,1,j-jfiltsu+1), &
+                    iim, champ(1,j,1), iip1*nlat, 0.0, &
+                    eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+              eignq(:,j-jdfil+1,:) &
+                    = matmul(matrinvs(:,:,j-jfiltsu+1), &
+                    champ(:iim,j,:))
+#endif
+           END DO
+
+
+        ELSE IF ( griscal )     THEN
+
+           DO j = jdfil,jffil
+#ifdef BLAS
+              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
+                    matriceus(1,1,j-jfiltsu+1), &
+                    iim, champ(1,j,1), iip1*nlat, 0.0, &
+                    eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+              eignq(:,j-jdfil+1,:) &
+                    = matmul(matriceus(:,:,j-jfiltsu+1), &
+                    champ(:iim,j,:))
+#endif
+           END DO
+
+        ELSE
+
+           DO j = jdfil,jffil
+#ifdef BLAS
+              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
+                    matricevs(1,1,j-jfiltsv+1), &
+                    iim, champ(1,j,1), iip1*nlat, 0.0, &
+                    eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+              eignq(:,j-jdfil+1,:) &
+                    = matmul(matricevs(:,:,j-jfiltsv+1), &
+                    champ(:iim,j,:))
+#endif
+           END DO
+
+        ENDIF
+
+     ENDIF
+
+     IF( ifiltre== 2 )  THEN
+
+        DO l = 1, nbniv
+           DO j = jdfil,jffil
+              DO i = 1, iim
+                 champ( i,j,l ) = &
+                       (champ(i,j,l) + eignq(i,j-jdfil+1,l)) &
+                       * sdd12(i,sdd2_type) ! sdd2(i)
+              END DO
+           END DO
+        END DO
+
+     ELSE
+
+        DO l = 1, nbniv
+           DO j = jdfil,jffil
+              DO i = 1, iim
+                 champ( i,j,l ) = &
+                       (champ(i,j,l) - eignq(i,j-jdfil+1,l)) &
+                       * sdd12(i,sdd2_type) ! sdd2(i)
+              END DO
+           END DO
+        END DO
+
+     ENDIF
+
+     DO l = 1, nbniv
+        DO j = jdfil,jffil
+           champ( iip1,j,l ) = champ( 1,j,l )
+        END DO
+     END DO
+
+
+  ENDDO
+
+1111   FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a&
+             &     filtrer, sur la grille des scalaires'/)
+2222   FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi&
+             &     ltrer, sur la grille de V ou de Z'/)
+  RETURN
+END SUBROUTINE filtreg
Index: DZ6/branches/Amaury_dev/libf/filtrez/inifgn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/inifgn.F	(revision 5104)
+++ 	(revision )
@@ -1,103 +1,0 @@
-
-! $Header: /home/cvsroot/LMDZ4/libf/filtrez/inifgn.F,v 1.1.1.1 2004-05-19 12:53:09 lmdzadmin Exp $
-
-      SUBROUTINE inifgn(dv)
-c  
-c    ...  H.Upadyaya , O.Sharma  ... 
-c
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-
-c
-      REAL vec(iim,iim),vec1(iim,iim)
-      REAL dlonu(iim),dlonv(iim)
-      REAL du(iim),dv(iim),d(iim)
-      REAL pi
-      INTEGER i,j,k,imm1,nrot
-C
-      include "coefils.h"
-c
-      EXTERNAL SSUM, acc,eigen,jacobi
-      REAL SSUM
-c
-
-      imm1  = iim -1
-      pi = 2.* ASIN(1.)
-C
-      DO i=1,iim
-       dlonu(i)=  xprimu( i )
-       dlonv(i)=  xprimv( i )
-      END DO
-
-      DO i=1,iim
-      sddv(i)   = SQRT(dlonv(i))
-      sddu(i)   = SQRT(dlonu(i))
-      unsddu(i) = 1./sddu(i)
-      unsddv(i) = 1./sddv(i)
-      END DO
-C
-      DO j=1,iim
-      DO i=1,iim
-      vec(i,j)     = 0.
-      vec1(i,j)    = 0.
-      eignfnv(i,j) = 0.
-      eignfnu(i,j) = 0.
-      END DO
-      END DO
-c
-c
-      eignfnv(1,1)    = -1.
-      eignfnv(iim,1)  =  1.
-      DO i=1,imm1
-      eignfnv(i+1,i+1)= -1.
-      eignfnv(i,i+1)  =  1.
-      END DO
-      DO j=1,iim
-      DO i=1,iim
-      eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j))
-      END DO
-      END DO
-      DO j=1,iim
-      DO i=1,iim
-      eignfnu(i,j) = -eignfnv(j,i)
-      END DO
-      END DO
-c
-      DO j = 1, iim
-      DO i = 1, iim
-        vec (i,j) = 0.0
-        vec1(i,j) = 0.0
-       DO k = 1, iim
-        vec (i,j) = vec(i,j)  + eignfnu(i,k) * eignfnv(k,j)
-        vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j)
-       ENDDO
-      ENDDO
-      ENDDO
-
-c
-      CALL jacobi(vec,iim,iim,dv,eignfnv,nrot)
-      CALL acc(eignfnv,d,iim)
-      CALL eigen_sort(dv,eignfnv,iim,iim)
-c
-      CALL jacobi(vec1,iim,iim,du,eignfnu,nrot)
-      CALL acc(eignfnu,d,iim)
-      CALL eigen_sort(du,eignfnu,iim,iim)
-
-cc   ancienne version avec appels IMSL
-c
-c     CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim)
-c     CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
-c     CALL EVCSF(iim,vec,iim,dv,eignfnv,iim)
-c     CALL acc(eignfnv,d,iim)
-c     CALL eigen(eignfnv,dv)
-c
-c     CALL EVCSF(iim,vec1,iim,du,eignfnu,iim)
-c     CALL acc(eignfnu,d,iim)
-c     CALL eigen(eignfnu,du)
-
-      RETURN
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/filtrez/inifgn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/inifgn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/filtrez/inifgn.f90	(revision 5105)
@@ -0,0 +1,103 @@
+
+! $Header: /home/cvsroot/LMDZ4/libf/filtrez/inifgn.F,v 1.1.1.1 2004-05-19 12:53:09 lmdzadmin Exp $
+
+SUBROUTINE inifgn(dv)
+  !
+  !    ...  H.Upadyaya , O.Sharma  ...
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  !
+  REAL :: vec(iim,iim),vec1(iim,iim)
+  REAL :: dlonu(iim),dlonv(iim)
+  REAL :: du(iim),dv(iim),d(iim)
+  REAL :: pi
+  INTEGER :: i,j,k,imm1,nrot
+  !
+  include "coefils.h"
+  !
+  EXTERNAL SSUM, acc,eigen,jacobi
+  REAL :: SSUM
+  !
+
+  imm1  = iim -1
+  pi = 2.* ASIN(1.)
+  !
+  DO i=1,iim
+   dlonu(i)=  xprimu( i )
+   dlonv(i)=  xprimv( i )
+  END DO
+
+  DO i=1,iim
+  sddv(i)   = SQRT(dlonv(i))
+  sddu(i)   = SQRT(dlonu(i))
+  unsddu(i) = 1./sddu(i)
+  unsddv(i) = 1./sddv(i)
+  END DO
+  !
+  DO j=1,iim
+  DO i=1,iim
+  vec(i,j)     = 0.
+  vec1(i,j)    = 0.
+  eignfnv(i,j) = 0.
+  eignfnu(i,j) = 0.
+  END DO
+  END DO
+  !
+  !
+  eignfnv(1,1)    = -1.
+  eignfnv(iim,1)  =  1.
+  DO i=1,imm1
+  eignfnv(i+1,i+1)= -1.
+  eignfnv(i,i+1)  =  1.
+  END DO
+  DO j=1,iim
+  DO i=1,iim
+  eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j))
+  END DO
+  END DO
+  DO j=1,iim
+  DO i=1,iim
+  eignfnu(i,j) = -eignfnv(j,i)
+  END DO
+  END DO
+  !
+  DO j = 1, iim
+  DO i = 1, iim
+    vec (i,j) = 0.0
+    vec1(i,j) = 0.0
+   DO k = 1, iim
+    vec (i,j) = vec(i,j)  + eignfnu(i,k) * eignfnv(k,j)
+    vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j)
+   ENDDO
+  ENDDO
+  ENDDO
+
+  !
+  CALL jacobi(vec,iim,iim,dv,eignfnv,nrot)
+  CALL acc(eignfnv,d,iim)
+  CALL eigen_sort(dv,eignfnv,iim,iim)
+  !
+  CALL jacobi(vec1,iim,iim,du,eignfnu,nrot)
+  CALL acc(eignfnu,d,iim)
+  CALL eigen_sort(du,eignfnu,iim,iim)
+
+  !c   ancienne version avec appels IMSL
+  !
+  ! CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim)
+  ! CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+  !     CALL EVCSF(iim,vec,iim,dv,eignfnv,iim)
+  ! CALL acc(eignfnv,d,iim)
+  ! CALL eigen(eignfnv,dv)
+  !
+  ! CALL EVCSF(iim,vec1,iim,du,eignfnu,iim)
+  ! CALL acc(eignfnu,d,iim)
+  ! CALL eigen(eignfnu,du)
+
+  RETURN
+END SUBROUTINE inifgn
+
Index: /LMDZ6/branches/Amaury_dev/libf/filtrez/jacobi.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/filtrez/jacobi.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/filtrez/jacobi.F90	(revision 5105)
@@ -103,4 +103,4 @@
       ENDDO ! of DO I=1,50
       STOP 'Jacobi: 50 iterations should never happen'
-      RETURN
+
       END SUBROUTINE JACOBI
Index: /LMDZ6/branches/Amaury_dev/libf/grid/fxy_new.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/grid/fxy_new.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/grid/fxy_new.h	(revision 5105)
@@ -2,26 +2,26 @@
 ! $Header$
 
-c--------------------------------------------------------------
-         REAL ripx
-         REAL fx,fxprim,fy,fyprim,ri,rj,bigy
-c
-c....stretching in x...
-c
-        ripx(  ri )= (ri-1.0) *2.*pi/REAL(iim) 
-        fx  (  ri )= ripx(ri) + transx  +
-     *         alphax * SIN( ripx(ri)+transx-pxo ) - pi
-        fxprim(ri) = 2.*pi/REAL(iim)  *
-     *        ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) )
+!--------------------------------------------------------------
+   REAL :: ripx
+   REAL :: fx,fxprim,fy,fyprim,ri,rj,bigy
+!
+!....stretching in x...
+!
+  ripx(  ri )= (ri-1.0) *2.*pi/REAL(iim)
+  fx  (  ri )= ripx(ri) + transx  + &
+        alphax * SIN( ripx(ri)+transx-pxo ) - pi
+  fxprim(ri) = 2.*pi/REAL(iim)  * &
+        ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) )
 
-c....stretching in y...
-c
-        bigy(rj)   = 2.* (REAL(jjp1)-rj ) *pi/jjm
-        fy(rj)     =  ( bigy(rj) + transy  +
-     *        alphay * SIN( bigy(rj)+transy-pyo ) ) /2.  - pi/2.
-        fyprim(rj) = ( pi/jjm ) * ( 1.+
-     *           alphay * COS( bigy(rj)+transy-pyo ) )
+!....stretching in y...
+!
+  bigy(rj)   = 2.* (REAL(jjp1)-rj ) *pi/jjm
+  fy(rj)     =  ( bigy(rj) + transy  + &
+        alphay * SIN( bigy(rj)+transy-pyo ) ) /2.  - pi/2.
+  fyprim(rj) = ( pi/jjm ) * ( 1.+ &
+        alphay * COS( bigy(rj)+transy-pyo ) )
 
-c       fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj-
-c     *  transy ))
-c       fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy)) 
-c--------------------------------------------------------------
+  ! fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj-
+! *  transy ))
+!   fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy))
+!--------------------------------------------------------------
Index: /LMDZ6/branches/Amaury_dev/libf/grid/fxy_reg.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/grid/fxy_reg.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/grid/fxy_reg.h	(revision 5105)
@@ -2,44 +2,44 @@
 ! $Header$
 
-c-----------------------------------------------------------------------
-c INCLUDE 'fxyprim.h'
-c
-c    ................................................................
-c    ................  Fonctions in line  ...........................
-c    ................................................................
-c
-      REAL  fy, fx, fxprim, fyprim
-      REAL  ri, rj
-c
-c
-      fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
-      fyprim( rj ) =    pi/REAL(jjm)
+!-----------------------------------------------------------------------
+! INCLUDE 'fxyprim.h'
+!
+!    ................................................................
+!    ................  Fonctions in line  ...........................
+!    ................................................................
+!
+REAL :: fy, fx, fxprim, fyprim
+REAL :: ri, rj
+!
+!
+fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
+fyprim( rj ) =    pi/REAL(jjm)
 
-c     fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
-c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+! fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
+! fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
 
-      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
-c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
-      fxprim( ri ) = 2.*pi/REAL(iim)
-c
-c
-c    La valeur de pi est passee par le common/const/ou /const2/ .
-c    Sinon, il faut la calculer avant d'appeler ces fonctions .
-c
-c   ----------------------------------------------------------------
-c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
-c   -----------------------------------------------------------------
-c
-c    .....  ici, on a l'application particuliere suivante   ........
-c
-c                **************************************
-c                **     x = 2. * pi/iim *  X         **
-c                **     y =      pi/jjm *  Y         **
-c                **************************************
-c
-c   ..................................................................
-c   ..................................................................
-c
-c
-c
-c-----------------------------------------------------------------------
+fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
+! fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
+fxprim( ri ) = 2.*pi/REAL(iim)
+!
+!
+!    La valeur de pi est passee par le common/const/ou /const2/ .
+!    Sinon, il faut la calculer avant d'appeler ces fonctions .
+!
+!   ----------------------------------------------------------------
+! Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+!   -----------------------------------------------------------------
+!
+!    .....  ici, on a l'application particuliere suivante   ........
+!
+!            **************************************
+!            **     x = 2. * pi/iim *  X         **
+!            **     y =      pi/jjm *  Y         **
+!            **************************************
+!
+!   ..................................................................
+!   ..................................................................
+!
+!
+!
+!-----------------------------------------------------------------------
Index: /LMDZ6/branches/Amaury_dev/libf/grid/fxy_sin.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/grid/fxy_sin.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/grid/fxy_sin.h	(revision 5105)
@@ -2,41 +2,41 @@
 ! $Header$
 
-c-----------------------------------------------------------------------
-c INCLUDE 'fxyprim.h'
-c
-c    ................................................................
-c    ................  Fonctions in line  ...........................
-c    ................................................................
-c
-      REAL  fy, fx, fxprim, fyprim
-      REAL  ri, rj
-c
-c
-      fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
-      fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+!-----------------------------------------------------------------------
+! INCLUDE 'fxyprim.h'
+!
+!    ................................................................
+!    ................  Fonctions in line  ...........................
+!    ................................................................
+!
+REAL :: fy, fx, fxprim, fyprim
+REAL :: ri, rj
+!
+!
+fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
+fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
 
-      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
-c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
-      fxprim( ri ) = 2.*pi/REAL(iim)
-c
-c
-c    La valeur de pi est passee par le common/const/ou /const2/ .
-c    Sinon, il faut la calculer avant d'appeler ces fonctions .
-c
-c   ----------------------------------------------------------------
-c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
-c   -----------------------------------------------------------------
-c
-c    .....  ici, on a l'application particuliere suivante   ........
-c
-c                **************************************
-c                **     x = 2. * pi/iim *  X         **
-c                **     y =      pi/jjm *  Y         **
-c                **************************************
-c
-c   ..................................................................
-c   ..................................................................
-c
-c
-c
-c-----------------------------------------------------------------------
+fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
+! fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
+fxprim( ri ) = 2.*pi/REAL(iim)
+!
+!
+!    La valeur de pi est passee par le common/const/ou /const2/ .
+!    Sinon, il faut la calculer avant d'appeler ces fonctions .
+!
+!   ----------------------------------------------------------------
+! Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+!   -----------------------------------------------------------------
+!
+!    .....  ici, on a l'application particuliere suivante   ........
+!
+!            **************************************
+!            **     x = 2. * pi/iim *  X         **
+!            **     y =      pi/jjm *  Y         **
+!            **************************************
+!
+!   ..................................................................
+!   ..................................................................
+!
+!
+!
+!-----------------------------------------------------------------------
Index: /LMDZ6/branches/Amaury_dev/libf/grid/fxyprim.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/grid/fxyprim.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/grid/fxyprim.h	(revision 5105)
@@ -2,44 +2,44 @@
 ! $Header$
 
-c-----------------------------------------------------------------------
-c INCLUDE 'fxyprim.h'
-c
-c    ................................................................
-c    ................  Fonctions in line  ...........................
-c    ................................................................
-c
-      REAL  fy, fx, fxprim, fyprim
-      REAL  ri, rj
-c
-c
-      fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
-      fyprim( rj ) =    pi/REAL(jjm)
+!-----------------------------------------------------------------------
+! INCLUDE 'fxyprim.h'
+!
+!    ................................................................
+!    ................  Fonctions in line  ...........................
+!    ................................................................
+!
+REAL :: fy, fx, fxprim, fyprim
+REAL :: ri, rj
+!
+!
+fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
+fyprim( rj ) =    pi/REAL(jjm)
 
-c     fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
-c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+! fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
+! fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
 
-      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
-c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
-      fxprim( ri ) = 2.*pi/REAL(iim)
-c
-c
-c    La valeur de pi est passee par le common/const/ou /const2/ .
-c    Sinon, il faut la calculer avant d'appeler ces fonctions .
-c
-c   ----------------------------------------------------------------
-c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
-c   -----------------------------------------------------------------
-c
-c    .....  ici, on a l'application particuliere suivante   ........
-c
-c                **************************************
-c                **     x = 2. * pi/iim *  X         **
-c                **     y =      pi/jjm *  Y         **
-c                **************************************
-c
-c   ..................................................................
-c   ..................................................................
-c
-c
-c
-c-----------------------------------------------------------------------
+fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
+! fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
+fxprim( ri ) = 2.*pi/REAL(iim)
+!
+!
+!    La valeur de pi est passee par le common/const/ou /const2/ .
+!    Sinon, il faut la calculer avant d'appeler ces fonctions .
+!
+!   ----------------------------------------------------------------
+! Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+!   -----------------------------------------------------------------
+!
+!    .....  ici, on a l'application particuliere suivante   ........
+!
+!            **************************************
+!            **     x = 2. * pi/iim *  X         **
+!            **     y =      pi/jjm *  Y         **
+!            **************************************
+!
+!   ..................................................................
+!   ..................................................................
+!
+!
+!
+!-----------------------------------------------------------------------
Index: DZ6/branches/Amaury_dev/libf/misc/cbrt.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/cbrt.F	(revision 5104)
+++ 	(revision )
@@ -1,11 +1,0 @@
-      FUNCTION cbrt(x)
-      ! Return the cubic root for positive or negative x
-      IMPLICIT NONE
-
-      REAL x,cbrt
-
-      cbrt=sign(1.,x)*(abs(x)**(1./3.))
-
-      RETURN
-      END
-
Index: /LMDZ6/branches/Amaury_dev/libf/misc/cbrt.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/cbrt.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/cbrt.f90	(revision 5105)
@@ -0,0 +1,11 @@
+FUNCTION cbrt(x)
+  ! ! Return the cubic root for positive or negative x
+  IMPLICIT NONE
+
+  REAL :: x,cbrt
+
+  cbrt=sign(1.,x)*(abs(x)**(1./3.))
+
+
+END FUNCTION cbrt
+
Index: DZ6/branches/Amaury_dev/libf/misc/chfev.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/chfev.F	(revision 5104)
+++ 	(revision )
@@ -1,155 +1,0 @@
-*DECK CHFEV
-      SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
-C***BEGIN PROLOGUE  CHFEV
-C***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an
-C            array of points.  While designed for use by PCHFE, it may
-C            be useful directly as an evaluator for a piecewise cubic
-C            Hermite function in applications, such as graphing, where
-C            the interval is known in advance.
-C***LIBRARY   SLATEC (PCHIP)
-C***CATEGORY  E3
-C***TYPE      SINGLE PRECISION (CHFEV-S, DCHFEV-D)
-C***KEYWORDS  CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION,
-C             PCHIP
-C***AUTHOR  Fritsch, F. N., (LLNL)
-C             Lawrence Livermore National Laboratory
-C             P.O. Box 808  (L-316)
-C             Livermore, CA  94550
-C             FTS 532-4275, (510) 422-4275
-C***DESCRIPTION
-C
-C          CHFEV:  Cubic Hermite Function EValuator
-C
-C     Evaluates the cubic polynomial determined by function values
-C     F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points
-C     XE(J), J=1(1)NE.
-C
-C ----------------------------------------------------------------------
-C
-C  Calling sequence:
-C
-C        INTEGER  NE, NEXT(2), IERR
-C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE)
-C
-C        CALL  CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR)
-C
-C   Parameters:
-C
-C     X1,X2 -- (input) endpoints of interval of definition of cubic.
-C           (Error return if  X1.EQ.X2 .)
-C
-C     F1,F2 -- (input) values of function at X1 and X2, respectively.
-C
-C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
-C
-C     NE -- (input) number of evaluation points.  (Error return if
-C           NE.LT.1 .)
-C
-C     XE -- (input) real array of points at which the function is to be
-C           evaluated.  If any of the XE are outside the interval
-C           [X1,X2], a warning error is returned in NEXT.
-C
-C     FE -- (output) real array of values of the cubic function defined
-C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
-C
-C     NEXT -- (output) integer array indicating number of extrapolation
-C           points:
-C            NEXT(1) = number of evaluation points to left of interval.
-C            NEXT(2) = number of evaluation points to right of interval.
-C
-C     IERR -- (output) error flag.
-C           Normal return:
-C              IERR = 0  (no errors).
-C           "Recoverable" errors:
-C              IERR = -1  if NE.LT.1 .
-C              IERR = -2  if X1.EQ.X2 .
-C                (The FE-array has not been changed in either case.)
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  XERMSG
-C***REVISION HISTORY  (YYMMDD)
-C   811019  DATE WRITTEN
-C   820803  Minor cosmetic changes for release 1.
-C   890411  Added SAVE statements (Vers. 3.2).
-C   890531  Changed all specific intrinsics to generic.  (WRB)
-C   890703  Corrected category record.  (WRB)
-C   890703  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
-C***END PROLOGUE  CHFEV
-C  Programming notes:
-C
-C     To produce a double precision version, simply:
-C        a. Change CHFEV to DCHFEV wherever it occurs,
-C        b. Change the real declaration to double precision, and
-C        c. Change the constant ZERO to double precision.
-C
-C  DECLARE ARGUMENTS.
-C
-      INTEGER  NE, NEXT(2), IERR
-      REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*)
-C
-C  DECLARE LOCAL VARIABLES.
-C
-      INTEGER  I
-      REAL  C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
-      SAVE ZERO
-      DATA  ZERO /0./
-C
-C  VALIDITY-CHECK ARGUMENTS.
-C
-C***FIRST EXECUTABLE STATEMENT  CHFEV
-      IF (NE < 1)  GO TO 5001
-      H = X2 - X1
-      IF (H == ZERO)  GO TO 5002
-C
-C  INITIALIZE.
-C
-      IERR = 0
-      NEXT(1) = 0
-      NEXT(2) = 0
-      XMI = MIN(ZERO, H)
-      XMA = MAX(ZERO, H)
-C
-C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
-C
-      DELTA = (F2 - F1)/H
-      DEL1 = (D1 - DELTA)/H
-      DEL2 = (D2 - DELTA)/H
-C                                           (DELTA IS NO LONGER NEEDED.)
-      C2 = -(DEL1+DEL1 + DEL2)
-      C3 = (DEL1 + DEL2)/H
-C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
-C
-C  EVALUATION LOOP.
-C
-      DO I = 1, NE
-         X = XE(I) - X1
-         FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
-C          COUNT EXTRAPOLATION POINTS.
-         IF ( X<XMI )  NEXT(1) = NEXT(1) + 1
-         IF ( X>XMA )  NEXT(2) = NEXT(2) + 1
-C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
-      END DO
-C
-C  NORMAL RETURN.
-C
-      RETURN
-C
-C  ERROR RETURNS.
-C
- 5001 CONTINUE
-C     NE.LT.1 RETURN.
-      IERR = -1
-      CALL XERMSG ('SLATEC', 'CHFEV',
-     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
-      RETURN
-C
- 5002 CONTINUE
-C     X1.EQ.X2 RETURN.
-      IERR = -2
-      CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR,
-     +   1)
-      RETURN
-C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/chfev.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/chfev.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/chfev.f90	(revision 5105)
@@ -0,0 +1,155 @@
+!DECK CHFEV
+SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
+  !***BEGIN PROLOGUE  CHFEV
+  !***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an
+         ! array of points.  While designed for use by PCHFE, it may
+         ! be useful directly as an evaluator for a piecewise cubic
+         ! Hermite function in applications, such as graphing, where
+         ! the interval is known in advance.
+  !***LIBRARY   SLATEC (PCHIP)
+  !***CATEGORY  E3
+  !***TYPE      SINGLE PRECISION (CHFEV-S, DCHFEV-D)
+  !***KEYWORDS  CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION,
+         !  PCHIP
+  !***AUTHOR  Fritsch, F. N., (LLNL)
+         !  Lawrence Livermore National Laboratory
+         !  P.O. Box 808  (L-316)
+         !  Livermore, CA  94550
+         !  FTS 532-4275, (510) 422-4275
+  !***DESCRIPTION
+  !
+  !      CHFEV:  Cubic Hermite Function EValuator
+  !
+  ! Evaluates the cubic polynomial determined by function values
+  ! F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points
+  ! XE(J), J=1(1)NE.
+  !
+  ! ----------------------------------------------------------------------
+  !
+  !  Calling sequence:
+  !
+  !    INTEGER  NE, NEXT(2), IERR
+  !    REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE)
+  !
+  !    CALL  CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR)
+  !
+  !   Parameters:
+  !
+  ! X1,X2 -- (input) endpoints of interval of definition of cubic.
+  !       (Error return if  X1.EQ.X2 .)
+  !
+  ! F1,F2 -- (input) values of function at X1 and X2, respectively.
+  !
+  ! D1,D2 -- (input) values of derivative at X1 and X2, respectively.
+  !
+  ! NE -- (input) number of evaluation points.  (Error return if
+  !       NE.LT.1 .)
+  !
+  ! XE -- (input) real array of points at which the function is to be
+  !       evaluated.  If any of the XE are outside the interval
+  !       [X1,X2], a warning error is returned in NEXT.
+  !
+  ! FE -- (output) real array of values of the cubic function defined
+  !       by  X1,X2, F1,F2, D1,D2  at the points  XE.
+  !
+  ! NEXT -- (output) integer array indicating number of extrapolation
+  !       points:
+  !        NEXT(1) = number of evaluation points to left of interval.
+  !        NEXT(2) = number of evaluation points to right of interval.
+  !
+  ! IERR -- (output) error flag.
+  !       Normal return:
+  !          IERR = 0  (no errors).
+  !       "Recoverable" errors:
+  !          IERR = -1  if NE.LT.1 .
+  !          IERR = -2  if X1.EQ.X2 .
+  !            (The FE-array has not been changed in either case.)
+  !
+  !***REFERENCES  (NONE)
+  !***ROUTINES CALLED  XERMSG
+  !***REVISION HISTORY  (YYMMDD)
+  !   811019  DATE WRITTEN
+  !   820803  Minor cosmetic changes for release 1.
+  !   890411  Added SAVE statements (Vers. 3.2).
+  !   890531  Changed all specific intrinsics to generic.  (WRB)
+  !   890703  Corrected category record.  (WRB)
+  !   890703  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+  !***END PROLOGUE  CHFEV
+  !  Programming notes:
+  !
+  ! To produce a double precision version, simply:
+  !    a. Change CHFEV to DCHFEV wherever it occurs,
+  !    b. Change the real declaration to double precision, and
+  !    c. Change the constant ZERO to double precision.
+  !
+  !  DECLARE ARGUMENTS.
+  !
+  INTEGER :: NE, NEXT(2), IERR
+  REAL :: X1, X2, F1, F2, D1, D2, XE(*), FE(*)
+  !
+  !  DECLARE LOCAL VARIABLES.
+  !
+  INTEGER :: I
+  REAL :: C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
+  SAVE ZERO
+  DATA  ZERO /0./
+  !
+  !  VALIDITY-CHECK ARGUMENTS.
+  !
+  !***FIRST EXECUTABLE STATEMENT  CHFEV
+  IF (NE < 1)  GO TO 5001
+  H = X2 - X1
+  IF (H == ZERO)  GO TO 5002
+  !
+  !  INITIALIZE.
+  !
+  IERR = 0
+  NEXT(1) = 0
+  NEXT(2) = 0
+  XMI = MIN(ZERO, H)
+  XMA = MAX(ZERO, H)
+  !
+  !  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
+  !
+  DELTA = (F2 - F1)/H
+  DEL1 = (D1 - DELTA)/H
+  DEL2 = (D2 - DELTA)/H
+                                        ! (DELTA IS NO LONGER NEEDED.)
+  C2 = -(DEL1+DEL1 + DEL2)
+  C3 = (DEL1 + DEL2)/H
+                            ! (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
+  !
+  !  EVALUATION LOOP.
+  !
+  DO I = 1, NE
+     X = XE(I) - X1
+     FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
+       ! COUNT EXTRAPOLATION POINTS.
+     IF ( X<XMI )  NEXT(1) = NEXT(1) + 1
+     IF ( X>XMA )  NEXT(2) = NEXT(2) + 1
+     ! (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
+  END DO
+  !
+  !  NORMAL RETURN.
+  !
+  RETURN
+  !
+  !  ERROR RETURNS.
+  !
+ 5001   CONTINUE
+  ! NE.LT.1 RETURN.
+  IERR = -1
+  CALL XERMSG ('SLATEC', 'CHFEV', &
+        'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
+  RETURN
+  !
+ 5002   CONTINUE
+  ! X1.EQ.X2 RETURN.
+  IERR = -2
+  CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR, &
+        1)
+  RETURN
+  !------------- LAST LINE OF CHFEV FOLLOWS ------------------------------
+END SUBROUTINE CHFEV
Index: DZ6/branches/Amaury_dev/libf/misc/fdump.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/fdump.F	(revision 5104)
+++ 	(revision )
@@ -1,31 +1,0 @@
-*DECK FDUMP
-      SUBROUTINE FDUMP
-C***BEGIN PROLOGUE  FDUMP
-C***PURPOSE  Symbolic dump (should be locally written).
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3
-C***TYPE      ALL (FDUMP-A)
-C***KEYWORDS  ERROR, XERMSG
-C***AUTHOR  Jones, R. E., (SNLA)
-C***DESCRIPTION
-C
-C        ***Note*** Machine Dependent Routine
-C        FDUMP is intended to be replaced by a locally written
-C        version which produces a symbolic dump.  Failing this,
-C        it should be replaced by a version which prints the
-C        subprogram nesting list.  Note that this dump must be
-C        printed on each of up to five files, as indicated by the
-C        XGETUA routine.  See XSETUA and XGETUA for details.
-C
-C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  (NONE)
-C***REVISION HISTORY  (YYMMDD)
-C   790801  DATE WRITTEN
-C   861211  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C***END PROLOGUE  FDUMP
-C***FIRST EXECUTABLE STATEMENT  FDUMP
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/fdump.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/fdump.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/fdump.f90	(revision 5105)
@@ -0,0 +1,31 @@
+!DECK FDUMP
+SUBROUTINE FDUMP
+  !***BEGIN PROLOGUE  FDUMP
+  !***PURPOSE  Symbolic dump (should be locally written).
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3
+  !***TYPE      ALL (FDUMP-A)
+  !***KEYWORDS  ERROR, XERMSG
+  !***AUTHOR  Jones, R. E., (SNLA)
+  !***DESCRIPTION
+  !
+  !    ***Note*** Machine Dependent Routine
+  !    FDUMP is intended to be replaced by a locally written
+  !    version which produces a symbolic dump.  Failing this,
+  !    it should be replaced by a version which prints the
+  !    subprogram nesting list.  Note that this dump must be
+  !    printed on each of up to five files, as indicated by the
+  !    XGETUA routine.  See XSETUA and XGETUA for details.
+  !
+  ! Written by Ron Jones, with SLATEC Common Math Library Subcommittee
+  !
+  !***REFERENCES  (NONE)
+  !***ROUTINES CALLED  (NONE)
+  !***REVISION HISTORY  (YYMMDD)
+  !   790801  DATE WRITTEN
+  !   861211  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !***END PROLOGUE  FDUMP
+  !***FIRST EXECUTABLE STATEMENT  FDUMP
+
+END SUBROUTINE FDUMP
Index: DZ6/branches/Amaury_dev/libf/misc/formcoord.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/formcoord.F	(revision 5104)
+++ 	(revision )
@@ -1,54 +1,0 @@
-
-! $Header$
-
-      SUBROUTINE formcoord(unit,n,x,a,rev,text)
-      implicit none
-      integer n,unit,ndec
-      logical rev
-      real x(n),a
-      character*4 text
-
-      integer i,id,i1,i2,in
-      real dx,dxmin
-
-      if(rev) then
-         id=-1
-         i1=n
-         i2=n-1
-         in=1
-         write(unit,3000) text(1:1)
-      else
-         id=1
-         i1=1
-         i2=2
-         in=n
-      endif
-
-      if (n<2) then
-         ndec=1
-         write(unit,1000) text,n,x(1)*a
-      else
-         dxmin=abs(x(2)-x(1))
-         do i=2,n-1
-            dx=abs(x(i+1)-x(i))
-            if (dx<dxmin) dxmin=dx
-         enddo
-
-         ndec=-log10(dxmin)+2
-         if(mod(n,6)==1) then
-            write(unit,1000) text,n,x(i1)*a
-            write(unit,2000) (x(i)*a,i=i2,in,id)
-         else
-            write(unit,1000) text,n
-            write(unit,2000) (x(i)*a,i=i1,in,id)
-         endif
-      endif
-
-1000  format(a4,2x,i4,' LEVELS',43x,f12.2)
-2000  format(6f12.2)
-c1000  format(a4,2x,i4,' LEVELS',43x,f12.<ndec>)
-c2000  format(6f12.<ndec>)
-3000  format('FORMAT ',a1,'REV')
-      return
-
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/misc/formcoord.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/formcoord.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/formcoord.f90	(revision 5105)
@@ -0,0 +1,54 @@
+
+! $Header$
+
+SUBROUTINE formcoord(unit,n,x,a,rev,text)
+  implicit none
+  integer :: n,unit,ndec
+  logical :: rev
+  real :: x(n),a
+  character(len=4) :: text
+
+  integer :: i,id,i1,i2,in
+  real :: dx,dxmin
+
+  if(rev) then
+     id=-1
+     i1=n
+     i2=n-1
+     in=1
+     write(unit,3000) text(1:1)
+  else
+     id=1
+     i1=1
+     i2=2
+     in=n
+  endif
+
+  if (n<2) then
+     ndec=1
+     write(unit,1000) text,n,x(1)*a
+  else
+     dxmin=abs(x(2)-x(1))
+     do i=2,n-1
+        dx=abs(x(i+1)-x(i))
+        if (dx<dxmin) dxmin=dx
+     enddo
+
+     ndec=-log10(dxmin)+2
+     if(mod(n,6)==1) then
+        write(unit,1000) text,n,x(i1)*a
+        write(unit,2000) (x(i)*a,i=i2,in,id)
+     else
+        write(unit,1000) text,n
+        write(unit,2000) (x(i)*a,i=i1,in,id)
+     endif
+  endif
+
+1000   format(a4,2x,i4,' LEVELS',43x,f12.2)
+2000   format(6f12.2)
+  !1000  format(a4,2x,i4,' LEVELS',43x,f12.<ndec>)
+  !2000  format(6f12.<ndec>)
+3000   format('FORMAT ',a1,'REV')
+
+
+end subroutine formcoord
Index: DZ6/branches/Amaury_dev/libf/misc/i1mach.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/i1mach.F	(revision 5104)
+++ 	(revision )
@@ -1,128 +1,0 @@
-*DECK I1MACH
-      INTEGER FUNCTION I1MACH (I)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  I1MACH
-C***PURPOSE  Return integer machine dependent constants.
-C***LIBRARY   SLATEC
-C***CATEGORY  R1
-C***TYPE      INTEGER (I1MACH-I)
-C***KEYWORDS  MACHINE CONSTANTS
-C***AUTHOR  Fox, P. A., (Bell Labs)
-C           Hall, A. D., (Bell Labs)
-C           Schryer, N. L., (Bell Labs)
-C***DESCRIPTION
-C
-C   I1MACH can be used to obtain machine-dependent parameters for the
-C   local machine environment.  It is a function subprogram with one
-C   (input) argument and can be referenced as follows:
-C
-C        K = I1MACH(I)
-C
-C   where I=1,...,16.  The (output) value of K above is determined by
-C   the (input) value of I.  The results for various values of I are
-C   discussed below.
-C
-C   I/O unit numbers:
-C     I1MACH( 1) = the standard input unit.
-C     I1MACH( 2) = the standard output unit.
-C     I1MACH( 3) = the standard punch unit.
-C     I1MACH( 4) = the standard error message unit.
-C
-C   Words:
-C     I1MACH( 5) = the number of bits per integer storage unit.
-C     I1MACH( 6) = the number of characters per integer storage unit.
-C
-C   Integers:
-C     assume integers are represented in the S-digit, base-A form
-C
-C                sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
-C
-C                where 0 .LE. X(I) .LT. A for I=0,...,S-1.
-C     I1MACH( 7) = A, the base.
-C     I1MACH( 8) = S, the number of base-A digits.
-C     I1MACH( 9) = A**S - 1, the largest magnitude.
-C
-C   Floating-Point Numbers:
-C     Assume floating-point numbers are represented in the T-digit,
-C     base-B form
-C                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
-C
-C                where 0 .LE. X(I) .LT. B for I=1,...,T,
-C                0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
-C     I1MACH(10) = B, the base.
-C
-C   Single-Precision:
-C     I1MACH(11) = T, the number of base-B digits.
-C     I1MACH(12) = EMIN, the smallest exponent E.
-C     I1MACH(13) = EMAX, the largest exponent E.
-C
-C   Double-Precision:
-C     I1MACH(14) = T, the number of base-B digits.
-C     I1MACH(15) = EMIN, the smallest exponent E.
-C     I1MACH(16) = EMAX, the largest exponent E.
-C
-C   To alter this function for a particular environment, the desired
-C   set of DATA statements should be activated by removing the C from
-C   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
-C   checked for consistency with the local operating system.
-C
-C***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
-C                 a portable library, ACM Transactions on Mathematical
-C                 Software 4, 2 (June 1978), pp. 177-188.
-C***ROUTINES CALLED  (NONE)
-C***REVISION HISTORY  (YYMMDD)
-C   750101  DATE WRITTEN
-C   891012  Added VAX G-floating constants.  (WRB)
-C   891012  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900618  Added DEC RISC constants.  (WRB)
-C   900723  Added IBM RS 6000 constants.  (WRB)
-C   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
-C           (RWC)
-C   910710  Added HP 730 constants.  (SMR)
-C   911114  Added Convex IEEE constants.  (WRB)
-C   920121  Added SUN -r8 compiler option constants.  (WRB)
-C   920229  Added Touchstone Delta i860 constants.  (WRB)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C   920625  Added Convex -p8 and -pd8 compiler option constants.
-C           (BKS, WRB)
-C   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
-C   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
-C           options.  (DWL, RWC and WRB).
-C   100623  Use Fortran 95 intrinsic functions (Lionel GUEZ)
-C***END PROLOGUE  I1MACH
-C
-      INTEGER IMACH(16),OUTPUT
-      SAVE IMACH
-      EQUIVALENCE (IMACH(4),OUTPUT)
-      INTEGER I
-C***FIRST EXECUTABLE STATEMENT  I1MACH
-      IMACH( 1) =         5
-      IMACH( 2) =         6
-      IMACH( 3) =         6
-      IMACH( 4) =         6
-      IMACH( 5) =        bit_size(0)
-      IMACH( 6) =         IMACH( 5) / 8
-      IMACH( 7) =         radix(0)
-      IMACH( 8) =        digits(0)
-      IMACH( 9) =     huge(0)
-      IMACH(10) =         radix(0.)
-      IMACH(11) =        digits(0.)
-      IMACH(12) =      minexponent(0.)
-      IMACH(13) =       maxexponent(0.)
-      IMACH(14) =        digits(0d0)
-      IMACH(15) =      minexponent(0d0)
-      IMACH(16) =       maxexponent(0d0)
-      IF (I < 1  .OR.  I > 16) GO TO 10
-C
-      I1MACH = IMACH(I)
-      RETURN
-C
-   10 CONTINUE
-      WRITE (UNIT = OUTPUT, FMT = 9000)
- 9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
-C
-C     CALL FDUMP
-C
-      STOP
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/i1mach.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/i1mach.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/i1mach.f90	(revision 5105)
@@ -0,0 +1,128 @@
+!DECK I1MACH
+INTEGER FUNCTION I1MACH (I)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  I1MACH
+  !***PURPOSE  Return integer machine dependent constants.
+  !***LIBRARY   SLATEC
+  !***CATEGORY  R1
+  !***TYPE      INTEGER (I1MACH-I)
+  !***KEYWORDS  MACHINE CONSTANTS
+  !***AUTHOR  Fox, P. A., (Bell Labs)
+        ! Hall, A. D., (Bell Labs)
+        ! Schryer, N. L., (Bell Labs)
+  !***DESCRIPTION
+  !
+  !   I1MACH can be used to obtain machine-dependent parameters for the
+  !   local machine environment.  It is a function subprogram with one
+  !   (input) argument and can be referenced as follows:
+  !
+  !    K = I1MACH(I)
+  !
+  !   where I=1,...,16.  The (output) value of K above is determined by
+  !   the (input) value of I.  The results for various values of I are
+  !   discussed below.
+  !
+  !   I/O unit numbers:
+  ! I1MACH( 1) = the standard input unit.
+  ! I1MACH( 2) = the standard output unit.
+  ! I1MACH( 3) = the standard punch unit.
+  ! I1MACH( 4) = the standard error message unit.
+  !
+  !   Words:
+  ! I1MACH( 5) = the number of bits per integer storage unit.
+  ! I1MACH( 6) = the number of characters per integer storage unit.
+  !
+  !   Integers:
+  ! assume integers are represented in the S-digit, base-A form
+  !
+  !            sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
+  !
+  !            where 0 .LE. X(I) .LT. A for I=0,...,S-1.
+  ! I1MACH( 7) = A, the base.
+  ! I1MACH( 8) = S, the number of base-A digits.
+  ! I1MACH( 9) = A**S - 1, the largest magnitude.
+  !
+  !   Floating-Point Numbers:
+  ! Assume floating-point numbers are represented in the T-digit,
+  ! base-B form
+  !            sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
+  !
+  !            where 0 .LE. X(I) .LT. B for I=1,...,T,
+  !            0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
+  ! I1MACH(10) = B, the base.
+  !
+  !   Single-Precision:
+  ! I1MACH(11) = T, the number of base-B digits.
+  ! I1MACH(12) = EMIN, the smallest exponent E.
+  ! I1MACH(13) = EMAX, the largest exponent E.
+  !
+  !   Double-Precision:
+  ! I1MACH(14) = T, the number of base-B digits.
+  ! I1MACH(15) = EMIN, the smallest exponent E.
+  ! I1MACH(16) = EMAX, the largest exponent E.
+  !
+  !   To alter this function for a particular environment, the desired
+  !   set of DATA statements should be activated by removing the C from
+  !   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
+  !   checked for consistency with the local operating system.
+  !
+  !***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
+  !             a portable library, ACM Transactions on Mathematical
+  !             Software 4, 2 (June 1978), pp. 177-188.
+  !***ROUTINES CALLED  (NONE)
+  !***REVISION HISTORY  (YYMMDD)
+  !   750101  DATE WRITTEN
+  !   891012  Added VAX G-floating constants.  (WRB)
+  !   891012  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900618  Added DEC RISC constants.  (WRB)
+  !   900723  Added IBM RS 6000 constants.  (WRB)
+  !   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
+  !       (RWC)
+  !   910710  Added HP 730 constants.  (SMR)
+  !   911114  Added Convex IEEE constants.  (WRB)
+  !   920121  Added SUN -r8 compiler option constants.  (WRB)
+  !   920229  Added Touchstone Delta i860 constants.  (WRB)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !   920625  Added Convex -p8 and -pd8 compiler option constants.
+  !       (BKS, WRB)
+  !   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
+  !   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
+  !       options.  (DWL, RWC and WRB).
+  !   100623  Use Fortran 95 intrinsic functions (Lionel GUEZ)
+  !***END PROLOGUE  I1MACH
+  !
+  INTEGER :: IMACH(16),OUTPUT
+  SAVE IMACH
+  EQUIVALENCE (IMACH(4),OUTPUT)
+  INTEGER :: I
+  !***FIRST EXECUTABLE STATEMENT  I1MACH
+  IMACH( 1) =         5
+  IMACH( 2) =         6
+  IMACH( 3) =         6
+  IMACH( 4) =         6
+  IMACH( 5) =        bit_size(0)
+  IMACH( 6) =         IMACH( 5) / 8
+  IMACH( 7) =         radix(0)
+  IMACH( 8) =        digits(0)
+  IMACH( 9) =     huge(0)
+  IMACH(10) =         radix(0.)
+  IMACH(11) =        digits(0.)
+  IMACH(12) =      minexponent(0.)
+  IMACH(13) =       maxexponent(0.)
+  IMACH(14) =        digits(0d0)
+  IMACH(15) =      minexponent(0d0)
+  IMACH(16) =       maxexponent(0d0)
+  IF (I < 1  .OR.  I > 16) GO TO 10
+  !
+  I1MACH = IMACH(I)
+  RETURN
+  !
+   10   CONTINUE
+  WRITE (UNIT = OUTPUT, FMT = 9000)
+ 9000   FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
+  !
+  ! CALL FDUMP
+  !
+  STOP
+END FUNCTION I1MACH
Index: DZ6/branches/Amaury_dev/libf/misc/ismax.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/ismax.F	(revision 5104)
+++ 	(revision )
@@ -1,24 +1,0 @@
-
-! $Header$
-
-      function ismax(n,sx,incx)
-c
-      IMPLICIT NONE
-c
-      INTEGER n,i,incx,ismax,ix
-      real sx((n-1)*incx+1),sxmax
-c
-      ix=1
-      ismax=1
-      sxmax=sx(1)
-      do i=1,n-1
-       ix=ix+incx
-       if(sx(ix)>sxmax) then
-         sxmax=sx(ix)
-         ismax=i+1
-       endif
-      END DO
-c
-      return
-      end
-
Index: /LMDZ6/branches/Amaury_dev/libf/misc/ismax.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/ismax.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/ismax.f90	(revision 5105)
@@ -0,0 +1,24 @@
+
+! $Header$
+
+function ismax(n,sx,incx)
+  !
+  IMPLICIT NONE
+  !
+  INTEGER :: n,i,incx,ismax,ix
+  real :: sx((n-1)*incx+1),sxmax
+  !
+  ix=1
+  ismax=1
+  sxmax=sx(1)
+  do i=1,n-1
+   ix=ix+incx
+   if(sx(ix)>sxmax) then
+     sxmax=sx(ix)
+     ismax=i+1
+   endif
+  END DO
+  !
+
+end function ismax
+
Index: DZ6/branches/Amaury_dev/libf/misc/ismin.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/ismin.F	(revision 5104)
+++ 	(revision )
@@ -1,24 +1,0 @@
-
-! $Header$
-
-      FUNCTION ismin(n,sx,incx)
-c
-      IMPLICIT NONE
-c
-      integer n,i,incx,ismin,ix
-      real sx((n-1)*incx+1),sxmin
-c
-      ix=1
-      ismin=1
-      sxmin=sx(1)
-      DO i=1,n-1
-         ix=ix+incx
-         if(sx(ix)<sxmin) then
-             sxmin=sx(ix)
-             ismin=i+1
-         endif
-      ENDDO
-c
-      return
-      end
-C
Index: /LMDZ6/branches/Amaury_dev/libf/misc/ismin.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/ismin.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/ismin.f90	(revision 5105)
@@ -0,0 +1,24 @@
+
+! $Header$
+
+FUNCTION ismin(n,sx,incx)
+  !
+  IMPLICIT NONE
+  !
+  integer :: n,i,incx,ismin,ix
+  real :: sx((n-1)*incx+1),sxmin
+  !
+  ix=1
+  ismin=1
+  sxmin=sx(1)
+  DO i=1,n-1
+     ix=ix+incx
+     if(sx(ix)<sxmin) then
+         sxmin=sx(ix)
+         ismin=i+1
+     endif
+  ENDDO
+  !
+
+end function ismin
+!
Index: DZ6/branches/Amaury_dev/libf/misc/j4save.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/j4save.F	(revision 5104)
+++ 	(revision )
@@ -1,67 +1,0 @@
-*DECK J4SAVE
-      FUNCTION J4SAVE (IWHICH, IVALUE, ISET)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  J4SAVE
-C***SUBSIDIARY
-C***PURPOSE  Save or reCALL global variables needed by error
-C            handling routines.
-C***LIBRARY   SLATEC (XERROR)
-C***TYPE      INTEGER (J4SAVE-I)
-C***KEYWORDS  ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR
-C***AUTHOR  Jones, R. E., (SNLA)
-C***DESCRIPTION
-C
-C     Abstract
-C        J4SAVE saves and recalls several global variables needed
-C        by the library error handling routines.
-C
-C     Description of Parameters
-C      --Input--
-C        IWHICH - Index of item desired.
-C                = 1 Refers to current error number.
-C                = 2 Refers to current error control flag.
-C                = 3 Refers to current unit number to which error
-C                    messages are to be sent.  (0 means use standard.)
-C                = 4 Refers to the maximum number of times any
-C                     message is to be printed (as set by XERMAX).
-C                = 5 Refers to the total number of units to which
-C                     each error message is to be written.
-C                = 6 Refers to the 2nd unit for error messages
-C                = 7 Refers to the 3rd unit for error messages
-C                = 8 Refers to the 4th unit for error messages
-C                = 9 Refers to the 5th unit for error messages
-C        IVALUE - The value to be set for the IWHICH-th parameter,
-C                 if ISET is .TRUE. .
-C        ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
-C                 given the value, IVALUE.  If ISET=.FALSE., the
-C                 IWHICH-th parameter will be unchanged, and IVALUE
-C                 is a dummy parameter.
-C      --Output--
-C        The (old) value of the IWHICH-th parameter will be returned
-C        in the function value, J4SAVE.
-C
-C***SEE ALSO  XERMSG
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  (NONE)
-C***REVISION HISTORY  (YYMMDD)
-C   790801  DATE WRITTEN
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900205  Minor modifications to prologue.  (WRB)
-C   900402  Added TYPE section.  (WRB)
-C   910411  Added KEYWORDS section.  (WRB)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  J4SAVE
-      LOGICAL ISET
-      INTEGER IPARAM(9)
-      SAVE IPARAM
-      DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/
-      DATA IPARAM(5)/1/
-      DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
-      INTEGER J4SAVE,IWHICH,IVALUE
-C***FIRST EXECUTABLE STATEMENT  J4SAVE
-      J4SAVE = IPARAM(IWHICH)
-      IF (ISET) IPARAM(IWHICH) = IVALUE
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/j4save.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/j4save.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/j4save.f90	(revision 5105)
@@ -0,0 +1,67 @@
+!DECK J4SAVE
+FUNCTION J4SAVE (IWHICH, IVALUE, ISET)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  J4SAVE
+  !***SUBSIDIARY
+  !***PURPOSE  Save or reCALL global variables needed by error
+         ! handling routines.
+  !***LIBRARY   SLATEC (XERROR)
+  !***TYPE      INTEGER (J4SAVE-I)
+  !***KEYWORDS  ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR
+  !***AUTHOR  Jones, R. E., (SNLA)
+  !***DESCRIPTION
+  !
+  ! Abstract
+  !    J4SAVE saves and recalls several global variables needed
+  !    by the library error handling routines.
+  !
+  ! Description of Parameters
+  !  --Input--
+  !    IWHICH - Index of item desired.
+  !            = 1 Refers to current error number.
+  !            = 2 Refers to current error control flag.
+  !            = 3 Refers to current unit number to which error
+  !                messages are to be sent.  (0 means use standard.)
+  !            = 4 Refers to the maximum number of times any
+  !                 message is to be printed (as set by XERMAX).
+  !            = 5 Refers to the total number of units to which
+  !                 each error message is to be written.
+  !            = 6 Refers to the 2nd unit for error messages
+  !            = 7 Refers to the 3rd unit for error messages
+  !            = 8 Refers to the 4th unit for error messages
+  !            = 9 Refers to the 5th unit for error messages
+  !    IVALUE - The value to be set for the IWHICH-th parameter,
+  !             if ISET is .TRUE. .
+  !    ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
+  !             given the value, IVALUE.  If ISET=.FALSE., the
+  !             IWHICH-th parameter will be unchanged, and IVALUE
+  !             is a dummy parameter.
+  !  --Output--
+  !    The (old) value of the IWHICH-th parameter will be returned
+  !    in the function value, J4SAVE.
+  !
+  !***SEE ALSO  XERMSG
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  (NONE)
+  !***REVISION HISTORY  (YYMMDD)
+  !   790801  DATE WRITTEN
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900205  Minor modifications to prologue.  (WRB)
+  !   900402  Added TYPE section.  (WRB)
+  !   910411  Added KEYWORDS section.  (WRB)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  J4SAVE
+  LOGICAL :: ISET
+  INTEGER :: IPARAM(9)
+  SAVE IPARAM
+  DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/
+  DATA IPARAM(5)/1/
+  DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
+  INTEGER :: J4SAVE,IWHICH,IVALUE
+  !***FIRST EXECUTABLE STATEMENT  J4SAVE
+  J4SAVE = IPARAM(IWHICH)
+  IF (ISET) IPARAM(IWHICH) = IVALUE
+
+END FUNCTION J4SAVE
Index: DZ6/branches/Amaury_dev/libf/misc/juldate.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/juldate.F	(revision 5104)
+++ 	(revision )
@@ -1,39 +1,0 @@
-
-! $Id$
-
-	SUBROUTINE juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)
-c	Sous-routine de changement de date:
-c	gregorien>>>date julienne
-c	En entree:an,mois,jour,heure,min.,sec.
-c	En sortie:tjd
-        IMPLICIT NONE
-        INTEGER,INTENT(IN) :: ian,imoi,ijou,oh,om,os
-        REAL,INTENT(OUT) :: tjd,tjdsec
-        
-        REAL frac,year,rmon,cf,a,b
-        INTEGER ojou
-        
-	frac=((os/60.+om)/60.+oh)/24.
-	ojou=dble(ijou)+frac
-	    year=dble(ian)
-	    rmon=dble(imoi)
-	if (imoi <= 2) then
-	    year=year-1.
-	    rmon=rmon+12.
-	endif
-	cf=year+(rmon/100.)+(ojou/10000.)
-	if (cf >= 1582.1015) then
-	    a=int(year/100)
-	    b=2-a+int(a/4)
-	else
-	    b=0
-	endif
-	tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou)
-     +   +1720994.5+b
-        tjdsec=(ojou-int(ojou))+(tjd-int(tjd))
-        tjd=int(tjd)+int(tjdsec)
-	tjdsec=tjdsec-int(tjdsec)
-	return
-	end
-
-
Index: /LMDZ6/branches/Amaury_dev/libf/misc/juldate.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/juldate.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/juldate.f90	(revision 5105)
@@ -0,0 +1,39 @@
+
+! $Id$
+
+  SUBROUTINE juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)
+  ! Sous-routine de changement de date:
+  ! gregorien>>>date julienne
+  ! En entree:an,mois,jour,heure,min.,sec.
+  ! En sortie:tjd
+    IMPLICIT NONE
+    INTEGER,INTENT(IN) :: ian,imoi,ijou,oh,om,os
+    REAL,INTENT(OUT) :: tjd,tjdsec
+
+    REAL :: frac,year,rmon,cf,a,b
+    INTEGER :: ojou
+
+    frac=((os/60.+om)/60.+oh)/24.
+    ojou=dble(ijou)+frac
+        year=dble(ian)
+        rmon=dble(imoi)
+    if (imoi <= 2) then
+        year=year-1.
+        rmon=rmon+12.
+    endif
+    cf=year+(rmon/100.)+(ojou/10000.)
+    if (cf >= 1582.1015) then
+        a=int(year/100)
+        b=2-a+int(a/4)
+    else
+        b=0
+    endif
+    tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou) &
+          +1720994.5+b
+    tjdsec=(ojou-int(ojou))+(tjd-int(tjd))
+    tjd=int(tjd)+int(tjdsec)
+    tjdsec=tjdsec-int(tjdsec)
+
+end subroutine juldate
+
+
Index: DZ6/branches/Amaury_dev/libf/misc/minmax.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/minmax.F	(revision 5104)
+++ 	(revision )
@@ -1,23 +1,0 @@
-
-! $Header$
-
-       SUBROUTINE minmax(imax, xi, zmin, zmax )
-c
-c      P. Le Van
-
-       INTEGER imax
-       REAL    xi(imax)
-       REAL    zmin,zmax
-       INTEGER i
-
-       zmin = xi(1)
-       zmax = xi(1)
-
-       DO i = 2, imax
-         zmin = MIN( zmin,xi(i) )
-         zmax = MAX( zmax,xi(i) )
-       ENDDO
-
-       RETURN
-       END
-
Index: /LMDZ6/branches/Amaury_dev/libf/misc/minmax.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/minmax.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/minmax.f90	(revision 5105)
@@ -0,0 +1,23 @@
+
+! $Header$
+
+ SUBROUTINE minmax(imax, xi, zmin, zmax )
+  !
+  !  P. Le Van
+
+   INTEGER :: imax
+   REAL :: xi(imax)
+   REAL :: zmin,zmax
+   INTEGER :: i
+
+   zmin = xi(1)
+   zmax = xi(1)
+
+   DO i = 2, imax
+     zmin = MIN( zmin,xi(i) )
+     zmax = MAX( zmax,xi(i) )
+   ENDDO
+
+
+END SUBROUTINE minmax
+
Index: DZ6/branches/Amaury_dev/libf/misc/minmax2.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/minmax2.F	(revision 5104)
+++ 	(revision )
@@ -1,20 +1,0 @@
-
-! $Header$
-
-       SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax )
-c
-       INTEGER lmax,jmax,imax
-       REAL xi(imax*jmax*lmax) 
-       REAL zmin,zmax
-       INTEGER i
-    
-       zmin = xi(1)
-       zmax = xi(1)
-
-       DO i = 2, imax*jmax*lmax
-         zmin = MIN( zmin,xi(i) )
-         zmax = MAX( zmax,xi(i) )
-       ENDDO
-
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/minmax2.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/minmax2.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/minmax2.f90	(revision 5105)
@@ -0,0 +1,20 @@
+
+! $Header$
+
+ SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax )
+  !
+   INTEGER :: lmax,jmax,imax
+   REAL :: xi(imax*jmax*lmax)
+   REAL :: zmin,zmax
+   INTEGER :: i
+
+   zmin = xi(1)
+   zmax = xi(1)
+
+   DO i = 2, imax*jmax*lmax
+     zmin = MIN( zmin,xi(i) )
+     zmax = MAX( zmax,xi(i) )
+   ENDDO
+
+
+END SUBROUTINE minmax2
Index: DZ6/branches/Amaury_dev/libf/misc/pchdf.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/pchdf.F	(revision 5104)
+++ 	(revision )
@@ -1,106 +1,0 @@
-*DECK PCHDF
-      REAL FUNCTION PCHDF (K, X, S, IERR)
-C***BEGIN PROLOGUE  PCHDF
-C***SUBSIDIARY
-C***PURPOSE  Computes divided differences for PCHCE and PCHSP
-C***LIBRARY   SLATEC (PCHIP)
-C***TYPE      SINGLE PRECISION (PCHDF-S, DPCHDF-D)
-C***AUTHOR  Fritsch, F. N., (LLNL)
-C***DESCRIPTION
-C
-C          PCHDF:   PCHIP Finite Difference Formula
-C
-C     Uses a divided difference formulation to compute a K-point approx-
-C     imation to the derivative at X(K) based on the data in X and S.
-C
-C     Called by  PCHCE  and  PCHSP  to compute 3- and 4-point boundary
-C     derivative approximations.
-C
-C ----------------------------------------------------------------------
-C
-C     On input:
-C        K      is the order of the desired derivative approximation.
-C               K must be at least 3 (error return if not).
-C        X      contains the K values of the independent variable.
-C               X need not be ordered, but the values **MUST** be
-C               distinct.  (Not checked here.)
-C        S      contains the associated slope values:
-C                  S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1.
-C               (Note that S need only be of length K-1.)
-C
-C     On return:
-C        S      will be destroyed.
-C        IERR   will be set to -1 if K.LT.2 .
-C        PCHDF  will be set to the desired derivative approximation if
-C               IERR=0 or to zero if IERR=-1.
-C
-C ----------------------------------------------------------------------
-C
-C***SEE ALSO  PCHCE, PCHSP
-C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
-C                 Verlag, New York, 1978, pp. 10-16.
-C***ROUTINES CALLED  XERMSG
-C***REVISION HISTORY  (YYMMDD)
-C   820503  DATE WRITTEN
-C   820805  Converted to SLATEC library version.
-C   870813  Minor cosmetic changes.
-C   890411  Added SAVE statements (Vers. 3.2).
-C   890411  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
-C   900328  Added TYPE section.  (WRB)
-C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
-C   920429  Revised format and order of references.  (WRB,FNF)
-C   930503  Improved purpose.  (FNF)
-C***END PROLOGUE  PCHDF
-C
-C**End
-C
-C  DECLARE ARGUMENTS.
-C
-      INTEGER  K, IERR
-      REAL  X(K), S(K)
-C
-C  DECLARE LOCAL VARIABLES.
-C
-      INTEGER  I, J
-      REAL  VALUE, ZERO
-      SAVE ZERO
-      DATA  ZERO /0./
-C
-C  CHECK FOR LEGAL VALUE OF K.
-C
-C***FIRST EXECUTABLE STATEMENT  PCHDF
-      IF (K < 3)  GO TO 5001
-C
-C  COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL.
-C
-      DO J = 2, K-1
-         DO I = 1, K-J
-            S(I) = (S(I+1)-S(I))/(X(I+J)-X(I))
-      END DO
-      END DO
-C
-C  EVALUATE DERIVATIVE AT X(K).
-C
-      VALUE = S(1)
-      DO I = 2, K-1
-         VALUE = S(I) + VALUE*(X(K)-X(I))
-      END DO
-C
-C  NORMAL RETURN.
-C
-      IERR = 0
-      PCHDF = VALUE
-      RETURN
-C
-C  ERROR RETURN.
-C
- 5001 CONTINUE
-C     K.LT.3 RETURN.
-      IERR = -1
-      CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1)
-      PCHDF = ZERO
-      RETURN
-C------------- LAST LINE OF PCHDF FOLLOWS ------------------------------
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/pchdf.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/pchdf.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/pchdf.f90	(revision 5105)
@@ -0,0 +1,106 @@
+!DECK PCHDF
+REAL FUNCTION PCHDF (K, X, S, IERR)
+  !***BEGIN PROLOGUE  PCHDF
+  !***SUBSIDIARY
+  !***PURPOSE  Computes divided differences for PCHCE and PCHSP
+  !***LIBRARY   SLATEC (PCHIP)
+  !***TYPE      SINGLE PRECISION (PCHDF-S, DPCHDF-D)
+  !***AUTHOR  Fritsch, F. N., (LLNL)
+  !***DESCRIPTION
+  !
+  !      PCHDF:   PCHIP Finite Difference Formula
+  !
+  ! Uses a divided difference formulation to compute a K-point approx-
+  ! imation to the derivative at X(K) based on the data in X and S.
+  !
+  ! Called by  PCHCE  and  PCHSP  to compute 3- and 4-point boundary
+  ! derivative approximations.
+  !
+  ! ----------------------------------------------------------------------
+  !
+  ! On input:
+  !    K      is the order of the desired derivative approximation.
+  !           K must be at least 3 (error return if not).
+  !    X      contains the K values of the independent variable.
+  !           X need not be ordered, but the values **MUST** be
+  !           distinct.  (Not checked here.)
+  !    S      contains the associated slope values:
+  !              S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1.
+  !           (Note that S need only be of length K-1.)
+  !
+  ! On return:
+  !    S      will be destroyed.
+  !    IERR   will be set to -1 if K.LT.2 .
+  !    PCHDF  will be set to the desired derivative approximation if
+  !           IERR=0 or to zero if IERR=-1.
+  !
+  ! ----------------------------------------------------------------------
+  !
+  !***SEE ALSO  PCHCE, PCHSP
+  !***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
+  !             Verlag, New York, 1978, pp. 10-16.
+  !***ROUTINES CALLED  XERMSG
+  !***REVISION HISTORY  (YYMMDD)
+  !   820503  DATE WRITTEN
+  !   820805  Converted to SLATEC library version.
+  !   870813  Minor cosmetic changes.
+  !   890411  Added SAVE statements (Vers. 3.2).
+  !   890411  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+  !   900328  Added TYPE section.  (WRB)
+  !   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
+  !   920429  Revised format and order of references.  (WRB,FNF)
+  !   930503  Improved purpose.  (FNF)
+  !***END PROLOGUE  PCHDF
+  !
+  !**End
+  !
+  !  DECLARE ARGUMENTS.
+  !
+  INTEGER :: K, IERR
+  REAL :: X(K), S(K)
+  !
+  !  DECLARE LOCAL VARIABLES.
+  !
+  INTEGER :: I, J
+  REAL :: VALUE, ZERO
+  SAVE ZERO
+  DATA  ZERO /0./
+  !
+  !  CHECK FOR LEGAL VALUE OF K.
+  !
+  !***FIRST EXECUTABLE STATEMENT  PCHDF
+  IF (K < 3)  GO TO 5001
+  !
+  !  COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL.
+  !
+  DO J = 2, K-1
+     DO I = 1, K-J
+        S(I) = (S(I+1)-S(I))/(X(I+J)-X(I))
+  END DO
+  END DO
+  !
+  !  EVALUATE DERIVATIVE AT X(K).
+  !
+  VALUE = S(1)
+  DO I = 2, K-1
+     VALUE = S(I) + VALUE*(X(K)-X(I))
+  END DO
+  !
+  !  NORMAL RETURN.
+  !
+  IERR = 0
+  PCHDF = VALUE
+  RETURN
+  !
+  !  ERROR RETURN.
+  !
+ 5001   CONTINUE
+  ! K.LT.3 RETURN.
+  IERR = -1
+  CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1)
+  PCHDF = ZERO
+  RETURN
+  !------------- LAST LINE OF PCHDF FOLLOWS ------------------------------
+END FUNCTION PCHDF
Index: DZ6/branches/Amaury_dev/libf/misc/pchfe.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/pchfe.F	(revision 5104)
+++ 	(revision )
@@ -1,308 +1,0 @@
-*DECK PCHFE
-      SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
-C***BEGIN PROLOGUE  PCHFE
-C***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
-C            points.  May be used by itself for Hermite interpolation,
-C            or as an evaluator for PCHIM or PCHIC.
-C***LIBRARY   SLATEC (PCHIP)
-C***CATEGORY  E3
-C***TYPE      SINGLE PRECISION (PCHFE-S, DPCHFE-D)
-C***KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
-C             PIECEWISE CUBIC EVALUATION
-C***AUTHOR  Fritsch, F. N., (LLNL)
-C             Lawrence Livermore National Laboratory
-C             P.O. Box 808  (L-316)
-C             Livermore, CA  94550
-C             FTS 532-4275, (510) 422-4275
-C***DESCRIPTION
-C
-C          PCHFE:  Piecewise Cubic Hermite Function Evaluator
-C
-C     Evaluates the cubic Hermite function defined by  N, X, F, D  at
-C     the points  XE(J), J=1(1)NE.
-C
-C     To provide compatibility with PCHIM and PCHIC, includes an
-C     increment between successive values of the F- and D-arrays.
-C
-C ----------------------------------------------------------------------
-C
-C  Calling sequence:
-C
-C        PARAMETER  (INCFD = ...)
-C        INTEGER  N, NE, IERR
-C        REAL  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE)
-C        LOGICAL  SKIP
-C
-C        CALL  PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
-C
-C   Parameters:
-C
-C     N -- (input) number of data points.  (Error return if N.LT.2 .)
-C
-C     X -- (input) real array of independent variable values.  The
-C           elements of X must be strictly increasing:
-C                X(I-1) .LT. X(I),  I = 2(1)N.
-C           (Error return if not.)
-C
-C     F -- (input) real array of function values.  F(1+(I-1)*INCFD) is
-C           the value corresponding to X(I).
-C
-C     D -- (input) real array of derivative values.  D(1+(I-1)*INCFD) is
-C           the value corresponding to X(I).
-C
-C     INCFD -- (input) increment between successive values in F and D.
-C           (Error return if  INCFD.LT.1 .)
-C
-C     SKIP -- (input/output) logical variable which should be set to
-C           .TRUE. if the user wishes to skip checks for validity of
-C           preceding parameters, or to .FALSE. otherwise.
-C           This will save time in case these checks have already
-C           been performed (say, in PCHIM or PCHIC).
-C           SKIP will be set to .TRUE. on normal return.
-C
-C     NE -- (input) number of evaluation points.  (Error return if
-C           NE.LT.1 .)
-C
-C     XE -- (input) real array of points at which the function is to be
-C           evaluated.
-C
-C          NOTES:
-C           1. The evaluation will be most efficient if the elements
-C              of XE are increasing relative to X;
-C              that is,   XE(J) .GE. X(I)
-C              implies    XE(K) .GE. X(I),  all K.GE.J .
-C           2. If any of the XE are outside the interval [X(1),X(N)],
-C              values are extrapolated from the nearest extreme cubic,
-C              and a warning error is returned.
-C
-C     FE -- (output) real array of values of the cubic Hermite function
-C           defined by  N, X, F, D  at the points  XE.
-C
-C     IERR -- (output) error flag.
-C           Normal return:
-C              IERR = 0  (no errors).
-C           Warning error:
-C              IERR.GT.0  means that extrapolation was performed at
-C                 IERR points.
-C           "Recoverable" errors:
-C              IERR = -1  if N.LT.2 .
-C              IERR = -2  if INCFD.LT.1 .
-C              IERR = -3  if the X-array is not strictly increasing.
-C              IERR = -4  if NE.LT.1 .
-C             (The FE-array has not been changed in any of these cases.)
-C               NOTE:  The above errors are checked in the order listed,
-C                   and following arguments have **NOT** been validated.
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  CHFEV, XERMSG
-C***REVISION HISTORY  (YYMMDD)
-C   811020  DATE WRITTEN
-C   820803  Minor cosmetic changes for release 1.
-C   870707  Minor cosmetic changes to prologue.
-C   890531  Changed all specific intrinsics to generic.  (WRB)
-C   890831  Modified array declarations.  (WRB)
-C   890831  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
-C***END PROLOGUE  PCHFE
-C  Programming notes:
-C
-C     1. To produce a double precision version, simply:
-C        a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they
-C           occur,
-C        b. Change the real declaration to double precision,
-C
-C     2. Most of the coding between the CALL to CHFEV and the end of
-C        the IR-loop could be eliminated if it were permissible to
-C        assume that XE is ordered relative to X.
-C
-C     3. CHFEV does not assume that X1 is less than X2.  thus, it would
-C        be possible to write a version of PCHFE that assumes a strict-
-C        ly decreasing X-array by simply running the IR-loop backwards
-C        (and reversing the order of appropriate tests).
-C
-C     4. The present code has a minor bug, which I have decided is not
-C        worth the effort that would be required to fix it.
-C        If XE contains points in [X(N-1),X(N)], followed by points .LT.
-C        X(N-1), followed by points .GT.X(N), the extrapolation points
-C        will be counted (at least) twice in the total returned in IERR.
-C
-C  DECLARE ARGUMENTS.
-C
-      INTEGER  N, INCFD, NE, IERR
-      REAL  X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*)
-      LOGICAL  SKIP
-C
-C  DECLARE LOCAL VARIABLES.
-C
-      INTEGER  I, IERC, IR, J, JFIRST, NEXT(2), NJ
-C
-C  VALIDITY-CHECK ARGUMENTS.
-C
-C***FIRST EXECUTABLE STATEMENT  PCHFE
-      IF (SKIP)  GO TO 5
-C
-      IF ( N<2 )  GO TO 5001
-      IF ( INCFD<1 )  GO TO 5002
-      DO I = 2, N
-         IF ( X(I)<=X(I-1) )  GO TO 5003
-      END DO
-C
-C  FUNCTION DEFINITION IS OK, GO ON.
-C
-    5 CONTINUE
-      IF ( NE<1 )  GO TO 5004
-      IERR = 0
-      SKIP = .TRUE.
-C
-C  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
-C                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
-      JFIRST = 1
-      IR = 2
-   10 CONTINUE
-C
-C     SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
-C
-         IF (JFIRST > NE)  GO TO 5000
-C
-C     LOCATE ALL POINTS IN INTERVAL.
-C
-         DO J = JFIRST, NE
-            IF (XE(J) >= X(IR))  GO TO 30
-      END DO
-         J = NE + 1
-         GO TO 40
-C
-C     HAVE LOCATED FIRST POINT BEYOND INTERVAL.
-C
-   30    CONTINUE
-         IF (IR == N)  J = NE + 1
-C
-   40    CONTINUE
-         NJ = J - JFIRST
-C
-C     SKIP EVALUATION IF NO POINTS IN INTERVAL.
-C
-         IF (NJ == 0)  GO TO 50
-C
-C     EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
-C
-C       ----------------------------------------------------------------
-        CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR),
-     *              NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC)
-C       ----------------------------------------------------------------
-         IF (IERC < 0)  GO TO 5005
-C
-         IF (NEXT(2) == 0)  GO TO 42
-C        IF (NEXT(2) .GT. 0)  THEN
-C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
-C           RIGHT OF X(IR).
-C
-            IF (IR < N)  GO TO 41
-C           IF (IR .EQ. N)  THEN
-C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
-               IERR = IERR + NEXT(2)
-               GO TO 42
-   41       CONTINUE
-C           ELSE
-C              WE SHOULD NEVER HAVE GOTTEN HERE.
-               GO TO 5005
-C           ENDIF
-C        ENDIF
-   42    CONTINUE
-C
-         IF (NEXT(1) == 0)  GO TO 49
-C        IF (NEXT(1) .GT. 0)  THEN
-C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
-C           LEFT OF X(IR-1).
-C
-            IF (IR > 2)  GO TO 43
-C           IF (IR .EQ. 2)  THEN
-C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
-               IERR = IERR + NEXT(1)
-               GO TO 49
-   43       CONTINUE
-C           ELSE
-C              XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
-C              EVALUATION INTERVAL.
-C
-C              FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
-               DO I = JFIRST, J-1
-                  IF (XE(I) < X(IR-1))  GO TO 45
-      END DO
-C              NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
-C                     IN CHFEV.
-               GO TO 5005
-C
-   45          CONTINUE
-C              RESET J.  (THIS WILL BE THE NEW JFIRST.)
-               J = I
-C
-C              NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
-               DO I = 1, IR-1
-                  IF (XE(J) < X(I)) GO TO 47
-      END DO
-C              NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
-C
-   47          CONTINUE
-C              AT THIS POINT, EITHER  XE(J) .LT. X(1)
-C                 OR      X(I-1) .LE. XE(J) .LT. X(I) .
-C              RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
-C              CYCLING.
-               IR = MAX(1, I-1)
-C           ENDIF
-C        ENDIF
-   49    CONTINUE
-C
-         JFIRST = J
-C
-C     END OF IR-LOOP.
-C
-   50 CONTINUE
-      IR = IR + 1
-      IF (IR <= N)  GO TO 10
-C
-C  NORMAL RETURN.
-C
- 5000 CONTINUE
-      RETURN
-C
-C  ERROR RETURNS.
-C
- 5001 CONTINUE
-C     N.LT.2 RETURN.
-      IERR = -1
-      CALL XERMSG ('SLATEC', 'PCHFE',
-     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
-      RETURN
-C
- 5002 CONTINUE
-C     INCFD.LT.1 RETURN.
-      IERR = -2
-      CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR,
-     +   1)
-      RETURN
-C
- 5003 CONTINUE
-C     X-ARRAY NOT STRICTLY INCREASING.
-      IERR = -3
-      CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING'
-     +   , IERR, 1)
-      RETURN
-C
- 5004 CONTINUE
-C     NE.LT.1 RETURN.
-      IERR = -4
-      CALL XERMSG ('SLATEC', 'PCHFE',
-     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
-      RETURN
-C
- 5005 CONTINUE
-C     ERROR RETURN FROM CHFEV.
-C   *** THIS CASE SHOULD NEVER OCCUR ***
-      IERR = -5
-      CALL XERMSG ('SLATEC', 'PCHFE',
-     +   'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2)
-      RETURN
-C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/pchfe.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/pchfe.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/pchfe.f90	(revision 5105)
@@ -0,0 +1,308 @@
+!DECK PCHFE
+SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
+  !***BEGIN PROLOGUE  PCHFE
+  !***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
+         ! points.  May be used by itself for Hermite interpolation,
+         ! or as an evaluator for PCHIM or PCHIC.
+  !***LIBRARY   SLATEC (PCHIP)
+  !***CATEGORY  E3
+  !***TYPE      SINGLE PRECISION (PCHFE-S, DPCHFE-D)
+  !***KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
+         !  PIECEWISE CUBIC EVALUATION
+  !***AUTHOR  Fritsch, F. N., (LLNL)
+         !  Lawrence Livermore National Laboratory
+         !  P.O. Box 808  (L-316)
+         !  Livermore, CA  94550
+         !  FTS 532-4275, (510) 422-4275
+  !***DESCRIPTION
+  !
+  !      PCHFE:  Piecewise Cubic Hermite Function Evaluator
+  !
+  ! Evaluates the cubic Hermite function defined by  N, X, F, D  at
+  ! the points  XE(J), J=1(1)NE.
+  !
+  ! To provide compatibility with PCHIM and PCHIC, includes an
+  ! increment between successive values of the F- and D-arrays.
+  !
+  ! ----------------------------------------------------------------------
+  !
+  !  Calling sequence:
+  !
+  !    PARAMETER  (INCFD = ...)
+  !    INTEGER  N, NE, IERR
+  !    REAL  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE)
+  !    LOGICAL  SKIP
+  !
+  !    CALL  PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
+  !
+  !   Parameters:
+  !
+  ! N -- (input) number of data points.  (Error return if N.LT.2 .)
+  !
+  ! X -- (input) real array of independent variable values.  The
+  !       elements of X must be strictly increasing:
+  !            X(I-1) .LT. X(I),  I = 2(1)N.
+  !       (Error return if not.)
+  !
+  ! F -- (input) real array of function values.  F(1+(I-1)*INCFD) is
+  !       the value corresponding to X(I).
+  !
+  ! D -- (input) real array of derivative values.  D(1+(I-1)*INCFD) is
+  !       the value corresponding to X(I).
+  !
+  ! INCFD -- (input) increment between successive values in F and D.
+  !       (Error return if  INCFD.LT.1 .)
+  !
+  ! SKIP -- (input/output) logical variable which should be set to
+  !       .TRUE. if the user wishes to skip checks for validity of
+  !       preceding parameters, or to .FALSE. otherwise.
+  !       This will save time in case these checks have already
+  !       been performed (say, in PCHIM or PCHIC).
+  !       SKIP will be set to .TRUE. on normal return.
+  !
+  ! NE -- (input) number of evaluation points.  (Error return if
+  !       NE.LT.1 .)
+  !
+  ! XE -- (input) real array of points at which the function is to be
+  !       evaluated.
+  !
+  !      NOTES:
+  !       1. The evaluation will be most efficient if the elements
+  !          of XE are increasing relative to X;
+  !          that is,   XE(J) .GE. X(I)
+  !          implies    XE(K) .GE. X(I),  all K.GE.J .
+  !       2. If any of the XE are outside the interval [X(1),X(N)],
+  !          values are extrapolated from the nearest extreme cubic,
+  !          and a warning error is returned.
+  !
+  ! FE -- (output) real array of values of the cubic Hermite function
+  !       defined by  N, X, F, D  at the points  XE.
+  !
+  ! IERR -- (output) error flag.
+  !       Normal return:
+  !          IERR = 0  (no errors).
+  !       Warning error:
+  !          IERR.GT.0  means that extrapolation was performed at
+  !             IERR points.
+  !       "Recoverable" errors:
+  !          IERR = -1  if N.LT.2 .
+  !          IERR = -2  if INCFD.LT.1 .
+  !          IERR = -3  if the X-array is not strictly increasing.
+  !          IERR = -4  if NE.LT.1 .
+  !         (The FE-array has not been changed in any of these cases.)
+  !           NOTE:  The above errors are checked in the order listed,
+  !               and following arguments have **NOT** been validated.
+  !
+  !***REFERENCES  (NONE)
+  !***ROUTINES CALLED  CHFEV, XERMSG
+  !***REVISION HISTORY  (YYMMDD)
+  !   811020  DATE WRITTEN
+  !   820803  Minor cosmetic changes for release 1.
+  !   870707  Minor cosmetic changes to prologue.
+  !   890531  Changed all specific intrinsics to generic.  (WRB)
+  !   890831  Modified array declarations.  (WRB)
+  !   890831  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+  !***END PROLOGUE  PCHFE
+  !  Programming notes:
+  !
+  ! 1. To produce a double precision version, simply:
+  !    a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they
+  !       occur,
+  !    b. Change the real declaration to double precision,
+  !
+  ! 2. Most of the coding between the CALL to CHFEV and the end of
+  !    the IR-loop could be eliminated if it were permissible to
+  !    assume that XE is ordered relative to X.
+  !
+  ! 3. CHFEV does not assume that X1 is less than X2.  thus, it would
+  !    be possible to write a version of PCHFE that assumes a strict-
+  !    ly decreasing X-array by simply running the IR-loop backwards
+  !    (and reversing the order of appropriate tests).
+  !
+  ! 4. The present code has a minor bug, which I have decided is not
+  !    worth the effort that would be required to fix it.
+  !    If XE contains points in [X(N-1),X(N)], followed by points .LT.
+  !    X(N-1), followed by points .GT.X(N), the extrapolation points
+  !    will be counted (at least) twice in the total returned in IERR.
+  !
+  !  DECLARE ARGUMENTS.
+  !
+  INTEGER :: N, INCFD, NE, IERR
+  REAL :: X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*)
+  LOGICAL :: SKIP
+  !
+  !  DECLARE LOCAL VARIABLES.
+  !
+  INTEGER :: I, IERC, IR, J, JFIRST, NEXT(2), NJ
+  !
+  !  VALIDITY-CHECK ARGUMENTS.
+  !
+  !***FIRST EXECUTABLE STATEMENT  PCHFE
+  IF (SKIP)  GO TO 5
+  !
+  IF ( N<2 )  GO TO 5001
+  IF ( INCFD<1 )  GO TO 5002
+  DO I = 2, N
+     IF ( X(I)<=X(I-1) )  GO TO 5003
+  END DO
+  !
+  !  FUNCTION DEFINITION IS OK, GO ON.
+  !
+    5   CONTINUE
+  IF ( NE<1 )  GO TO 5004
+  IERR = 0
+  SKIP = .TRUE.
+  !
+  !  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
+  !                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
+  JFIRST = 1
+  IR = 2
+   10   CONTINUE
+  !
+  ! SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
+  !
+     IF (JFIRST > NE)  GO TO 5000
+  !
+  ! LOCATE ALL POINTS IN INTERVAL.
+  !
+     DO J = JFIRST, NE
+        IF (XE(J) >= X(IR))  GO TO 30
+  END DO
+     J = NE + 1
+     GO TO 40
+  !
+  ! HAVE LOCATED FIRST POINT BEYOND INTERVAL.
+  !
+   30   CONTINUE
+     IF (IR == N)  J = NE + 1
+  !
+   40   CONTINUE
+     NJ = J - JFIRST
+  !
+  ! SKIP EVALUATION IF NO POINTS IN INTERVAL.
+  !
+     IF (NJ == 0)  GO TO 50
+  !
+  ! EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
+  !
+  !   ----------------------------------------------------------------
+    CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), &
+          NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC)
+    ! ----------------------------------------------------------------
+     IF (IERC < 0)  GO TO 5005
+  !
+     IF (NEXT(2) == 0)  GO TO 42
+     ! IF (NEXT(2) .GT. 0)  THEN
+     !    IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
+     !    RIGHT OF X(IR).
+  !
+        IF (IR < N)  GO TO 41
+        ! IF (IR .EQ. N)  THEN
+        !    THESE ARE ACTUALLY EXTRAPOLATION POINTS.
+           IERR = IERR + NEXT(2)
+           GO TO 42
+   41    CONTINUE
+        ! ELSE
+        !    WE SHOULD NEVER HAVE GOTTEN HERE.
+           GO TO 5005
+        ! ENDIF
+     ! ENDIF
+   42   CONTINUE
+  !
+     IF (NEXT(1) == 0)  GO TO 49
+     ! IF (NEXT(1) .GT. 0)  THEN
+     !    IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
+     !    LEFT OF X(IR-1).
+  !
+        IF (IR > 2)  GO TO 43
+        ! IF (IR .EQ. 2)  THEN
+        !    THESE ARE ACTUALLY EXTRAPOLATION POINTS.
+           IERR = IERR + NEXT(1)
+           GO TO 49
+   43    CONTINUE
+        ! ELSE
+        !    XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
+        !    EVALUATION INTERVAL.
+  !
+  !          FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
+           DO I = JFIRST, J-1
+              IF (XE(I) < X(IR-1))  GO TO 45
+  END DO
+           ! NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
+           !        IN CHFEV.
+           GO TO 5005
+  !
+   45       CONTINUE
+           ! RESET J.  (THIS WILL BE THE NEW JFIRST.)
+           J = I
+  !
+  !          NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
+           DO I = 1, IR-1
+              IF (XE(J) < X(I)) GO TO 47
+  END DO
+           ! NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
+  !
+   47       CONTINUE
+           ! AT THIS POINT, EITHER  XE(J) .LT. X(1)
+           !    OR      X(I-1) .LE. XE(J) .LT. X(I) .
+           ! RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
+           ! CYCLING.
+           IR = MAX(1, I-1)
+        ! ENDIF
+     ! ENDIF
+   49   CONTINUE
+  !
+     JFIRST = J
+  !
+  ! END OF IR-LOOP.
+  !
+   50   CONTINUE
+  IR = IR + 1
+  IF (IR <= N)  GO TO 10
+  !
+  !  NORMAL RETURN.
+  !
+ 5000   CONTINUE
+  RETURN
+  !
+  !  ERROR RETURNS.
+  !
+ 5001   CONTINUE
+  ! N.LT.2 RETURN.
+  IERR = -1
+  CALL XERMSG ('SLATEC', 'PCHFE', &
+        'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
+  RETURN
+  !
+ 5002   CONTINUE
+  ! INCFD.LT.1 RETURN.
+  IERR = -2
+  CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR, &
+        1)
+  RETURN
+  !
+ 5003   CONTINUE
+  ! X-ARRAY NOT STRICTLY INCREASING.
+  IERR = -3
+  CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING' &
+        , IERR, 1)
+  RETURN
+  !
+ 5004   CONTINUE
+  ! NE.LT.1 RETURN.
+  IERR = -4
+  CALL XERMSG ('SLATEC', 'PCHFE', &
+        'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
+  RETURN
+  !
+ 5005   CONTINUE
+  ! ERROR RETURN FROM CHFEV.
+  !   *** THIS CASE SHOULD NEVER OCCUR ***
+  IERR = -5
+  CALL XERMSG ('SLATEC', 'PCHFE', &
+        'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2)
+  RETURN
+  !------------- LAST LINE OF PCHFE FOLLOWS ------------------------------
+END SUBROUTINE PCHFE
Index: DZ6/branches/Amaury_dev/libf/misc/pchsp.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/pchsp.F	(revision 5104)
+++ 	(revision )
@@ -1,388 +1,0 @@
-*DECK PCHSP
-      SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
-C***BEGIN PROLOGUE  PCHSP
-C***PURPOSE  Set derivatives needed to determine the Hermite represen-
-C            tation of the cubic spline interpolant to given data, with
-C            specified boundary conditions.
-C***LIBRARY   SLATEC (PCHIP)
-C***CATEGORY  E1A
-C***TYPE      SINGLE PRECISION (PCHSP-S, DPCHSP-D)
-C***KEYWORDS  CUBIC HERMITE INTERPOLATION, PCHIP,
-C             PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION
-C***AUTHOR  Fritsch, F. N., (LLNL)
-C             Lawrence Livermore National Laboratory
-C             P.O. Box 808  (L-316)
-C             Livermore, CA  94550
-C             FTS 532-4275, (510) 422-4275
-C***DESCRIPTION
-C
-C          PCHSP:   Piecewise Cubic Hermite Spline
-C
-C     Computes the Hermite representation of the cubic spline inter-
-C     polant to the data given in X and F satisfying the boundary
-C     conditions specified by IC and VC.
-C
-C     To facilitate two-dimensional applications, includes an increment
-C     between successive values of the F- and D-arrays.
-C
-C     The resulting piecewise cubic Hermite function may be evaluated
-C     by PCHFE or PCHFD.
-C
-C     NOTE:  This is a modified version of C. de Boor's cubic spline
-C            routine CUBSPL.
-C
-C ----------------------------------------------------------------------
-C
-C  Calling sequence:
-C
-C        PARAMETER  (INCFD = ...)
-C        INTEGER  IC(2), N, NWK, IERR
-C        REAL  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
-C
-C        CALL  PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
-C
-C   Parameters:
-C
-C     IC -- (input) integer array of length 2 specifying desired
-C           boundary conditions:
-C           IC(1) = IBEG, desired condition at beginning of data.
-C           IC(2) = IEND, desired condition at end of data.
-C
-C           IBEG = 0  to set D(1) so that the third derivative is con-
-C              tinuous at X(2).  This is the "not a knot" condition
-C              provided by de Boor's cubic spline routine CUBSPL.
-C              < This is the default boundary condition. >
-C           IBEG = 1  if first derivative at X(1) is given in VC(1).
-C           IBEG = 2  if second derivative at X(1) is given in VC(1).
-C           IBEG = 3  to use the 3-point difference formula for D(1).
-C                     (Reverts to the default b.c. if N.LT.3 .)
-C           IBEG = 4  to use the 4-point difference formula for D(1).
-C                     (Reverts to the default b.c. if N.LT.4 .)
-C          NOTES:
-C           1. An error return is taken if IBEG is out of range.
-C           2. For the "natural" boundary condition, use IBEG=2 and
-C              VC(1)=0.
-C
-C           IEND may take on the same values as IBEG, but applied to
-C           derivative at X(N).  In case IEND = 1 or 2, the value is
-C           given in VC(2).
-C
-C          NOTES:
-C           1. An error return is taken if IEND is out of range.
-C           2. For the "natural" boundary condition, use IEND=2 and
-C              VC(2)=0.
-C
-C     VC -- (input) real array of length 2 specifying desired boundary
-C           values, as indicated above.
-C           VC(1) need be set only if IC(1) = 1 or 2 .
-C           VC(2) need be set only if IC(2) = 1 or 2 .
-C
-C     N -- (input) number of data points.  (Error return if N.LT.2 .)
-C
-C     X -- (input) real array of independent variable values.  The
-C           elements of X must be strictly increasing:
-C                X(I-1) .LT. X(I),  I = 2(1)N.
-C           (Error return if not.)
-C
-C     F -- (input) real array of dependent variable values to be inter-
-C           polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
-C
-C     D -- (output) real array of derivative values at the data points.
-C           These values will determine the cubic spline interpolant
-C           with the requested boundary conditions.
-C           The value corresponding to X(I) is stored in
-C                D(1+(I-1)*INCFD),  I=1(1)N.
-C           No other entries in D are changed.
-C
-C     INCFD -- (input) increment between successive values in F and D.
-C           This argument is provided primarily for 2-D applications.
-C           (Error return if  INCFD.LT.1 .)
-C
-C     WK -- (scratch) real array of working storage.
-C
-C     NWK -- (input) length of work array.
-C           (Error return if NWK.LT.2*N .)
-C
-C     IERR -- (output) error flag.
-C           Normal return:
-C              IERR = 0  (no errors).
-C           "Recoverable" errors:
-C              IERR = -1  if N.LT.2 .
-C              IERR = -2  if INCFD.LT.1 .
-C              IERR = -3  if the X-array is not strictly increasing.
-C              IERR = -4  if IBEG.LT.0 or IBEG.GT.4 .
-C              IERR = -5  if IEND.LT.0 of IEND.GT.4 .
-C              IERR = -6  if both of the above are true.
-C              IERR = -7  if NWK is too small.
-C               NOTE:  The above errors are checked in the order listed,
-C                   and following arguments have **NOT** been validated.
-C             (The D-array has not been changed in any of these cases.)
-C              IERR = -8  in case of trouble solving the linear system
-C                         for the interior derivative values.
-C             (The D-array may have been changed in this case.)
-C             (             Do **NOT** use it!                )
-C
-C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
-C                 Verlag, New York, 1978, pp. 53-59.
-C***ROUTINES CALLED  PCHDF, XERMSG
-C***REVISION HISTORY  (YYMMDD)
-C   820503  DATE WRITTEN
-C   820804  Converted to SLATEC library version.
-C   870707  Minor cosmetic changes to prologue.
-C   890411  Added SAVE statements (Vers. 3.2).
-C   890703  Corrected category record.  (WRB)
-C   890831  Modified array declarations.  (WRB)
-C   890831  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
-C   920429  Revised format and order of references.  (WRB,FNF)
-C***END PROLOGUE  PCHSP
-C  Programming notes:
-C
-C     To produce a double precision version, simply:
-C        a. Change PCHSP to DPCHSP wherever it occurs,
-C        b. Change the real declarations to double precision, and
-C        c. Change the constants ZERO, HALF, ... to double precision.
-C
-C  DECLARE ARGUMENTS.
-C
-      INTEGER  IC(2), N, INCFD, NWK, IERR
-      REAL  VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*)
-C
-C  DECLARE LOCAL VARIABLES.
-C
-      INTEGER  IBEG, IEND, INDEX, J, NM1
-      REAL  G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO
-      SAVE ZERO, HALF, ONE, TWO, THREE
-      REAL  PCHDF
-C
-      DATA  ZERO /0./,  HALF /0.5/,  ONE /1./,  TWO /2./,  THREE /3./
-C
-C  VALIDITY-CHECK ARGUMENTS.
-C
-C***FIRST EXECUTABLE STATEMENT  PCHSP
-      IF ( N<2 )  GO TO 5001
-      IF ( INCFD<1 )  GO TO 5002
-      DO J = 2, N
-         IF ( X(J)<=X(J-1) )  GO TO 5003
-      END DO
-C
-      IBEG = IC(1)
-      IEND = IC(2)
-      IERR = 0
-      IF ( (IBEG<0).OR.(IBEG>4) )  IERR = IERR - 1
-      IF ( (IEND<0).OR.(IEND>4) )  IERR = IERR - 2
-      IF ( IERR<0 )  GO TO 5004
-C
-C  FUNCTION DEFINITION IS OK -- GO ON.
-C
-      IF ( NWK < 2*N )  GO TO 5007
-C
-C  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
-C  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
-      DO J=2,N
-         WK(1,J) = X(J) - X(J-1)
-         WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J)
-      END DO
-C
-C  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
-C
-      IF ( IBEG>N )  IBEG = 0
-      IF ( IEND>N )  IEND = 0
-C
-C  SET UP FOR BOUNDARY CONDITIONS.
-C
-      IF ( (IBEG==1).OR.(IBEG==2) )  THEN
-         D(1,1) = VC(1)
-      ELSE IF (IBEG > 2)  THEN
-C        PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
-         DO J = 1, IBEG
-            INDEX = IBEG-J+1
-C           INDEX RUNS FROM IBEG DOWN TO 1.
-            XTEMP(J) = X(INDEX)
-            IF (J < IBEG)  STEMP(J) = WK(2,INDEX)
-      END DO
-C                 --------------------------------
-         D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR)
-C                 --------------------------------
-         IF (IERR /= 0)  GO TO 5009
-         IBEG = 1
-      ENDIF
-C
-      IF ( (IEND==1).OR.(IEND==2) )  THEN
-         D(1,N) = VC(2)
-      ELSE IF (IEND > 2)  THEN
-C        PICK UP LAST IEND POINTS.
-         DO J = 1, IEND
-            INDEX = N-IEND+J
-C           INDEX RUNS FROM N+1-IEND UP TO N.
-            XTEMP(J) = X(INDEX)
-            IF (J < IEND)  STEMP(J) = WK(2,INDEX+1)
-      END DO
-C                 --------------------------------
-         D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR)
-C                 --------------------------------
-         IF (IERR /= 0)  GO TO 5009
-         IEND = 1
-      ENDIF
-C
-C --------------------( BEGIN CODING FROM CUBSPL )--------------------
-C
-C  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
-C  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
-C  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
-C     WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
-C
-C  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
-C             WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
-C
-      IF (IBEG == 0)  THEN
-         IF (N == 2)  THEN
-C           NO CONDITION AT LEFT END AND N = 2.
-            WK(2,1) = ONE
-            WK(1,1) = ONE
-            D(1,1) = TWO*WK(2,2)
-         ELSE
-C           NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
-            WK(2,1) = WK(1,3)
-            WK(1,1) = WK(1,2) + WK(1,3)
-            D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3)
-     *                        + WK(1,2)**2*WK(2,3)) / WK(1,1)
-         ENDIF
-      ELSE IF (IBEG == 1)  THEN
-C        SLOPE PRESCRIBED AT LEFT END.
-         WK(2,1) = ONE
-         WK(1,1) = ZERO
-      ELSE
-C        SECOND DERIVATIVE PRESCRIBED AT LEFT END.
-         WK(2,1) = TWO
-         WK(1,1) = ONE
-         D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
-      ENDIF
-C
-C  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
-C  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
-C  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
-C
-      NM1 = N-1
-      IF (NM1 > 1)  THEN
-         DO J=2,NM1
-            IF (WK(2,J-1) == ZERO)  GO TO 5008
-            G = -WK(1,J+1)/WK(2,J-1)
-            D(1,J) = G*D(1,J-1)
-     *                  + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J))
-            WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1))
-      END DO
-      ENDIF
-C
-C  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
-C           (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
-C
-C     IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
-C     SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
-C     AT THIS POINT.
-      IF (IEND == 1)  GO TO 30
-C
-      IF (IEND == 0)  THEN
-         IF (N==2 .AND. IBEG==0)  THEN
-C           NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
-            D(1,2) = WK(2,2)
-            GO TO 30
-         ELSE IF ((N==2) .OR. (N==3 .AND. IBEG==0))  THEN
-C           EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
-C           NOT-A-KNOT AT LEFT END POINT).
-            D(1,N) = TWO*WK(2,N)
-            WK(2,N) = ONE
-            IF (WK(2,N-1) == ZERO)  GO TO 5008
-            G = -ONE/WK(2,N-1)
-         ELSE
-C           NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
-C           KNOT AT LEFT END POINT.
-            G = WK(1,N-1) + WK(1,N)
-C           DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
-            D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1)
-     *                  + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
-            IF (WK(2,N-1) == ZERO)  GO TO 5008
-            G = -G/WK(2,N-1)
-            WK(2,N) = WK(1,N-1)
-         ENDIF
-      ELSE
-C        SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
-         D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
-         WK(2,N) = TWO
-         IF (WK(2,N-1) == ZERO)  GO TO 5008
-         G = -ONE/WK(2,N-1)
-      ENDIF
-C
-C  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
-C
-      WK(2,N) = G*WK(1,N-1) + WK(2,N)
-      IF (WK(2,N) == ZERO)   GO TO 5008
-      D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N)
-C
-C  CARRY OUT BACK SUBSTITUTION
-C
-   30 CONTINUE
-      DO J=NM1,1,-1
-         IF (WK(2,J) == ZERO)  GO TO 5008
-         D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J)
-      END DO
-C --------------------(  END  CODING FROM CUBSPL )--------------------
-C
-C  NORMAL RETURN.
-C
-      RETURN
-C
-C  ERROR RETURNS.
-C
- 5001 CONTINUE
-C     N.LT.2 RETURN.
-      IERR = -1
-      CALL XERMSG ('SLATEC', 'PCHSP',
-     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
-      RETURN
-C
- 5002 CONTINUE
-C     INCFD.LT.1 RETURN.
-      IERR = -2
-      CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR,
-     +   1)
-      RETURN
-C
- 5003 CONTINUE
-C     X-ARRAY NOT STRICTLY INCREASING.
-      IERR = -3
-      CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING'
-     +   , IERR, 1)
-      RETURN
-C
- 5004 CONTINUE
-C     IC OUT OF RANGE RETURN.
-      IERR = IERR - 3
-      CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1)
-      RETURN
-C
- 5007 CONTINUE
-C     NWK TOO SMALL RETURN.
-      IERR = -7
-      CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1)
-      RETURN
-C
- 5008 CONTINUE
-C     SINGULAR SYSTEM.
-C   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
-C   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
-      IERR = -8
-      CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR,
-     +   1)
-      RETURN
-C
- 5009 CONTINUE
-C     ERROR RETURN FROM PCHDF.
-C   *** THIS CASE SHOULD NEVER OCCUR ***
-      IERR = -9
-      CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR,
-     +   1)
-      RETURN
-C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/pchsp.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/pchsp.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/pchsp.f90	(revision 5105)
@@ -0,0 +1,388 @@
+!DECK PCHSP
+SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
+  !***BEGIN PROLOGUE  PCHSP
+  !***PURPOSE  Set derivatives needed to determine the Hermite represen-
+         ! tation of the cubic spline interpolant to given data, with
+         ! specified boundary conditions.
+  !***LIBRARY   SLATEC (PCHIP)
+  !***CATEGORY  E1A
+  !***TYPE      SINGLE PRECISION (PCHSP-S, DPCHSP-D)
+  !***KEYWORDS  CUBIC HERMITE INTERPOLATION, PCHIP,
+         !  PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION
+  !***AUTHOR  Fritsch, F. N., (LLNL)
+         !  Lawrence Livermore National Laboratory
+         !  P.O. Box 808  (L-316)
+         !  Livermore, CA  94550
+         !  FTS 532-4275, (510) 422-4275
+  !***DESCRIPTION
+  !
+  !      PCHSP:   Piecewise Cubic Hermite Spline
+  !
+  ! Computes the Hermite representation of the cubic spline inter-
+  ! polant to the data given in X and F satisfying the boundary
+  ! conditions specified by IC and VC.
+  !
+  ! To facilitate two-dimensional applications, includes an increment
+  ! between successive values of the F- and D-arrays.
+  !
+  ! The resulting piecewise cubic Hermite function may be evaluated
+  ! by PCHFE or PCHFD.
+  !
+  ! NOTE:  This is a modified version of C. de Boor's cubic spline
+  !        routine CUBSPL.
+  !
+  ! ----------------------------------------------------------------------
+  !
+  !  Calling sequence:
+  !
+  !    PARAMETER  (INCFD = ...)
+  !    INTEGER  IC(2), N, NWK, IERR
+  !    REAL  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
+  !
+  !    CALL  PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
+  !
+  !   Parameters:
+  !
+  ! IC -- (input) integer array of length 2 specifying desired
+  !       boundary conditions:
+  !       IC(1) = IBEG, desired condition at beginning of data.
+  !       IC(2) = IEND, desired condition at end of data.
+  !
+  !       IBEG = 0  to set D(1) so that the third derivative is con-
+  !          tinuous at X(2).  This is the "not a knot" condition
+  !          provided by de Boor's cubic spline routine CUBSPL.
+  !          < This is the default boundary condition. >
+  !       IBEG = 1  if first derivative at X(1) is given in VC(1).
+  !       IBEG = 2  if second derivative at X(1) is given in VC(1).
+  !       IBEG = 3  to use the 3-point difference formula for D(1).
+  !                 (Reverts to the default b.c. if N.LT.3 .)
+  !       IBEG = 4  to use the 4-point difference formula for D(1).
+  !                 (Reverts to the default b.c. if N.LT.4 .)
+  !      NOTES:
+  !       1. An error return is taken if IBEG is out of range.
+  !       2. For the "natural" boundary condition, use IBEG=2 and
+  !          VC(1)=0.
+  !
+  !       IEND may take on the same values as IBEG, but applied to
+  !       derivative at X(N).  In case IEND = 1 or 2, the value is
+  !       given in VC(2).
+  !
+  !      NOTES:
+  !       1. An error return is taken if IEND is out of range.
+  !       2. For the "natural" boundary condition, use IEND=2 and
+  !          VC(2)=0.
+  !
+  ! VC -- (input) real array of length 2 specifying desired boundary
+  !       values, as indicated above.
+  !       VC(1) need be set only if IC(1) = 1 or 2 .
+  !       VC(2) need be set only if IC(2) = 1 or 2 .
+  !
+  ! N -- (input) number of data points.  (Error return if N.LT.2 .)
+  !
+  ! X -- (input) real array of independent variable values.  The
+  !       elements of X must be strictly increasing:
+  !            X(I-1) .LT. X(I),  I = 2(1)N.
+  !       (Error return if not.)
+  !
+  ! F -- (input) real array of dependent variable values to be inter-
+  !       polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
+  !
+  ! D -- (output) real array of derivative values at the data points.
+  !       These values will determine the cubic spline interpolant
+  !       with the requested boundary conditions.
+  !       The value corresponding to X(I) is stored in
+  !            D(1+(I-1)*INCFD),  I=1(1)N.
+  !       No other entries in D are changed.
+  !
+  ! INCFD -- (input) increment between successive values in F and D.
+  !       This argument is provided primarily for 2-D applications.
+  !       (Error return if  INCFD.LT.1 .)
+  !
+  ! WK -- (scratch) real array of working storage.
+  !
+  ! NWK -- (input) length of work array.
+  !       (Error return if NWK.LT.2*N .)
+  !
+  ! IERR -- (output) error flag.
+  !       Normal return:
+  !          IERR = 0  (no errors).
+  !       "Recoverable" errors:
+  !          IERR = -1  if N.LT.2 .
+  !          IERR = -2  if INCFD.LT.1 .
+  !          IERR = -3  if the X-array is not strictly increasing.
+  !          IERR = -4  if IBEG.LT.0 or IBEG.GT.4 .
+  !          IERR = -5  if IEND.LT.0 of IEND.GT.4 .
+  !          IERR = -6  if both of the above are true.
+  !          IERR = -7  if NWK is too small.
+  !           NOTE:  The above errors are checked in the order listed,
+  !               and following arguments have **NOT** been validated.
+  !         (The D-array has not been changed in any of these cases.)
+  !          IERR = -8  in case of trouble solving the linear system
+  !                     for the interior derivative values.
+  !         (The D-array may have been changed in this case.)
+  !         (             Do **NOT** use it!                )
+  !
+  !***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
+  !             Verlag, New York, 1978, pp. 53-59.
+  !***ROUTINES CALLED  PCHDF, XERMSG
+  !***REVISION HISTORY  (YYMMDD)
+  !   820503  DATE WRITTEN
+  !   820804  Converted to SLATEC library version.
+  !   870707  Minor cosmetic changes to prologue.
+  !   890411  Added SAVE statements (Vers. 3.2).
+  !   890703  Corrected category record.  (WRB)
+  !   890831  Modified array declarations.  (WRB)
+  !   890831  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+  !   920429  Revised format and order of references.  (WRB,FNF)
+  !***END PROLOGUE  PCHSP
+  !  Programming notes:
+  !
+  ! To produce a double precision version, simply:
+  !    a. Change PCHSP to DPCHSP wherever it occurs,
+  !    b. Change the real declarations to double precision, and
+  !    c. Change the constants ZERO, HALF, ... to double precision.
+  !
+  !  DECLARE ARGUMENTS.
+  !
+  INTEGER :: IC(2), N, INCFD, NWK, IERR
+  REAL :: VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*)
+  !
+  !  DECLARE LOCAL VARIABLES.
+  !
+  INTEGER :: IBEG, IEND, INDEX, J, NM1
+  REAL :: G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO
+  SAVE ZERO, HALF, ONE, TWO, THREE
+  REAL :: PCHDF
+  !
+  DATA  ZERO /0./,  HALF /0.5/,  ONE /1./,  TWO /2./,  THREE /3./
+  !
+  !  VALIDITY-CHECK ARGUMENTS.
+  !
+  !***FIRST EXECUTABLE STATEMENT  PCHSP
+  IF ( N<2 )  GO TO 5001
+  IF ( INCFD<1 )  GO TO 5002
+  DO J = 2, N
+     IF ( X(J)<=X(J-1) )  GO TO 5003
+  END DO
+  !
+  IBEG = IC(1)
+  IEND = IC(2)
+  IERR = 0
+  IF ( (IBEG<0).OR.(IBEG>4) )  IERR = IERR - 1
+  IF ( (IEND<0).OR.(IEND>4) )  IERR = IERR - 2
+  IF ( IERR<0 )  GO TO 5004
+  !
+  !  FUNCTION DEFINITION IS OK -- GO ON.
+  !
+  IF ( NWK < 2*N )  GO TO 5007
+  !
+  !  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
+  !  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
+  DO J=2,N
+     WK(1,J) = X(J) - X(J-1)
+     WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J)
+  END DO
+  !
+  !  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
+  !
+  IF ( IBEG>N )  IBEG = 0
+  IF ( IEND>N )  IEND = 0
+  !
+  !  SET UP FOR BOUNDARY CONDITIONS.
+  !
+  IF ( (IBEG==1).OR.(IBEG==2) )  THEN
+     D(1,1) = VC(1)
+  ELSE IF (IBEG > 2)  THEN
+     ! PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
+     DO J = 1, IBEG
+        INDEX = IBEG-J+1
+        ! INDEX RUNS FROM IBEG DOWN TO 1.
+        XTEMP(J) = X(INDEX)
+        IF (J < IBEG)  STEMP(J) = WK(2,INDEX)
+  END DO
+              ! --------------------------------
+     D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR)
+              ! --------------------------------
+     IF (IERR /= 0)  GO TO 5009
+     IBEG = 1
+  ENDIF
+  !
+  IF ( (IEND==1).OR.(IEND==2) )  THEN
+     D(1,N) = VC(2)
+  ELSE IF (IEND > 2)  THEN
+     ! PICK UP LAST IEND POINTS.
+     DO J = 1, IEND
+        INDEX = N-IEND+J
+        ! INDEX RUNS FROM N+1-IEND UP TO N.
+        XTEMP(J) = X(INDEX)
+        IF (J < IEND)  STEMP(J) = WK(2,INDEX+1)
+  END DO
+              ! --------------------------------
+     D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR)
+              ! --------------------------------
+     IF (IERR /= 0)  GO TO 5009
+     IEND = 1
+  ENDIF
+  !
+  ! --------------------( BEGIN CODING FROM CUBSPL )--------------------
+  !
+  !  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
+  !  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
+  !  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
+  ! WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
+  !
+  !  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
+  !         WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
+  !
+  IF (IBEG == 0)  THEN
+     IF (N == 2)  THEN
+        ! NO CONDITION AT LEFT END AND N = 2.
+        WK(2,1) = ONE
+        WK(1,1) = ONE
+        D(1,1) = TWO*WK(2,2)
+     ELSE
+        ! NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
+        WK(2,1) = WK(1,3)
+        WK(1,1) = WK(1,2) + WK(1,3)
+        D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) &
+              + WK(1,2)**2*WK(2,3)) / WK(1,1)
+     ENDIF
+  ELSE IF (IBEG == 1)  THEN
+     ! SLOPE PRESCRIBED AT LEFT END.
+     WK(2,1) = ONE
+     WK(1,1) = ZERO
+  ELSE
+     ! SECOND DERIVATIVE PRESCRIBED AT LEFT END.
+     WK(2,1) = TWO
+     WK(1,1) = ONE
+     D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
+  ENDIF
+  !
+  !  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
+  !  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
+  !  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
+  !
+  NM1 = N-1
+  IF (NM1 > 1)  THEN
+     DO J=2,NM1
+        IF (WK(2,J-1) == ZERO)  GO TO 5008
+        G = -WK(1,J+1)/WK(2,J-1)
+        D(1,J) = G*D(1,J-1) &
+              + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J))
+        WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1))
+  END DO
+  ENDIF
+  !
+  !  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
+  !       (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
+  !
+  ! IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
+  ! SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
+  ! AT THIS POINT.
+  IF (IEND == 1)  GO TO 30
+  !
+  IF (IEND == 0)  THEN
+     IF (N==2 .AND. IBEG==0)  THEN
+        ! NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
+        D(1,2) = WK(2,2)
+        GO TO 30
+     ELSE IF ((N==2) .OR. (N==3 .AND. IBEG==0))  THEN
+        ! EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
+        ! NOT-A-KNOT AT LEFT END POINT).
+        D(1,N) = TWO*WK(2,N)
+        WK(2,N) = ONE
+        IF (WK(2,N-1) == ZERO)  GO TO 5008
+        G = -ONE/WK(2,N-1)
+     ELSE
+        ! NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
+        ! KNOT AT LEFT END POINT.
+        G = WK(1,N-1) + WK(1,N)
+        ! DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
+        D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) &
+              + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
+        IF (WK(2,N-1) == ZERO)  GO TO 5008
+        G = -G/WK(2,N-1)
+        WK(2,N) = WK(1,N-1)
+     ENDIF
+  ELSE
+     ! SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
+     D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
+     WK(2,N) = TWO
+     IF (WK(2,N-1) == ZERO)  GO TO 5008
+     G = -ONE/WK(2,N-1)
+  ENDIF
+  !
+  !  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
+  !
+  WK(2,N) = G*WK(1,N-1) + WK(2,N)
+  IF (WK(2,N) == ZERO)   GO TO 5008
+  D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N)
+  !
+  !  CARRY OUT BACK SUBSTITUTION
+  !
+   30   CONTINUE
+  DO J=NM1,1,-1
+     IF (WK(2,J) == ZERO)  GO TO 5008
+     D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J)
+  END DO
+  ! --------------------(  END  CODING FROM CUBSPL )--------------------
+  !
+  !  NORMAL RETURN.
+  !
+  RETURN
+  !
+  !  ERROR RETURNS.
+  !
+ 5001   CONTINUE
+  ! N.LT.2 RETURN.
+  IERR = -1
+  CALL XERMSG ('SLATEC', 'PCHSP', &
+        'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
+  RETURN
+  !
+ 5002   CONTINUE
+  ! INCFD.LT.1 RETURN.
+  IERR = -2
+  CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR, &
+        1)
+  RETURN
+  !
+ 5003   CONTINUE
+  ! X-ARRAY NOT STRICTLY INCREASING.
+  IERR = -3
+  CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING' &
+        , IERR, 1)
+  RETURN
+  !
+ 5004   CONTINUE
+  ! IC OUT OF RANGE RETURN.
+  IERR = IERR - 3
+  CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1)
+  RETURN
+  !
+ 5007   CONTINUE
+  ! NWK TOO SMALL RETURN.
+  IERR = -7
+  CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1)
+  RETURN
+  !
+ 5008   CONTINUE
+  ! SINGULAR SYSTEM.
+  !   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
+  !   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
+  IERR = -8
+  CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR, &
+        1)
+  RETURN
+  !
+ 5009   CONTINUE
+  ! ERROR RETURN FROM PCHDF.
+  !   *** THIS CASE SHOULD NEVER OCCUR ***
+  IERR = -9
+  CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR, &
+        1)
+  RETURN
+  !------------- LAST LINE OF PCHSP FOLLOWS ------------------------------
+END SUBROUTINE PCHSP
Index: DZ6/branches/Amaury_dev/libf/misc/q_sat.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/q_sat.F	(revision 5104)
+++ 	(revision )
@@ -1,70 +1,0 @@
-
-! $Header$
-
-
-
-      SUBROUTINE q_sat(np,temp,pres,qsat)
-
-      IMPLICIT none
-!======================================================================
-! Autheur(s): Z.X. Li (LMD/CNRS)
-!  reecriture vectorisee par F. Hourdin.
-! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
-!======================================================================
-! Arguments:
-! kelvin---input-R: temperature en Kelvin
-! millibar--input-R: pression en mb
-
-! q_sat----output-R: vapeur d'eau saturante en kg/kg
-!======================================================================
-
-      integer np
-      REAL temp(np),pres(np),qsat(np)
-
-      REAL r2es
-      PARAMETER (r2es=611.14 *18.0153/28.9644)
-
-      REAL r3les, r3ies, r3es
-      PARAMETER (R3LES=17.269)
-      PARAMETER (R3IES=21.875)
-
-      REAL r4les, r4ies, r4es
-      PARAMETER (R4LES=35.86)
-      PARAMETER (R4IES=7.66)
-
-      REAL rtt
-      PARAMETER (rtt=273.16)
-
-      REAL retv
-      PARAMETER (retv=28.9644/18.0153 - 1.0)
-
-      real zqsat
-      integer ip
-
-!     ------------------------------------------------------------------
-
-
-      do ip=1,np
-
-!      write(*,*)'kelvin,millibar=',kelvin,millibar
-!       write(*,*)'temp,pres=',temp(ip),pres(ip)
-
-         IF (temp(ip) <= rtt) THEN
-            r3es = r3ies
-            r4es = r4ies
-         ELSE
-            r3es = r3les
-            r4es = r4les
-         ENDIF
-
-         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
-         zqsat=MIN(0.5,ZQSAT)
-         zqsat=zqsat/(1.-retv *zqsat)
-
-         qsat(ip)= zqsat
-!      write(*,*)'qsat=',qsat(ip)
-
-      enddo
-
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/q_sat.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/q_sat.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/q_sat.f90	(revision 5105)
@@ -0,0 +1,70 @@
+
+! $Header$
+
+
+
+SUBROUTINE q_sat(np,temp,pres,qsat)
+
+  IMPLICIT none
+  !======================================================================
+  ! Autheur(s): Z.X. Li (LMD/CNRS)
+  !  reecriture vectorisee par F. Hourdin.
+  ! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+  !======================================================================
+  ! Arguments:
+  ! kelvin---input-R: temperature en Kelvin
+  ! millibar--input-R: pression en mb
+
+  ! q_sat----output-R: vapeur d'eau saturante en kg/kg
+  !======================================================================
+
+  integer :: np
+  REAL :: temp(np),pres(np),qsat(np)
+
+  REAL :: r2es
+  PARAMETER (r2es=611.14 *18.0153/28.9644)
+
+  REAL :: r3les, r3ies, r3es
+  PARAMETER (R3LES=17.269)
+  PARAMETER (R3IES=21.875)
+
+  REAL :: r4les, r4ies, r4es
+  PARAMETER (R4LES=35.86)
+  PARAMETER (R4IES=7.66)
+
+  REAL :: rtt
+  PARAMETER (rtt=273.16)
+
+  REAL :: retv
+  PARAMETER (retv=28.9644/18.0153 - 1.0)
+
+  real :: zqsat
+  integer :: ip
+
+  ! ------------------------------------------------------------------
+
+
+  do ip=1,np
+
+   ! write(*,*)'kelvin,millibar=',kelvin,millibar
+   !  write(*,*)'temp,pres=',temp(ip),pres(ip)
+
+     IF (temp(ip) <= rtt) THEN
+        r3es = r3ies
+        r4es = r4ies
+     ELSE
+        r3es = r3les
+        r4es = r4les
+     ENDIF
+
+     zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+     zqsat=MIN(0.5,ZQSAT)
+     zqsat=zqsat/(1.-retv *zqsat)
+
+     qsat(ip)= zqsat
+   ! write(*,*)'qsat=',qsat(ip)
+
+  enddo
+
+
+END SUBROUTINE q_sat
Index: DZ6/branches/Amaury_dev/libf/misc/ran1.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/ran1.F	(revision 5104)
+++ 	(revision )
@@ -1,38 +1,0 @@
-
-! $Id$
-
-      FUNCTION RAN1(IDUM)
-      IMPLICIT NONE
-      REAL RAN1
-      REAL,SAVE :: R(97)
-      REAL,PARAMETER :: RM1=3.8580247E-6,RM2=7.4373773E-6
-      INTEGER,SAVE :: IFF=0
-      integer,save :: ix1,ix2,ix3
-      INTEGER,PARAMETER :: M1=259200,IA1=7141,IC1=54773
-      INTEGER,PARAMETER :: M2=134456,IA2=8121,IC2=28411
-      INTEGER,PARAMETER :: M3=243000,IA3=4561,IC3=51349
-      INTEGER :: IDUM,J
-
-      IF (IDUM<0.OR.IFF==0) THEN
-        IFF=1
-        IX1=MOD(IC1-IDUM,M1)
-        IX1=MOD(IA1*IX1+IC1,M1)
-        IX2=MOD(IX1,M2)
-        IX1=MOD(IA1*IX1+IC1,M1)
-        IX3=MOD(IX1,M3)
-        DO J=1,97
-          IX1=MOD(IA1*IX1+IC1,M1)
-          IX2=MOD(IA2*IX2+IC2,M2)
-          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
-      END DO
-        IDUM=1
-      ENDIF
-      IX1=MOD(IA1*IX1+IC1,M1)
-      IX2=MOD(IA2*IX2+IC2,M2)
-      IX3=MOD(IA3*IX3+IC3,M3)
-      J=1+(97*IX3)/M3
-      IF(J>97.OR.J<1) stop 1
-      RAN1=R(J)
-      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/ran1.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/ran1.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/ran1.f90	(revision 5105)
@@ -0,0 +1,38 @@
+
+! $Id$
+
+FUNCTION RAN1(IDUM)
+  IMPLICIT NONE
+  REAL :: RAN1
+  REAL,SAVE :: R(97)
+  REAL,PARAMETER :: RM1=3.8580247E-6,RM2=7.4373773E-6
+  INTEGER,SAVE :: IFF=0
+  integer,save :: ix1,ix2,ix3
+  INTEGER,PARAMETER :: M1=259200,IA1=7141,IC1=54773
+  INTEGER,PARAMETER :: M2=134456,IA2=8121,IC2=28411
+  INTEGER,PARAMETER :: M3=243000,IA3=4561,IC3=51349
+  INTEGER :: IDUM,J
+
+  IF (IDUM<0.OR.IFF==0) THEN
+    IFF=1
+    IX1=MOD(IC1-IDUM,M1)
+    IX1=MOD(IA1*IX1+IC1,M1)
+    IX2=MOD(IX1,M2)
+    IX1=MOD(IA1*IX1+IC1,M1)
+    IX3=MOD(IX1,M3)
+    DO J=1,97
+      IX1=MOD(IA1*IX1+IC1,M1)
+      IX2=MOD(IA2*IX2+IC2,M2)
+      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+  END DO
+    IDUM=1
+  ENDIF
+  IX1=MOD(IA1*IX1+IC1,M1)
+  IX2=MOD(IA2*IX2+IC2,M2)
+  IX3=MOD(IA3*IX3+IC3,M3)
+  J=1+(97*IX3)/M3
+  IF(J>97.OR.J<1) stop 1
+  RAN1=R(J)
+  R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+
+END FUNCTION RAN1
Index: DZ6/branches/Amaury_dev/libf/misc/sort.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/sort.F	(revision 5104)
+++ 	(revision )
@@ -1,37 +1,0 @@
-
-! $Header$
-
-C
-C
-      SUBROUTINE sort(n,d)
-c
-c     P.Le Van
-c      
-c...  cette routine met le tableau d  dans l'ordre croissant  ....
-cc   ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc
-c      tion  situee + bas  IF(d(j).LE.p)  THEN     par
-c                           IF(d(j).GE.p)  THEN
-c
-
-      INTEGER n
-      REAL d(n) , p
-      INTEGER i,j,k
-
-      DO i=1,n-1
-        k=i
-        p=d(i)
-        DO j=i+1,n
-         IF(d(j)<=p) THEN
-           k=j
-           p=d(j)
-         ENDIF
-        ENDDO
-
-       IF(k/=i) THEN
-         d(k)=d(i)
-         d(i)=p
-       ENDIF
-      ENDDO
-
-       RETURN
-       END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/sort.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/sort.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/sort.f90	(revision 5105)
@@ -0,0 +1,37 @@
+
+! $Header$
+
+!
+!
+SUBROUTINE sort(n,d)
+  !
+  ! P.Le Van
+  !
+  !...  cette routine met le tableau d  dans l'ordre croissant  ....
+  !c   ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc
+  !  tion  situee + bas  IF(d(j).LE.p)  THEN     par
+  !                       IF(d(j).GE.p)  THEN
+  !
+
+  INTEGER :: n
+  REAL :: d(n) , p
+  INTEGER :: i,j,k
+
+  DO i=1,n-1
+    k=i
+    p=d(i)
+    DO j=i+1,n
+     IF(d(j)<=p) THEN
+       k=j
+       p=d(j)
+     ENDIF
+    ENDDO
+
+   IF(k/=i) THEN
+     d(k)=d(i)
+     d(i)=p
+   ENDIF
+  ENDDO
+
+
+END SUBROUTINE sort
Index: DZ6/branches/Amaury_dev/libf/misc/xercnt.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xercnt.F	(revision 5104)
+++ 	(revision )
@@ -1,62 +1,0 @@
-*DECK XERCNT
-      SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  XERCNT
-C***SUBSIDIARY
-C***PURPOSE  Allow user control over handling of errors.
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3C
-C***TYPE      ALL (XERCNT-A)
-C***KEYWORDS  ERROR, XERROR
-C***AUTHOR  Jones, R. E., (SNLA)
-C***DESCRIPTION
-C
-C     Abstract
-C        Allows user control over handling of individual errors.
-C        Just after each message is recorded, but before it is
-C        processed any further (i.e., before it is printed or
-C        a decision to abort is made), a CALL is made to XERCNT.
-C        If the user has provided his own version of XERCNT, he
-C        can then override the value of KONTROL used in processing
-C        this message by redefining its value.
-C        KONTRL may be set to any value from -2 to 2.
-C        The meanings for KONTRL are the same as in XSETF, except
-C        that the value of KONTRL changes only for this message.
-C        If KONTRL is set to a value outside the range from -2 to 2,
-C        it will be moved back into that range.
-C
-C     Description of Parameters
-C
-C      --Input--
-C        LIBRAR - the library that the routine is in.
-C        SUBROU - the SUBROUTINE that XERMSG is being called from
-C        MESSG  - the first 20 characters of the error message.
-C        NERR   - same as in the CALL to XERMSG.
-C        LEVEL  - same as in the CALL to XERMSG.
-C        KONTRL - the current value of the control flag as set
-C                 by a CALL to XSETF.
-C
-C      --Output--
-C        KONTRL - the new value of KONTRL.  If KONTRL is not
-C                 defined, it will remain at its original value.
-C                 This changed value of control affects only
-C                 the current occurrence of the current message.
-C
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  (NONE)
-C***REVISION HISTORY  (YYMMDD)
-C   790801  DATE WRITTEN
-C   861211  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900206  Routine changed from user-callable to subsidiary.  (WRB)
-C   900510  Changed calling sequence to include LIBRARY and SUBROUTINE
-C           names, changed routine name from XERCTL to XERCNT.  (RWC)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  XERCNT
-      CHARACTER*(*) LIBRAR, SUBROU, MESSG
-      INTEGER NERR, LEVEL, KONTRL
-C***FIRST EXECUTABLE STATEMENT  XERCNT
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/xercnt.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xercnt.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/xercnt.f90	(revision 5105)
@@ -0,0 +1,62 @@
+!DECK XERCNT
+SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  XERCNT
+  !***SUBSIDIARY
+  !***PURPOSE  Allow user control over handling of errors.
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3C
+  !***TYPE      ALL (XERCNT-A)
+  !***KEYWORDS  ERROR, XERROR
+  !***AUTHOR  Jones, R. E., (SNLA)
+  !***DESCRIPTION
+  !
+  ! Abstract
+  !    Allows user control over handling of individual errors.
+  !    Just after each message is recorded, but before it is
+  !    processed any further (i.e., before it is printed or
+  !    a decision to abort is made), a CALL is made to XERCNT.
+  !    If the user has provided his own version of XERCNT, he
+  !    can then override the value of KONTROL used in processing
+  !    this message by redefining its value.
+  !    KONTRL may be set to any value from -2 to 2.
+  !    The meanings for KONTRL are the same as in XSETF, except
+  !    that the value of KONTRL changes only for this message.
+  !    If KONTRL is set to a value outside the range from -2 to 2,
+  !    it will be moved back into that range.
+  !
+  ! Description of Parameters
+  !
+  !  --Input--
+  !    LIBRAR - the library that the routine is in.
+  !    SUBROU - the SUBROUTINE that XERMSG is being called from
+  !    MESSG  - the first 20 characters of the error message.
+  !    NERR   - same as in the CALL to XERMSG.
+  !    LEVEL  - same as in the CALL to XERMSG.
+  !    KONTRL - the current value of the control flag as set
+  !             by a CALL to XSETF.
+  !
+  !  --Output--
+  !    KONTRL - the new value of KONTRL.  If KONTRL is not
+  !             defined, it will remain at its original value.
+  !             This changed value of control affects only
+  !             the current occurrence of the current message.
+  !
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  (NONE)
+  !***REVISION HISTORY  (YYMMDD)
+  !   790801  DATE WRITTEN
+  !   861211  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900206  Routine changed from user-callable to subsidiary.  (WRB)
+  !   900510  Changed calling sequence to include LIBRARY and SUBROUTINE
+  !       names, changed routine name from XERCTL to XERCNT.  (RWC)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  XERCNT
+  CHARACTER(len=*) :: LIBRAR, SUBROU, MESSG
+  INTEGER :: NERR, LEVEL, KONTRL
+  !***FIRST EXECUTABLE STATEMENT  XERCNT
+
+END SUBROUTINE XERCNT
Index: DZ6/branches/Amaury_dev/libf/misc/xerhlt.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xerhlt.F	(revision 5104)
+++ 	(revision )
@@ -1,39 +1,0 @@
-*DECK XERHLT
-      SUBROUTINE XERHLT (MESSG)
-C***BEGIN PROLOGUE  XERHLT
-C***SUBSIDIARY
-C***PURPOSE  Abort program execution and print error message.
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3C
-C***TYPE      ALL (XERHLT-A)
-C***KEYWORDS  ABORT PROGRAM EXECUTION, ERROR, XERROR
-C***AUTHOR  Jones, R. E., (SNLA)
-C***DESCRIPTION
-C
-C     Abstract
-C        ***Note*** machine dependent routine
-C        XERHLT aborts the execution of the program.
-C        The error message causing the abort is given in the calling
-C        sequence, in case one needs it for printing on a dayfile,
-C        for example.
-C
-C     Description of Parameters
-C        MESSG is as in XERMSG.
-C
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  (NONE)
-C***REVISION HISTORY  (YYMMDD)
-C   790801  DATE WRITTEN
-C   861211  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900206  Routine changed from user-callable to subsidiary.  (WRB)
-C   900510  Changed calling sequence to delete length of character
-C           and changed routine name from XERABT to XERHLT.  (RWC)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  XERHLT
-      CHARACTER*(*) MESSG
-C***FIRST EXECUTABLE STATEMENT  XERHLT
-      STOP
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/xerhlt.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xerhlt.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/xerhlt.f90	(revision 5105)
@@ -0,0 +1,39 @@
+!DECK XERHLT
+SUBROUTINE XERHLT (MESSG)
+  !***BEGIN PROLOGUE  XERHLT
+  !***SUBSIDIARY
+  !***PURPOSE  Abort program execution and print error message.
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3C
+  !***TYPE      ALL (XERHLT-A)
+  !***KEYWORDS  ABORT PROGRAM EXECUTION, ERROR, XERROR
+  !***AUTHOR  Jones, R. E., (SNLA)
+  !***DESCRIPTION
+  !
+  ! Abstract
+  !    ***Note*** machine dependent routine
+  !    XERHLT aborts the execution of the program.
+  !    The error message causing the abort is given in the calling
+  !    sequence, in case one needs it for printing on a dayfile,
+  !    for example.
+  !
+  ! Description of Parameters
+  !    MESSG is as in XERMSG.
+  !
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  (NONE)
+  !***REVISION HISTORY  (YYMMDD)
+  !   790801  DATE WRITTEN
+  !   861211  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900206  Routine changed from user-callable to subsidiary.  (WRB)
+  !   900510  Changed calling sequence to delete length of character
+  !       and changed routine name from XERABT to XERHLT.  (RWC)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  XERHLT
+  CHARACTER(len=*) :: MESSG
+  !***FIRST EXECUTABLE STATEMENT  XERHLT
+  STOP
+END SUBROUTINE XERHLT
Index: DZ6/branches/Amaury_dev/libf/misc/xermsg.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xermsg.F	(revision 5104)
+++ 	(revision )
@@ -1,368 +1,0 @@
-*DECK XERMSG
-      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  XERMSG
-C***PURPOSE  Process error messages for SLATEC and other libraries.
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3C
-C***TYPE      ALL (XERMSG-A)
-C***KEYWORDS  ERROR MESSAGE, XERROR
-C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
-C***DESCRIPTION
-C
-C   XERMSG processes a diagnostic message in a manner determined by the
-C   value of LEVEL and the current value of the library error control
-C   flag, KONTRL.  See SUBROUTINE XSETF for details.
-C
-C    LIBRAR   A character constant (or character variable) with the name
-C             of the library.  This will be 'SLATEC' for the SLATEC
-C             Common Math Library.  The error handling package is
-C             general enough to be used by many libraries
-C             simultaneously, so it is desirable for the routine that
-C             detects and reports an error to identify the library name
-C             as well as the routine name.
-C
-C    SUBROU   A character constant (or character variable) with the name
-C             of the routine that detected the error.  Usually it is the
-C             name of the routine that is calling XERMSG.  There are
-C             some instances where a user callable library routine calls
-C             lower level subsidiary routines where the error is
-C             detected.  In such cases it may be more informative to
-C             supply the name of the routine the user called rather than
-C             the name of the subsidiary routine that detected the
-C             error.
-C
-C    MESSG    A character constant (or character variable) with the text
-C             of the error or warning message.  In the example below,
-C             the message is a character constant that contains a
-C             generic message.
-C
-C                   CALL XERMSG ('SLATEC', 'MMPY',
-C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
-C                  *3, 1)
-C
-C             It is possible (and is sometimes desirable) to generate a
-C             specific message--e.g., one that contains actual numeric
-C             values.  Specific numeric values can be converted into
-C             character strings using formatted WRITE statements into
-C             character variables.  This is called standard Fortran
-C             internal file I/O and is exemplified in the first three
-C             lines of the following example.  You can also catenate
-C             substrings of characters to construct the error message.
-C             Here is an example showing the use of both writing to
-C             an internal file and catenating character strings.
-C
-C                   CHARACTER*5 CHARN, CHARL
-C                   WRITE (CHARN,10) N
-C                   WRITE (CHARL,10) LDA
-C                10 FORMAT(I5)
-C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
-C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
-C                  *   CHARL, 3, 1)
-C
-C             There are two subtleties worth mentioning.  One is that
-C             the // for character catenation is used to construct the
-C             error message so that no single character constant is
-C             continued to the next line.  This avoids confusion as to
-C             whether there are trailing blanks at the end of the line.
-C             The second is that by catenating the parts of the message
-C             as an actual argument rather than encoding the entire
-C             message into one large character variable, we avoid
-C             having to know how long the message will be in order to
-C             declare an adequate length for that large character
-C             variable.  XERMSG calls XERPRN to print the message using
-C             multiple lines if necessary.  If the message is very long,
-C             XERPRN will break it into pieces of 72 characters (as
-C             requested by XERMSG) for printing on multiple lines.
-C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
-C             so that the total line length could be 76 characters.
-C             Note also that XERPRN scans the error message backwards
-C             to ignore trailing blanks.  Another feature is that
-C             the substring '$$' is treated as a new line sentinel
-C             by XERPRN.  If you want to construct a multiline
-C             message without having to count out multiples of 72
-C             characters, just use '$$' as a separator.  '$$'
-C             obviously must occur within 72 characters of the
-C             start of each line to have its intended effect since
-C             XERPRN is asked to wrap around at 72 characters in
-C             addition to looking for '$$'.
-C
-C    NERR     An integer value that is chosen by the library routine's
-C             author.  It must be in the range -99 to 999 (three
-C             printable digits).  Each distinct error should have its
-C             own error number.  These error numbers should be described
-C             in the machine readable documentation for the routine.
-C             The error numbers need be unique only within each routine,
-C             so it is reasonable for each routine to start enumerating
-C             errors from 1 and proceeding to the next integer.
-C
-C    LEVEL    An integer value in the range 0 to 2 that indicates the
-C             level (severity) of the error.  Their meanings are
-C
-C            -1  A warning message.  This is used if it is not clear
-C                that there really is an error, but the user's attention
-C                may be needed.  An attempt is made to only print this
-C                message once.
-C
-C             0  A warning message.  This is used if it is not clear
-C                that there really is an error, but the user's attention
-C                may be needed.
-C
-C             1  A recoverable error.  This is used even if the error is
-C                so serious that the routine cannot return any useful
-C                answer.  If the user has told the error package to
-C                return after recoverable errors, then XERMSG will
-C                return to the Library routine which can then return to
-C                the user's routine.  The user may also permit the error
-C                package to terminate the program upon encountering a
-C                recoverable error.
-C
-C             2  A fatal error.  XERMSG will not return to its caller
-C                after it receives a fatal error.  This level should
-C                hardly ever be used; it is much better to allow the
-C                user a chance to recover.  An example of one of the few
-C                cases in which it is permissible to declare a level 2
-C                error is a reverse communication Library routine that
-C                is likely to be called repeatedly until it integrates
-C                across some interval.  If there is a serious error in
-C                the input such that another step cannot be taken and
-C                the Library routine is called again without the input
-C                error having been corrected by the caller, the Library
-C                routine will probably be called forever with improper
-C                input.  In this case, it is reasonable to declare the
-C                error to be fatal.
-C
-C    Each of the arguments to XERMSG is input; none will be modified by
-C    XERMSG.  A routine may make multiple calls to XERMSG with warning
-C    level messages; however, after a CALL to XERMSG with a recoverable
-C    error, the routine should return to the user.  Do not try to call
-C    XERMSG with a second recoverable error after the first recoverable
-C    error because the error package saves the error number.  The user
-C    can retrieve this error number by calling another entry point in
-C    the error handling package and then clear the error number when
-C    recovering from the error.  Calling XERMSG in succession causes the
-C    old error number to be overwritten by the latest error number.
-C    This is considered harmless for error numbers associated with
-C    warning messages but must not be done for error numbers of serious
-C    errors.  After a CALL to XERMSG with a recoverable error, the user
-C    must be given a chance to CALL NUMXER or XERCLR to retrieve or
-C    clear the error number.
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
-C***REVISION HISTORY  (YYMMDD)
-C   880101  DATE WRITTEN
-C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
-C           THERE ARE TWO BASIC CHANGES.
-C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
-C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
-C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
-C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
-C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
-C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
-C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
-C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
-C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
-C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
-C               OF LOWER CASE.
-C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
-C           THE PRINCIPAL CHANGES ARE
-C           1.  CLARIFY COMMENTS IN THE PROLOGUES
-C           2.  RENAME XRPRNT TO XERPRN
-C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
-C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
-C               CHARACTER FOR NEW RECORDS.
-C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
-C           CLEAN UP THE CODING.
-C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
-C           PREFIX.
-C   891013  REVISED TO CORRECT COMMENTS.
-C   891214  Prologue converted to Version 4.0 format.  (WRB)
-C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
-C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
-C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
-C           XERCTL to XERCNT.  (RWC)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  XERMSG
-      CHARACTER*(*) LIBRAR, SUBROU, MESSG
-      CHARACTER*8 XLIBR, XSUBR
-      CHARACTER*72  TEMP
-      CHARACTER*20  LFIRST
-      INTEGER NERR, LEVEL, LKNTRL
-      INTEGER J4SAVE, MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL
-      INTEGER MKNTRL, LTEMP
-C***FIRST EXECUTABLE STATEMENT  XERMSG
-      LKNTRL = J4SAVE (2, 0, .FALSE.)
-      MAXMES = J4SAVE (4, 0, .FALSE.)
-C
-C       LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
-C       MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
-C          SHOULD BE PRINTED.
-C
-C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
-C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
-C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
-C
-      IF (NERR<-9999999 .OR. NERR>99999999 .OR. NERR==0 .OR.
-     *   LEVEL<-1 .OR. LEVEL>2) THEN
-         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
-     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
-     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
-         CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
-         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
-         RETURN
-      ENDIF
-C
-C       RECORD THE MESSAGE.
-C
-      I = J4SAVE (1, NERR, .TRUE.)
-      CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
-C
-C       HANDLE PRINT-ONCE WARNING MESSAGES.
-C
-      IF (LEVEL==-1 .AND. KOUNT>1) RETURN
-C
-C       ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
-C
-      XLIBR  = LIBRAR
-      XSUBR  = SUBROU
-      LFIRST = MESSG
-      LERR   = NERR
-      LLEVEL = LEVEL
-      CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
-C
-      LKNTRL = MAX(-2, MIN(2,LKNTRL))
-      MKNTRL = ABS(LKNTRL)
-C
-C       SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
-C       ZERO AND THE ERROR IS NOT FATAL.
-C
-      IF (LEVEL<2 .AND. LKNTRL==0) GO TO 30
-      IF (LEVEL==0 .AND. KOUNT>MAXMES) GO TO 30
-      IF (LEVEL==1 .AND. KOUNT>MAXMES .AND. MKNTRL==1) GO TO 30
-      IF (LEVEL==2 .AND. KOUNT>MAX(1,MAXMES)) GO TO 30
-C
-C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
-C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
-C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
-C       IS NOT ZERO.
-C
-      IF (LKNTRL /= 0) THEN
-         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
-         I = MIN(LEN(SUBROU), 16)
-         TEMP(22:21+I) = SUBROU(1:I)
-         TEMP(22+I:33+I) = ' IN LIBRARY '
-         LTEMP = 33 + I
-         I = MIN(LEN(LIBRAR), 16)
-         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
-         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
-         LTEMP = LTEMP + I + 1
-         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
-      ENDIF
-C
-C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
-C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
-C       FROM EACH OF THE FOLLOWING THREE OPTIONS.
-C       1.  LEVEL OF THE MESSAGE
-C              'INFORMATIVE MESSAGE'
-C              'POTENTIALLY RECOVERABLE ERROR'
-C              'FATAL ERROR'
-C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
-C              'PROG CONTINUES'
-C              'PROG ABORTED'
-C       3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
-C           MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
-C           WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
-C              'TRACEBACK REQUESTED'
-C              'TRACEBACK NOT REQUESTED'
-C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
-C       EXCEED 74 CHARACTERS.
-C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
-C
-      IF (LKNTRL > 0) THEN
-C
-C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
-C
-         IF (LEVEL <= 0) THEN
-            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
-            LTEMP = 20
-         ELSEIF (LEVEL == 1) THEN
-            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
-            LTEMP = 30
-         ELSE
-            TEMP(1:12) = 'FATAL ERROR,'
-            LTEMP = 12
-         ENDIF
-C
-C       THEN WHETHER THE PROGRAM WILL CONTINUE.
-C
-         IF ((MKNTRL==2 .AND. LEVEL>=1) .OR.
-     *       (MKNTRL==1 .AND. LEVEL==2)) THEN
-            TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
-            LTEMP = LTEMP + 14
-         ELSE
-            TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
-            LTEMP = LTEMP + 16
-         ENDIF
-C
-C       FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
-C
-         IF (LKNTRL > 0) THEN
-            TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
-            LTEMP = LTEMP + 20
-         ELSE
-            TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
-            LTEMP = LTEMP + 24
-         ENDIF
-         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
-      ENDIF
-C
-C       NOW SEND OUT THE MESSAGE.
-C
-      CALL XERPRN (' *  ', -1, MESSG, 72)
-C
-C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
-C          TRACEBACK.
-C
-      IF (LKNTRL > 0) THEN
-         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
-         DO I=16,22
-            IF (TEMP(I:I) /= ' ') GO TO 20
-      END DO
-C
-   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
-         CALL FDUMP
-      ENDIF
-C
-C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
-C
-      IF (LKNTRL /= 0) THEN
-         CALL XERPRN (' *  ', -1, ' ', 72)
-         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
-         CALL XERPRN ('    ',  0, ' ', 72)
-      ENDIF
-C
-C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
-C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
-C
-   30 IF (LEVEL<=0 .OR. (LEVEL==1 .AND. MKNTRL<=1)) RETURN
-C
-C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
-C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
-C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
-C
-      IF (LKNTRL>0 .AND. KOUNT<MAX(1,MAXMES)) THEN
-         IF (LEVEL == 1) THEN
-            CALL XERPRN
-     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
-         ELSE
-            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
-         ENDIF
-         CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
-         CALL XERHLT (' ')
-      ELSE
-         CALL XERHLT (MESSG)
-      ENDIF
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/xermsg.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xermsg.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/xermsg.f90	(revision 5105)
@@ -0,0 +1,368 @@
+!DECK XERMSG
+SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  XERMSG
+  !***PURPOSE  Process error messages for SLATEC and other libraries.
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3C
+  !***TYPE      ALL (XERMSG-A)
+  !***KEYWORDS  ERROR MESSAGE, XERROR
+  !***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
+  !***DESCRIPTION
+  !
+  !   XERMSG processes a diagnostic message in a manner determined by the
+  !   value of LEVEL and the current value of the library error control
+  !   flag, KONTRL.  See SUBROUTINE XSETF for details.
+  !
+  !    LIBRAR   A character constant (or character variable) with the name
+  !         of the library.  This will be 'SLATEC' for the SLATEC
+  !         Common Math Library.  The error handling package is
+  !         general enough to be used by many libraries
+  !         simultaneously, so it is desirable for the routine that
+  !         detects and reports an error to identify the library name
+  !         as well as the routine name.
+  !
+  !    SUBROU   A character constant (or character variable) with the name
+  !             of the routine that detected the error.  Usually it is the
+  !         name of the routine that is calling XERMSG.  There are
+  !         some instances where a user callable library routine calls
+  !         lower level subsidiary routines where the error is
+  !         detected.  In such cases it may be more informative to
+  !         supply the name of the routine the user called rather than
+  !         the name of the subsidiary routine that detected the
+  !         error.
+  !
+  !    MESSG    A character constant (or character variable) with the text
+  !         of the error or warning message.  In the example below,
+  !         the message is a character constant that contains a
+  !         generic message.
+  !
+  !               CALL XERMSG ('SLATEC', 'MMPY',
+  !              *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
+  !              *3, 1)
+  !
+  !         It is possible (and is sometimes desirable) to generate a
+  !         specific message--e.g., one that contains actual numeric
+  !         values.  Specific numeric values can be converted into
+  !         character strings using formatted WRITE statements into
+  !         character variables.  This is called standard Fortran
+  !         internal file I/O and is exemplified in the first three
+  !         lines of the following example.  You can also catenate
+  !         substrings of characters to construct the error message.
+  !         Here is an example showing the use of both writing to
+  !         an internal file and catenating character strings.
+  !
+  !               CHARACTER*5 CHARN, CHARL
+  !               WRITE (CHARN,10) N
+  !               WRITE (CHARL,10) LDA
+  !            10 FORMAT(I5)
+  !               CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
+  !              *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
+  !              *   CHARL, 3, 1)
+  !
+  !         There are two subtleties worth mentioning.  One is that
+  !         the // for character catenation is used to construct the
+  !         error message so that no single character constant is
+  !         continued to the next line.  This avoids confusion as to
+  !         whether there are trailing blanks at the end of the line.
+  !         The second is that by catenating the parts of the message
+  !             as an actual argument rather than encoding the entire
+  !         message into one large character variable, we avoid
+  !         having to know how long the message will be in order to
+  !         declare an adequate length for that large character
+  !         variable.  XERMSG calls XERPRN to print the message using
+  !         multiple lines if necessary.  If the message is very long,
+  !         XERPRN will break it into pieces of 72 characters (as
+  !         requested by XERMSG) for printing on multiple lines.
+  !         Also, XERMSG asks XERPRN to prefix each line with ' *  '
+  !         so that the total line length could be 76 characters.
+  !         Note also that XERPRN scans the error message backwards
+  !         to ignore trailing blanks.  Another feature is that
+  !         the substring '$$' is treated as a new line sentinel
+  !         by XERPRN.  If you want to construct a multiline
+  !         message without having to count out multiples of 72
+  !         characters, just use '$$' as a separator.  '$$'
+  !         obviously must occur within 72 characters of the
+  !         start of each line to have its intended effect since
+  !         XERPRN is asked to wrap around at 72 characters in
+  !         addition to looking for '$$'.
+  !
+  !    NERR     An integer value that is chosen by the library routine's
+  !         author.  It must be in the range -99 to 999 (three
+  !         printable digits).  Each distinct error should have its
+  !         own error number.  These error numbers should be described
+  !         in the machine readable documentation for the routine.
+  !         The error numbers need be unique only within each routine,
+  !         so it is reasonable for each routine to start enumerating
+  !         errors from 1 and proceeding to the next integer.
+  !
+  !    LEVEL    An integer value in the range 0 to 2 that indicates the
+  !         level (severity) of the error.  Their meanings are
+  !
+  !        -1  A warning message.  This is used if it is not clear
+  !            that there really is an error, but the user's attention
+  !            may be needed.  An attempt is made to only print this
+  !            message once.
+  !
+  !         0  A warning message.  This is used if it is not clear
+  !            that there really is an error, but the user's attention
+  !            may be needed.
+  !
+  !         1  A recoverable error.  This is used even if the error is
+  !            so serious that the routine cannot return any useful
+  !            answer.  If the user has told the error package to
+  !            return after recoverable errors, then XERMSG will
+  !            return to the Library routine which can then return to
+  !            the user's routine.  The user may also permit the error
+  !            package to terminate the program upon encountering a
+  !            recoverable error.
+  !
+  !         2  A fatal error.  XERMSG will not return to its caller
+  !            after it receives a fatal error.  This level should
+  !            hardly ever be used; it is much better to allow the
+  !            user a chance to recover.  An example of one of the few
+  !            cases in which it is permissible to declare a level 2
+  !            error is a reverse communication Library routine that
+  !            is likely to be called repeatedly until it integrates
+  !            across some interval.  If there is a serious error in
+  !            the input such that another step cannot be taken and
+  !            the Library routine is called again without the input
+  !            error having been corrected by the caller, the Library
+  !            routine will probably be called forever with improper
+  !            input.  In this case, it is reasonable to declare the
+  !            error to be fatal.
+  !
+  !    Each of the arguments to XERMSG is input; none will be modified by
+  !    XERMSG.  A routine may make multiple calls to XERMSG with warning
+  !    level messages; however, after a CALL to XERMSG with a recoverable
+  !    error, the routine should return to the user.  Do not try to call
+  !    XERMSG with a second recoverable error after the first recoverable
+  !    error because the error package saves the error number.  The user
+  !    can retrieve this error number by calling another entry point in
+  !    the error handling package and then clear the error number when
+  !    recovering from the error.  Calling XERMSG in succession causes the
+  !    old error number to be overwritten by the latest error number.
+  !    This is considered harmless for error numbers associated with
+  !    warning messages but must not be done for error numbers of serious
+  !    errors.  After a CALL to XERMSG with a recoverable error, the user
+  !    must be given a chance to CALL NUMXER or XERCLR to retrieve or
+  !    clear the error number.
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
+  !***REVISION HISTORY  (YYMMDD)
+  !   880101  DATE WRITTEN
+  !   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
+  !       THERE ARE TWO BASIC CHANGES.
+  !       1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
+  !           PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
+  !           INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
+  !           ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
+  !           ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
+  !           ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
+  !           72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
+  !           LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
+  !       2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
+  !           FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
+  !           OF LOWER CASE.
+  !   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
+  !       THE PRINCIPAL CHANGES ARE
+  !       1.  CLARIFY COMMENTS IN THE PROLOGUES
+  !       2.  RENAME XRPRNT TO XERPRN
+  !       3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
+  !           SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
+  !           CHARACTER FOR NEW RECORDS.
+  !   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+  !       CLEAN UP THE CODING.
+  !   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
+  !       PREFIX.
+  !   891013  REVISED TO CORRECT COMMENTS.
+  !   891214  Prologue converted to Version 4.0 format.  (WRB)
+  !   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
+  !       NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
+  !       LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
+  !       XERCTL to XERCNT.  (RWC)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  XERMSG
+  CHARACTER(len=*) :: LIBRAR, SUBROU, MESSG
+  CHARACTER(len=8) :: XLIBR, XSUBR
+  CHARACTER(len=72) :: TEMP
+  CHARACTER(len=20) :: LFIRST
+  INTEGER :: NERR, LEVEL, LKNTRL
+  INTEGER :: J4SAVE, MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL
+  INTEGER :: MKNTRL, LTEMP
+  !***FIRST EXECUTABLE STATEMENT  XERMSG
+  LKNTRL = J4SAVE (2, 0, .FALSE.)
+  MAXMES = J4SAVE (4, 0, .FALSE.)
+  !
+  !   LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
+  !   MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
+  !      SHOULD BE PRINTED.
+  !
+  !   WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
+  !      CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
+  !      AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
+  !
+  IF (NERR<-9999999 .OR. NERR>99999999 .OR. NERR==0 .OR. &
+        LEVEL<-1 .OR. LEVEL>2) THEN
+     CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // &
+           'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// &
+           'JOB ABORT DUE TO FATAL ERROR.', 72)
+     CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
+     CALL XERHLT (' ***XERMSG -- INVALID INPUT')
+     RETURN
+  ENDIF
+  !
+  !   RECORD THE MESSAGE.
+  !
+  I = J4SAVE (1, NERR, .TRUE.)
+  CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
+  !
+  !   HANDLE PRINT-ONCE WARNING MESSAGES.
+  !
+  IF (LEVEL==-1 .AND. KOUNT>1) RETURN
+  !
+  !   ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
+  !
+  XLIBR  = LIBRAR
+  XSUBR  = SUBROU
+  LFIRST = MESSG
+  LERR   = NERR
+  LLEVEL = LEVEL
+  CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
+  !
+  LKNTRL = MAX(-2, MIN(2,LKNTRL))
+  MKNTRL = ABS(LKNTRL)
+  !
+  !   SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
+  !   ZERO AND THE ERROR IS NOT FATAL.
+  !
+  IF (LEVEL<2 .AND. LKNTRL==0) GO TO 30
+  IF (LEVEL==0 .AND. KOUNT>MAXMES) GO TO 30
+  IF (LEVEL==1 .AND. KOUNT>MAXMES .AND. MKNTRL==1) GO TO 30
+  IF (LEVEL==2 .AND. KOUNT>MAX(1,MAXMES)) GO TO 30
+  !
+  !   ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
+  !   MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
+  !   AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
+  !   IS NOT ZERO.
+  !
+  IF (LKNTRL /= 0) THEN
+     TEMP(1:21) = 'MESSAGE FROM ROUTINE '
+     I = MIN(LEN(SUBROU), 16)
+     TEMP(22:21+I) = SUBROU(1:I)
+     TEMP(22+I:33+I) = ' IN LIBRARY '
+     LTEMP = 33 + I
+     I = MIN(LEN(LIBRAR), 16)
+     TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
+     TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
+     LTEMP = LTEMP + I + 1
+     CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+  ENDIF
+  !
+  !   IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
+  !   PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
+  !   FROM EACH OF THE FOLLOWING THREE OPTIONS.
+  !   1.  LEVEL OF THE MESSAGE
+  !          'INFORMATIVE MESSAGE'
+  !          'POTENTIALLY RECOVERABLE ERROR'
+  !          'FATAL ERROR'
+  !   2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
+  !          'PROG CONTINUES'
+  !          'PROG ABORTED'
+  !   3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
+  !       MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
+  !       WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
+  !          'TRACEBACK REQUESTED'
+  !          'TRACEBACK NOT REQUESTED'
+  !   NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
+  !   EXCEED 74 CHARACTERS.
+  !   WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
+  !
+  IF (LKNTRL > 0) THEN
+  !
+  !   THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
+  !
+     IF (LEVEL <= 0) THEN
+        TEMP(1:20) = 'INFORMATIVE MESSAGE,'
+        LTEMP = 20
+     ELSEIF (LEVEL == 1) THEN
+        TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
+        LTEMP = 30
+     ELSE
+        TEMP(1:12) = 'FATAL ERROR,'
+        LTEMP = 12
+     ENDIF
+  !
+  !   THEN WHETHER THE PROGRAM WILL CONTINUE.
+  !
+     IF ((MKNTRL==2 .AND. LEVEL>=1) .OR. &
+           (MKNTRL==1 .AND. LEVEL==2)) THEN
+        TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
+        LTEMP = LTEMP + 14
+     ELSE
+        TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
+        LTEMP = LTEMP + 16
+     ENDIF
+  !
+  !   FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
+  !
+     IF (LKNTRL > 0) THEN
+        TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
+        LTEMP = LTEMP + 20
+     ELSE
+        TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
+        LTEMP = LTEMP + 24
+     ENDIF
+     CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+  ENDIF
+  !
+  !   NOW SEND OUT THE MESSAGE.
+  !
+  CALL XERPRN (' *  ', -1, MESSG, 72)
+  !
+  !   IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
+  !      TRACEBACK.
+  !
+  IF (LKNTRL > 0) THEN
+     WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
+     DO I=16,22
+        IF (TEMP(I:I) /= ' ') GO TO 20
+  END DO
+  !
+   20   CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
+     CALL FDUMP
+  ENDIF
+  !
+  !   IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
+  !
+  IF (LKNTRL /= 0) THEN
+     CALL XERPRN (' *  ', -1, ' ', 72)
+     CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
+     CALL XERPRN ('    ',  0, ' ', 72)
+  ENDIF
+  !
+  !   IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
+  !   CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
+  !
+   30   IF (LEVEL<=0 .OR. (LEVEL==1 .AND. MKNTRL<=1)) RETURN
+  !
+  !   THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
+  !   FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
+  !   SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
+  !
+  IF (LKNTRL>0 .AND. KOUNT<MAX(1,MAXMES)) THEN
+     IF (LEVEL == 1) THEN
+        CALL XERPRN &
+              (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
+     ELSE
+        CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
+     ENDIF
+     CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
+     CALL XERHLT (' ')
+  ELSE
+     CALL XERHLT (MESSG)
+  ENDIF
+
+END SUBROUTINE XERMSG
Index: DZ6/branches/Amaury_dev/libf/misc/xerprn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xerprn.F	(revision 5104)
+++ 	(revision )
@@ -1,231 +1,0 @@
-*DECK XERPRN
-      SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  XERPRN
-C***SUBSIDIARY
-C***PURPOSE  Print error messages processed by XERMSG.
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3C
-C***TYPE      ALL (XERPRN-A)
-C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
-C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
-C***DESCRIPTION
-C
-C This routine sends one or more lines to each of the (up to five)
-C logical units to which error messages are to be sent.  This routine
-C is called several times by XERMSG, sometimes with a single line to
-C print and sometimes with a (potentially very long) message that may
-C wrap around into multiple lines.
-C
-C PREFIX  Input argument of type CHARACTER.  This argument contains
-C         characters to be put at the beginning of each line before
-C         the body of the message.  No more than 16 characters of
-C         PREFIX will be used.
-C
-C NPREF   Input argument of type INTEGER.  This argument is the number
-C         of characters to use from PREFIX.  If it is negative, the
-C         intrinsic function LEN is used to determine its length.  If
-C         it is zero, PREFIX is not used.  If it exceeds 16 or if
-C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
-C         used.  If NPREF is positive and the length of PREFIX is less
-C         than NPREF, a copy of PREFIX extended with blanks to length
-C         NPREF will be used.
-C
-C MESSG   Input argument of type CHARACTER.  This is the text of a
-C         message to be printed.  If it is a long message, it will be
-C         broken into pieces for printing on multiple lines.  Each line
-C         will start with the appropriate prefix and be followed by a
-C         piece of the message.  NWRAP is the number of characters per
-C         piece; that is, after each NWRAP characters, we break and
-C         start a new line.  In addition the characters '$$' embedded
-C         in MESSG are a sentinel for a new line.  The counting of
-C         characters up to NWRAP starts over for each new line.  The
-C         value of NWRAP typically used by XERMSG is 72 since many
-C         older error messages in the SLATEC Library are laid out to
-C         rely on wrap-around every 72 characters.
-C
-C NWRAP   Input argument of type INTEGER.  This gives the maximum size
-C         piece into which to break MESSG for printing on multiple
-C         lines.  An embedded '$$' ends a line, and the count restarts
-C         at the following character.  If a line break does not occur
-C         on a blank (it would split a word) that word is moved to the
-C         next line.  Values of NWRAP less than 16 will be treated as
-C         16.  Values of NWRAP greater than 132 will be treated as 132.
-C         The actual line length will be NPREF + NWRAP after NPREF has
-C         been adjusted to fall between 0 and 16 and NWRAP has been
-C         adjusted to fall between 16 and 132.
-C
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  I1MACH, XGETUA
-C***REVISION HISTORY  (YYMMDD)
-C   880621  DATE WRITTEN
-C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
-C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
-C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
-C           SLASH CHARACTER IN FORMAT STATEMENTS.
-C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
-C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
-C           LINES TO BE PRINTED.
-C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
-C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
-C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
-C   891214  Prologue converted to Version 4.0 format.  (WRB)
-C   900510  Added code to break messages between words.  (RWC)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  XERPRN
-      CHARACTER*(*) PREFIX, MESSG
-      INTEGER NPREF, NWRAP
-      CHARACTER*148 CBUFF
-      INTEGER IU(5), NUNIT
-      CHARACTER*2 NEWLIN
-      PARAMETER (NEWLIN = '$$')
-      INTEGER N, I1MACH, I, LPREF, LWRAP, LENMSG, NEXTC
-      INTEGER LPIECE, IDELTA
-C***FIRST EXECUTABLE STATEMENT  XERPRN
-      CALL XGETUA(IU,NUNIT)
-C
-C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
-C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
-C       ERROR MESSAGE UNIT.
-C
-      N = I1MACH(4)
-      DO I=1,NUNIT
-         IF (IU(I) == 0) IU(I) = N
-      END DO
-C
-C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
-C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
-C       THE REST OF THIS ROUTINE.
-C
-      IF ( NPREF < 0 ) THEN
-         LPREF = LEN(PREFIX)
-      ELSE
-         LPREF = NPREF
-      ENDIF
-      LPREF = MIN(16, LPREF)
-      IF (LPREF /= 0) CBUFF(1:LPREF) = PREFIX
-C
-C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
-C       TIME FROM MESSG TO PRINT ON ONE LINE.
-C
-      LWRAP = MAX(16, MIN(132, NWRAP))
-C
-C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
-C
-      LENMSG = LEN(MESSG)
-      N = LENMSG
-      DO I=1,N
-         IF (MESSG(LENMSG:LENMSG) /= ' ') GO TO 30
-         LENMSG = LENMSG - 1
-      END DO
-   30 CONTINUE
-C
-C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
-C
-      IF (LENMSG == 0) THEN
-         CBUFF(LPREF+1:LPREF+1) = ' '
-         DO I=1,NUNIT
-            WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
-      END DO
-         RETURN
-      ENDIF
-C
-C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
-C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
-C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
-C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
-C
-C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
-C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
-C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
-C       OF THE SECOND ARGUMENT.
-C
-C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
-C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
-C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
-C       POSITION NEXTC.
-C
-C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
-C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
-C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
-C                       WHICHEVER IS LESS.
-C
-C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
-C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
-C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
-C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
-C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
-C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
-C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
-C                       SHOULD BE INCREMENTED BY 2.
-C
-C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
-C
-C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
-C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
-C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
-C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
-C                       AT THE END OF A LINE.
-C
-      NEXTC = 1
-   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
-      IF (LPIECE == 0) THEN
-C
-C       THERE WAS NO NEW LINE SENTINEL FOUND.
-C
-         IDELTA = 0
-         LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
-         IF (LPIECE < LENMSG+1-NEXTC) THEN
-            DO I=LPIECE+1,2,-1
-               IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN
-                  LPIECE = I-1
-                  IDELTA = 1
-                  GOTO 54
-               ENDIF
-      END DO
-         ENDIF
-   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
-         NEXTC = NEXTC + LPIECE + IDELTA
-      ELSEIF (LPIECE == 1) THEN
-C
-C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
-C       DON'T PRINT A BLANK LINE.
-C
-         NEXTC = NEXTC + 2
-         GO TO 50
-      ELSEIF (LPIECE > LWRAP+1) THEN
-C
-C       LPIECE SHOULD BE SET DOWN TO LWRAP.
-C
-         IDELTA = 0
-         LPIECE = LWRAP
-         DO I=LPIECE+1,2,-1
-            IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN
-               LPIECE = I-1
-               IDELTA = 1
-               GOTO 58
-            ENDIF
-      END DO
-   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
-         NEXTC = NEXTC + LPIECE + IDELTA
-      ELSE
-C
-C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
-C       WE SHOULD DECREMENT LPIECE BY ONE.
-C
-         LPIECE = LPIECE - 1
-         CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
-         NEXTC  = NEXTC + LPIECE + 2
-      ENDIF
-C
-C       PRINT
-C
-      DO I=1,NUNIT
-         WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
-      END DO
-C
-      IF (NEXTC <= LENMSG) GO TO 50
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/xerprn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xerprn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/xerprn.f90	(revision 5105)
@@ -0,0 +1,231 @@
+!DECK XERPRN
+SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  XERPRN
+  !***SUBSIDIARY
+  !***PURPOSE  Print error messages processed by XERMSG.
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3C
+  !***TYPE      ALL (XERPRN-A)
+  !***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
+  !***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
+  !***DESCRIPTION
+  !
+  ! This routine sends one or more lines to each of the (up to five)
+  ! logical units to which error messages are to be sent.  This routine
+  ! is called several times by XERMSG, sometimes with a single line to
+  ! print and sometimes with a (potentially very long) message that may
+  ! wrap around into multiple lines.
+  !
+  ! PREFIX  Input argument of type CHARACTER.  This argument contains
+  !     characters to be put at the beginning of each line before
+  !     the body of the message.  No more than 16 characters of
+  !     PREFIX will be used.
+  !
+  ! NPREF   Input argument of type INTEGER.  This argument is the number
+  !     of characters to use from PREFIX.  If it is negative, the
+  !     intrinsic function LEN is used to determine its length.  If
+  !         it is zero, PREFIX is not used.  If it exceeds 16 or if
+  !     LEN(PREFIX) exceeds 16, only the first 16 characters will be
+  !     used.  If NPREF is positive and the length of PREFIX is less
+  !     than NPREF, a copy of PREFIX extended with blanks to length
+  !     NPREF will be used.
+  !
+  ! MESSG   Input argument of type CHARACTER.  This is the text of a
+  !     message to be printed.  If it is a long message, it will be
+  !     broken into pieces for printing on multiple lines.  Each line
+  !     will start with the appropriate prefix and be followed by a
+  !     piece of the message.  NWRAP is the number of characters per
+  !     piece; that is, after each NWRAP characters, we break and
+  !     start a new line.  In addition the characters '$$' embedded
+  !     in MESSG are a sentinel for a new line.  The counting of
+  !     characters up to NWRAP starts over for each new line.  The
+  !     value of NWRAP typically used by XERMSG is 72 since many
+  !     older error messages in the SLATEC Library are laid out to
+  !     rely on wrap-around every 72 characters.
+  !
+  ! NWRAP   Input argument of type INTEGER.  This gives the maximum size
+  !     piece into which to break MESSG for printing on multiple
+  !     lines.  An embedded '$$' ends a line, and the count restarts
+  !     at the following character.  If a line break does not occur
+  !     on a blank (it would split a word) that word is moved to the
+  !     next line.  Values of NWRAP less than 16 will be treated as
+  !     16.  Values of NWRAP greater than 132 will be treated as 132.
+  !     The actual line length will be NPREF + NWRAP after NPREF has
+  !     been adjusted to fall between 0 and 16 and NWRAP has been
+  !     adjusted to fall between 16 and 132.
+  !
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  I1MACH, XGETUA
+  !***REVISION HISTORY  (YYMMDD)
+  !   880621  DATE WRITTEN
+  !   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
+  !       JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
+  !       THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
+  !       SLASH CHARACTER IN FORMAT STATEMENTS.
+  !   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+  !       STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
+  !       LINES TO BE PRINTED.
+  !   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
+  !       CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
+  !   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
+  !   891214  Prologue converted to Version 4.0 format.  (WRB)
+  !   900510  Added code to break messages between words.  (RWC)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  XERPRN
+  CHARACTER(len=*) :: PREFIX, MESSG
+  INTEGER :: NPREF, NWRAP
+  CHARACTER(len=148) :: CBUFF
+  INTEGER :: IU(5), NUNIT
+  CHARACTER(len=2) :: NEWLIN
+  PARAMETER (NEWLIN = '$$')
+  INTEGER :: N, I1MACH, I, LPREF, LWRAP, LENMSG, NEXTC
+  INTEGER :: LPIECE, IDELTA
+  !***FIRST EXECUTABLE STATEMENT  XERPRN
+  CALL XGETUA(IU,NUNIT)
+  !
+  !   A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
+  !   ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
+  !   ERROR MESSAGE UNIT.
+  !
+  N = I1MACH(4)
+  DO I=1,NUNIT
+     IF (IU(I) == 0) IU(I) = N
+  END DO
+  !
+  !   LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
+  !   BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
+  !   THE REST OF THIS ROUTINE.
+  !
+  IF ( NPREF < 0 ) THEN
+     LPREF = LEN(PREFIX)
+  ELSE
+     LPREF = NPREF
+  ENDIF
+  LPREF = MIN(16, LPREF)
+  IF (LPREF /= 0) CBUFF(1:LPREF) = PREFIX
+  !
+  !   LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
+  !   TIME FROM MESSG TO PRINT ON ONE LINE.
+  !
+  LWRAP = MAX(16, MIN(132, NWRAP))
+  !
+  !   SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
+  !
+  LENMSG = LEN(MESSG)
+  N = LENMSG
+  DO I=1,N
+     IF (MESSG(LENMSG:LENMSG) /= ' ') GO TO 30
+     LENMSG = LENMSG - 1
+  END DO
+   30   CONTINUE
+  !
+  !   IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
+  !
+  IF (LENMSG == 0) THEN
+     CBUFF(LPREF+1:LPREF+1) = ' '
+     DO I=1,NUNIT
+        WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
+  END DO
+     RETURN
+  ENDIF
+  !
+  !   SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
+  !   STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
+  !   WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
+  !   WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
+  !
+  !   WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
+  !   INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
+  !   OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
+  !   OF THE SECOND ARGUMENT.
+  !
+  !   THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
+  !   FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
+  !   OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
+  !   POSITION NEXTC.
+  !
+  !   LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
+  !                   REMAINDER OF THE CHARACTER STRING.  LPIECE
+  !                   SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
+  !                   WHICHEVER IS LESS.
+  !
+  !   LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
+  !                   NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
+  !                   PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
+  !                   BLANK LINES.  THIS TAKES CARE OF THE SITUATION
+  !                   WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
+  !                   EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
+  !                   SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
+  !                   SHOULD BE INCREMENTED BY 2.
+  !
+  !   LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
+  !
+  !   ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
+  !                   RESET LPIECE = LPIECE-1.  NOTE THAT THIS
+  !                   PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
+  !                   LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
+  !                   AT THE END OF A LINE.
+  !
+  NEXTC = 1
+   50   LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
+  IF (LPIECE == 0) THEN
+  !
+  !   THERE WAS NO NEW LINE SENTINEL FOUND.
+  !
+     IDELTA = 0
+     LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
+     IF (LPIECE < LENMSG+1-NEXTC) THEN
+        DO I=LPIECE+1,2,-1
+           IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN
+              LPIECE = I-1
+              IDELTA = 1
+              GOTO 54
+           ENDIF
+  END DO
+     ENDIF
+   54   CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+     NEXTC = NEXTC + LPIECE + IDELTA
+  ELSEIF (LPIECE == 1) THEN
+  !
+  !   WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
+  !   DON'T PRINT A BLANK LINE.
+  !
+     NEXTC = NEXTC + 2
+     GO TO 50
+  ELSEIF (LPIECE > LWRAP+1) THEN
+  !
+  !   LPIECE SHOULD BE SET DOWN TO LWRAP.
+  !
+     IDELTA = 0
+     LPIECE = LWRAP
+     DO I=LPIECE+1,2,-1
+        IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN
+           LPIECE = I-1
+           IDELTA = 1
+           GOTO 58
+        ENDIF
+  END DO
+   58   CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+     NEXTC = NEXTC + LPIECE + IDELTA
+  ELSE
+  !
+  !   IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
+  !   WE SHOULD DECREMENT LPIECE BY ONE.
+  !
+     LPIECE = LPIECE - 1
+     CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+     NEXTC  = NEXTC + LPIECE + 2
+  ENDIF
+  !
+  !   PRINT
+  !
+  DO I=1,NUNIT
+     WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
+  END DO
+  !
+  IF (NEXTC <= LENMSG) GO TO 50
+
+END SUBROUTINE XERPRN
Index: DZ6/branches/Amaury_dev/libf/misc/xersve.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xersve.F	(revision 5104)
+++ 	(revision )
@@ -1,159 +1,0 @@
-*DECK XERSVE
-      SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
-     +   ICOUNT)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  XERSVE
-C***SUBSIDIARY
-C***PURPOSE  Record that an error has occurred.
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3
-C***TYPE      ALL (XERSVE-A)
-C***KEYWORDS  ERROR, XERROR
-C***AUTHOR  Jones, R. E., (SNLA)
-C***DESCRIPTION
-C
-C *Usage:
-C
-C        INTEGER  KFLAG, NERR, LEVEL, ICOUNT
-C        CHARACTER * (len) LIBRAR, SUBROU, MESSG
-C
-C        CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
-C
-C *Arguments:
-C
-C        LIBRAR :IN    is the library that the message is from.
-C        SUBROU :IN    is the SUBROUTINE that the message is from.
-C        MESSG  :IN    is the message to be saved.
-C        KFLAG  :IN    indicates the action to be performed.
-C                      when KFLAG > 0, the message in MESSG is saved.
-C                      when KFLAG=0 the tables will be dumped and
-C                      cleared.
-C                      when KFLAG < 0, the tables will be dumped and
-C                      not cleared.
-C        NERR   :IN    is the error number.
-C        LEVEL  :IN    is the error severity.
-C        ICOUNT :OUT   the number of times this message has been seen,
-C                      or zero if the table has overflowed and does not
-C                      contain this message specifically.  When KFLAG=0,
-C                      ICOUNT will not be altered.
-C
-C *Description:
-C
-C   Record that this error occurred and possibly dump and clear the
-C   tables.
-C
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  I1MACH, XGETUA
-C***REVISION HISTORY  (YYMMDD)
-C   800319  DATE WRITTEN
-C   861211  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   900413  Routine modified to remove reference to KFLAG.  (WRB)
-C   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
-C           sequence, use IF-THEN-ELSE, make number of saved entries
-C           easily changeable, changed routine name from XERSAV to
-C           XERSVE.  (RWC)
-C   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  XERSVE
-      INTEGER,PARAMETER :: LENTAB=10
-      INTEGER LUN(5)
-      CHARACTER*(*) LIBRAR, SUBROU, MESSG
-      CHARACTER*8  LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
-      CHARACTER*20 MESTAB(LENTAB), MES
-      DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
-      SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
-      DATA KOUNTX/0/, NMSG/0/
-      INTEGER NERR,LEVEL,KONTRL
-      INTEGER NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
-      INTEGER KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I1MACH, I
-C***FIRST EXECUTABLE STATEMENT  XERSVE
-C
-      IF (KFLAG<=0) THEN
-C
-C        Dump the table.
-C
-         IF (NMSG==0) RETURN
-C
-C        Print to each unit.
-C
-         CALL XGETUA (LUN, NUNIT)
-         DO KUNIT = 1,NUNIT
-            IUNIT = LUN(KUNIT)
-            IF (IUNIT==0) IUNIT = I1MACH(4)
-C
-C           Print the table header.
-C
-            WRITE (IUNIT,9000)
-C
-C           Print body of table.
-C
-            DO I = 1,NMSG
-               WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
-     *            NERTAB(I),LEVTAB(I),KOUNT(I)
-      END DO
-C
-C           Print number of other errors.
-C
-            IF (KOUNTX/=0) WRITE (IUNIT,9020) KOUNTX
-            WRITE (IUNIT,9030)
-      END DO
-C
-C        Clear the error tables.
-C
-         IF (KFLAG==0) THEN
-            NMSG = 0
-            KOUNTX = 0
-         ENDIF
-      ELSE
-C
-C        PROCESS A MESSAGE...
-C        SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
-C        OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
-C
-         LIB = LIBRAR
-         SUB = SUBROU
-         MES = MESSG
-         DO I = 1,NMSG
-            IF (LIB==LIBTAB(I) .AND. SUB==SUBTAB(I) .AND.
-     *         MES==MESTAB(I) .AND. NERR==NERTAB(I) .AND.
-     *         LEVEL==LEVTAB(I)) THEN
-                  KOUNT(I) = KOUNT(I) + 1
-                  ICOUNT = KOUNT(I)
-                  RETURN
-            ENDIF
-      END DO
-C
-         IF (NMSG<LENTAB) THEN
-C
-C           Empty slot found for new message.
-C
-            NMSG = NMSG + 1
-            LIBTAB(I) = LIB
-            SUBTAB(I) = SUB
-            MESTAB(I) = MES
-            NERTAB(I) = NERR
-            LEVTAB(I) = LEVEL
-            KOUNT (I) = 1
-            ICOUNT    = 1
-         ELSE
-C
-C           Table is full.
-C
-            KOUNTX = KOUNTX+1
-            ICOUNT = 0
-         ENDIF
-      ENDIF
-      RETURN
-C
-C     Formats.
-C
- 9000 FORMAT ('0          ERROR MESSAGE SUMMARY' /
-     +   ' LIBRARY    SUBROUTINE MESSAGE START             NERR',
-     +   '     LEVEL     COUNT')
- 9010 FORMAT (1X,A,3X,A,3X,A,3I10)
- 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
- 9030 FORMAT (1X)
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/xersve.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xersve.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/xersve.f90	(revision 5105)
@@ -0,0 +1,159 @@
+!DECK XERSVE
+SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, &
+        ICOUNT)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  XERSVE
+  !***SUBSIDIARY
+  !***PURPOSE  Record that an error has occurred.
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3
+  !***TYPE      ALL (XERSVE-A)
+  !***KEYWORDS  ERROR, XERROR
+  !***AUTHOR  Jones, R. E., (SNLA)
+  !***DESCRIPTION
+  !
+  ! *Usage:
+  !
+  !    INTEGER  KFLAG, NERR, LEVEL, ICOUNT
+  !    CHARACTER * (len) LIBRAR, SUBROU, MESSG
+  !
+  !    CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
+  !
+  ! *Arguments:
+  !
+  !    LIBRAR :IN    is the library that the message is from.
+  !    SUBROU :IN    is the SUBROUTINE that the message is from.
+  !    MESSG  :IN    is the message to be saved.
+  !    KFLAG  :IN    indicates the action to be performed.
+  !                  when KFLAG > 0, the message in MESSG is saved.
+  !                  when KFLAG=0 the tables will be dumped and
+  !                  cleared.
+  !                  when KFLAG < 0, the tables will be dumped and
+  !                  not cleared.
+  !    NERR   :IN    is the error number.
+  !    LEVEL  :IN    is the error severity.
+  !    ICOUNT :OUT   the number of times this message has been seen,
+  !                  or zero if the table has overflowed and does not
+  !                  contain this message specifically.  When KFLAG=0,
+  !                  ICOUNT will not be altered.
+  !
+  ! *Description:
+  !
+  !   Record that this error occurred and possibly dump and clear the
+  !   tables.
+  !
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  I1MACH, XGETUA
+  !***REVISION HISTORY  (YYMMDD)
+  !   800319  DATE WRITTEN
+  !   861211  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   900413  Routine modified to remove reference to KFLAG.  (WRB)
+  !   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
+  !       sequence, use IF-THEN-ELSE, make number of saved entries
+  !       easily changeable, changed routine name from XERSAV to
+  !       XERSVE.  (RWC)
+  !   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  XERSVE
+  INTEGER,PARAMETER :: LENTAB=10
+  INTEGER :: LUN(5)
+  CHARACTER(len=*) :: LIBRAR, SUBROU, MESSG
+  CHARACTER(len=8) :: LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
+  CHARACTER(len=20) :: MESTAB(LENTAB), MES
+  DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
+  SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
+  DATA KOUNTX/0/, NMSG/0/
+  INTEGER :: NERR,LEVEL,KONTRL
+  INTEGER :: NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
+  INTEGER :: KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I1MACH, I
+  !***FIRST EXECUTABLE STATEMENT  XERSVE
+  !
+  IF (KFLAG<=0) THEN
+  !
+  !    Dump the table.
+  !
+     IF (NMSG==0) RETURN
+  !
+  !    Print to each unit.
+  !
+     CALL XGETUA (LUN, NUNIT)
+     DO KUNIT = 1,NUNIT
+        IUNIT = LUN(KUNIT)
+        IF (IUNIT==0) IUNIT = I1MACH(4)
+  !
+  !       Print the table header.
+  !
+        WRITE (IUNIT,9000)
+  !
+  !       Print body of table.
+  !
+        DO I = 1,NMSG
+           WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), &
+                 NERTAB(I),LEVTAB(I),KOUNT(I)
+  END DO
+  !
+  !       Print number of other errors.
+  !
+        IF (KOUNTX/=0) WRITE (IUNIT,9020) KOUNTX
+        WRITE (IUNIT,9030)
+  END DO
+  !
+  !    Clear the error tables.
+  !
+     IF (KFLAG==0) THEN
+        NMSG = 0
+        KOUNTX = 0
+     ENDIF
+  ELSE
+  !
+  !    PROCESS A MESSAGE...
+  !    SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
+  !    OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
+  !
+     LIB = LIBRAR
+     SUB = SUBROU
+     MES = MESSG
+     DO I = 1,NMSG
+        IF (LIB==LIBTAB(I) .AND. SUB==SUBTAB(I) .AND. &
+              MES==MESTAB(I) .AND. NERR==NERTAB(I) .AND. &
+              LEVEL==LEVTAB(I)) THEN
+              KOUNT(I) = KOUNT(I) + 1
+              ICOUNT = KOUNT(I)
+              RETURN
+        ENDIF
+  END DO
+  !
+     IF (NMSG<LENTAB) THEN
+  !
+  !       Empty slot found for new message.
+  !
+        NMSG = NMSG + 1
+        LIBTAB(I) = LIB
+        SUBTAB(I) = SUB
+        MESTAB(I) = MES
+        NERTAB(I) = NERR
+        LEVTAB(I) = LEVEL
+        KOUNT (I) = 1
+        ICOUNT    = 1
+     ELSE
+  !
+  !       Table is full.
+  !
+        KOUNTX = KOUNTX+1
+        ICOUNT = 0
+     ENDIF
+  ENDIF
+  RETURN
+  !
+  ! Formats.
+  !
+ 9000   FORMAT ('0          ERROR MESSAGE SUMMARY' / &
+              ' LIBRARY    SUBROUTINE MESSAGE START             NERR', &
+              '     LEVEL     COUNT')
+ 9010   FORMAT (1X,A,3X,A,3X,A,3I10)
+ 9020   FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
+ 9030   FORMAT (1X)
+END SUBROUTINE XERSVE
Index: DZ6/branches/Amaury_dev/libf/misc/xgetua.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xgetua.F	(revision 5104)
+++ 	(revision )
@@ -1,53 +1,0 @@
-*DECK XGETUA
-      SUBROUTINE XGETUA (IUNITA, N)
-      IMPLICIT NONE
-C***BEGIN PROLOGUE  XGETUA
-C***PURPOSE  Return unit number(s) to which error messages are being
-C            sent.
-C***LIBRARY   SLATEC (XERROR)
-C***CATEGORY  R3C
-C***TYPE      ALL (XGETUA-A)
-C***KEYWORDS  ERROR, XERROR
-C***AUTHOR  Jones, R. E., (SNLA)
-C***DESCRIPTION
-C
-C     Abstract
-C        XGETUA may be called to determine the unit number or numbers
-C        to which error messages are being sent.
-C        These unit numbers may have been set by a CALL to XSETUN,
-C        or a CALL to XSETUA, or may be a default value.
-C
-C     Description of Parameters
-C      --Output--
-C        IUNIT - an array of one to five unit numbers, depending
-C                on the value of N.  A value of zero refers to the
-C                default unit, as defined by the I1MACH machine
-C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
-C                defined by XGETUA.  The values of IUNIT(N+1),...,
-C                IUNIT(5) are not defined (for N .LT. 5) or altered
-C                in any way by XGETUA.
-C        N     - the number of units to which copies of the
-C                error messages are being sent.  N will be in the
-C                range from 1 to 5.
-C
-C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
-C                 Error-handling Package, SAND82-0800, Sandia
-C                 Laboratories, 1982.
-C***ROUTINES CALLED  J4SAVE
-C***REVISION HISTORY  (YYMMDD)
-C   790801  DATE WRITTEN
-C   861211  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C***END PROLOGUE  XGETUA
-      DIMENSION IUNITA(5)
-      INTEGER IUNITA, N, J4SAVE, INDEX, I
-C***FIRST EXECUTABLE STATEMENT  XGETUA
-      N = J4SAVE(5,0,.FALSE.)
-      DO I=1,N
-         INDEX = I+4
-         IF (I==1) INDEX = 3
-         IUNITA(I) = J4SAVE(INDEX,0,.FALSE.)
-      END DO
-      RETURN
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/misc/xgetua.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/misc/xgetua.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/misc/xgetua.f90	(revision 5105)
@@ -0,0 +1,53 @@
+!DECK XGETUA
+SUBROUTINE XGETUA (IUNITA, N)
+  IMPLICIT NONE
+  !***BEGIN PROLOGUE  XGETUA
+  !***PURPOSE  Return unit number(s) to which error messages are being
+         ! sent.
+  !***LIBRARY   SLATEC (XERROR)
+  !***CATEGORY  R3C
+  !***TYPE      ALL (XGETUA-A)
+  !***KEYWORDS  ERROR, XERROR
+  !***AUTHOR  Jones, R. E., (SNLA)
+  !***DESCRIPTION
+  !
+  ! Abstract
+  !    XGETUA may be called to determine the unit number or numbers
+  !    to which error messages are being sent.
+  !    These unit numbers may have been set by a CALL to XSETUN,
+  !    or a CALL to XSETUA, or may be a default value.
+  !
+  ! Description of Parameters
+  !  --Output--
+  !    IUNIT - an array of one to five unit numbers, depending
+  !            on the value of N.  A value of zero refers to the
+  !            default unit, as defined by the I1MACH machine
+  !            constant routine.  Only IUNIT(1),...,IUNIT(N) are
+  !            defined by XGETUA.  The values of IUNIT(N+1),...,
+  !            IUNIT(5) are not defined (for N .LT. 5) or altered
+  !            in any way by XGETUA.
+  !    N     - the number of units to which copies of the
+  !            error messages are being sent.  N will be in the
+  !            range from 1 to 5.
+  !
+  !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+  !             Error-handling Package, SAND82-0800, Sandia
+  !             Laboratories, 1982.
+  !***ROUTINES CALLED  J4SAVE
+  !***REVISION HISTORY  (YYMMDD)
+  !   790801  DATE WRITTEN
+  !   861211  REVISION DATE from Version 3.2
+  !   891214  Prologue converted to Version 4.0 format.  (BAB)
+  !   920501  Reformatted the REFERENCES section.  (WRB)
+  !***END PROLOGUE  XGETUA
+  DIMENSION IUNITA(5)
+  INTEGER :: IUNITA, N, J4SAVE, INDEX, I
+  !***FIRST EXECUTABLE STATEMENT  XGETUA
+  N = J4SAVE(5,0,.FALSE.)
+  DO I=1,N
+     INDEX = I+4
+     IF (I==1) INDEX = 3
+     IUNITA(I) = J4SAVE(INDEX,0,.FALSE.)
+  END DO
+
+END SUBROUTINE XGETUA
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/aeropt_spl.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/aeropt_spl.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/aeropt_spl.f90	(revision 5105)
@@ -246,4 +246,4 @@
   ! .                                        MAXVAL(taue550_ss)
   !
-  RETURN
+
 END SUBROUTINE aeropt_spl
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/bcscav_spl.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/bcscav_spl.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/bcscav_spl.f90	(revision 5105)
@@ -52,4 +52,4 @@
   ENDDO
   !
-  RETURN
+
 END SUBROUTINE bcscav_spl
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/cltrac_spl.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/cltrac_spl.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/cltrac_spl.f90	(revision 5105)
@@ -134,4 +134,4 @@
   ! print *,'d_tr = ',sum(d_tr),MINVAL(d_tr),MAXVAL(d_tr)
 
-  RETURN
+
 END SUBROUTINE cltrac_spl
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfc.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfc.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfc.f90	(revision 5105)
@@ -117,4 +117,4 @@
   PRINT*, 'Carbon sources lues pour jour: ', jour
 
-  RETURN
+
 END SUBROUTINE condsurfc
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfc_new.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfc_new.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfc_new.f90	(revision 5105)
@@ -205,4 +205,4 @@
   CALL scatter(lmt_omnat_glo, lmt_omnat)
 
-  RETURN
+
 END SUBROUTINE condsurfc_new
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfs.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfs.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfs.f90	(revision 5105)
@@ -235,4 +235,4 @@
   PRINT*, 'Sources SOUFRE lues pour jour: ', jour
 
-  RETURN
+
 END SUBROUTINE condsurfs
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfs_new.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfs_new.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/condsurfs_new.f90	(revision 5105)
@@ -258,4 +258,4 @@
   CALL scatter(lmt_altvolc_expl_glo, lmt_altvolc_expl)
 
-  RETURN
+
 END SUBROUTINE condsurfs_new
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/dustemission_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/dustemission_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/dustemission_mod.F90	(revision 5105)
@@ -978,5 +978,5 @@
 !        END IF
 !        IF(nbins2.EQ.1)THEN
-!           PRINT*,'!! warning: lower limit was found: STOP'
+!           PRINT*,'!! warning: lower limit was found: stop '
 !           STOP
 !        END IF
@@ -1410,5 +1410,5 @@
 !---------------        
 
-      return
+
 END SUBROUTINE def_copyncl
 
@@ -1531,5 +1531,5 @@
        END DO
 !c-----------------
-       RETURN
+
       END SUBROUTINE calcvd
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/gastoparticle.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/gastoparticle.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/gastoparticle.f90	(revision 5105)
@@ -87,4 +87,4 @@
 
   !
-  RETURN
+
 END SUBROUTINE gastoparticle
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/inscav_spl.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/inscav_spl.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/inscav_spl.f90	(revision 5105)
@@ -137,4 +137,4 @@
   ENDDO
   !
-  RETURN
+
 END SUBROUTINE inscav_spl
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/neutral.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/neutral.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/neutral.f90	(revision 5105)
@@ -67,5 +67,5 @@
 
   enddo
-  return
+
 end subroutine neutral
 !***********************************************************************
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/phytracr_spl_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/phytracr_spl_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/phytracr_spl_mod.F90	(revision 5105)
@@ -762,5 +762,5 @@
     param_wstarWAKEperregion(:) = 0.
 
-    RETURN
+
   END SUBROUTINE phytracr_spl_ini
 
@@ -4207,5 +4207,5 @@
     !      CALL abort_gcm('TEST1', 'OK1', 1)
 
-    RETURN
+
   END SUBROUTINE phytracr_spl
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_dust.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_dust.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_dust.f90	(revision 5105)
@@ -72,4 +72,4 @@
   CALL scatter(dust_ec_glo, dust_ec)
 
-  RETURN
+
 END SUBROUTINE read_dust
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_surface.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_surface.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_surface.F90	(revision 5105)
@@ -148,4 +148,4 @@
 
 
-       return
+
        END SUBROUTINE  read_surface
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_vent.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_vent.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_vent.f90	(revision 5105)
@@ -102,5 +102,5 @@
   !   print *,'u v 1 ', u10m_ec(1),v10m_ec(1)
   !   print *,'u v klon ', u10m_ec(klon),v10m_ec(klon)
-  RETURN
+
 END SUBROUTINE read_vent
 
@@ -122,5 +122,5 @@
   enddo
 
-  return
+
 END SUBROUTINE  correctbid
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/satellite_out_spla.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/satellite_out_spla.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/satellite_out_spla.F90	(revision 5105)
@@ -61,5 +61,5 @@
 !  CALL writefield_phy("masque_terra",float(masque_terra),1)
 
-  RETURN
+
 END SUBROUTINE satellite_out_spla
 
@@ -187,5 +187,5 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE swathpolder
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/seasalt.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/seasalt.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/seasalt.f90	(revision 5105)
@@ -49,4 +49,4 @@
   ! print *,'SUM OF WIND = ',wind
   ! print *,'SUM OF OCEAN SURFACE = ',ocean
-  RETURN
+
 END SUBROUTINE seasalt
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/sediment_mod.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/sediment_mod.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/sediment_mod.f90	(revision 5105)
@@ -334,4 +334,4 @@
 
   !
-  RETURN
+
 END SUBROUTINE sediment_mod
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/tiedqneg.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/tiedqneg.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/tiedqneg.f90	(revision 5105)
@@ -62,4 +62,4 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE tiedqneg
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/interp_sulf_input.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/interp_sulf_input.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/interp_sulf_input.F90	(revision 5105)
@@ -353,5 +353,5 @@
   ENDDO
  
-  RETURN
+
 
 END SUBROUTINE interp_sulf_input
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/nucleation_tstep_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/nucleation_tstep_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/nucleation_tstep_mod.F90	(revision 5105)
@@ -289,5 +289,5 @@
    + 0.00879662256826497*t*LOG(rh)) !1/cm3
 
-  RETURN
+
 
 END SUBROUTINE binapara
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/stratH2O_methox.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/stratH2O_methox.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/stratH2O_methox.F90	(revision 5105)
@@ -156,5 +156,5 @@
   ENDIF ! debutphy.OR.new month
   
-  RETURN
+
   
 END SUBROUTINE stratH2O_methox
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/sulfate_aer_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/sulfate_aer_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/StratAer/sulfate_aer_mod.F90	(revision 5105)
@@ -145,5 +145,5 @@
       ENDDO
 
-      RETURN
+
     
   END SUBROUTINE STRACOMP_KELVIN
@@ -717,5 +717,5 @@
     IF(VAL>99.99) VAL=99.99
    
-    RETURN
+
     END SUBROUTINE
 !****************************************************************
@@ -738,5 +738,5 @@
        ENDIF
 
-       RETURN
+
        END SUBROUTINE
 !********************************************************************
@@ -762,5 +762,5 @@
        ENDIF
    
-       RETURN
+
        END SUBROUTINE
 !********************************************************************
@@ -786,5 +786,5 @@
     +b4*(1.+log(tref/T)-tref/T) )   )
 
-       return
+
     end function psh2so4
 !-----------------------------------------------------------------------
@@ -805,5 +805,5 @@
       ndsh2so4_out=presat*10./(akb*T)
 
-       return
+
      end function ndsh2so4
 !-----------------------------------------------------------------------
@@ -832,5 +832,5 @@
 !      PRINT*,psh2o_out
       
-       return
+
      end function psh2o
 !-----------------------------------------------------------------------
@@ -883,5 +883,5 @@
       density_out=(a+b*T+c*T*T) ! units are gm/cm**3
 
-       return
+
      end function density
 !-----------------------------------------------------------------------
@@ -923,5 +923,5 @@
       surftension_out=so4sig*convfac
 
-       return
+
      end function surftension
 !-----------------------------------------------------------------------
@@ -998,5 +998,5 @@
          wph2so4_out = min(wph2so4_out,99.999)
 
-       return
+
      end function wph2so4
 !-----------------------------------------------------------------------
@@ -1020,5 +1020,5 @@
       solh2so4_out=cacta*xa*presat
 
-       return
+
      end function solh2so4
 !-----------------------------------------------------------------------      
@@ -1043,5 +1043,5 @@
         rpmvh2so4_out=rpmvh2so4_out*1000.
         
-       return
+
      end function rpmvh2so4
 !-----------------------------------------------------------------------
@@ -1057,5 +1057,5 @@
        rmvh2o_out=(x1+x2*T+x3*T*T)*1000.
        
-       return
+
      end function rmvh2o
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/aaam_bud.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/aaam_bud.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/aaam_bud.F90	(revision 5105)
@@ -355,4 +355,4 @@
   torsfc = tmou(3) + tsso(3) + tbls(3)
 
-  RETURN
+
 END SUBROUTINE aaam_bud
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/add_phys_tend_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/add_phys_tend_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/add_phys_tend_mod.F90	(revision 5105)
@@ -81,5 +81,5 @@
   ENDIF
 
-  RETURN
+
 END SUBROUTINE add_pbl_tend
 
@@ -485,5 +485,5 @@
   ENDIF ! (mode == 1)
 
-  RETURN
+
 END SUBROUTINE add_phys_tend
 
@@ -648,5 +648,5 @@
   ENDIF ! endif (fl_ebil .GT. 0)
 
-  RETURN
+
 END SUBROUTINE diag_phys_tend
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/aeropt.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/aeropt.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/aeropt.F90	(revision 5105)
@@ -121,4 +121,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE aeropt
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/ajsec.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/ajsec.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/ajsec.F90	(revision 5105)
@@ -151,5 +151,5 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE ajsec
 
@@ -301,5 +301,5 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE ajsec_convv2
 SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
@@ -394,4 +394,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE ajsec_old
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/albedo.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/albedo.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/albedo.F90	(revision 5105)
@@ -118,5 +118,5 @@
        END DO
     END IF
-    RETURN
+
   END SUBROUTINE alboc
   ! =====================================================================
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_th.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_th.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_th.F90	(revision 5105)
@@ -334,5 +334,5 @@
                 endif
              enddo
-!    print *,'In order to run with iflag_coupl=2, you have to comment out the following stop'
+!    print *,'In order to run with iflag_coupl=2, you have to comment out the following stop '
 !             STOP
              abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort'
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_wk.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_wk.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_wk.F90	(revision 5105)
@@ -80,5 +80,5 @@
 !!                        wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1)
 
-   RETURN
+
    END SUBROUTINE alpale_wk
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/calwake.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/calwake.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/calwake.F90	(revision 5105)
@@ -327,5 +327,5 @@
   ENDIF
 
-  RETURN
+
 END SUBROUTINE calwake
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cfmip_point_locations.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cfmip_point_locations.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cfmip_point_locations.F90	(revision 5105)
@@ -11,5 +11,4 @@
 
   WRITE(*,*) 'npCFMIP=',npCFMIP
-! OPEN(20, file="pointlocations.txt",status='old')
   OPEN(20, file="pointlocations.txt",status='old',err=999)
   OPEN(21, file="pointlocations_lon180.txt")
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/clc_core_cp.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/clc_core_cp.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/clc_core_cp.F90	(revision 5105)
@@ -229,4 +229,4 @@
   rugosh =  z_0h
 
-      RETURN
+
       END SUBROUTINE clc_core_cp
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/clift.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/clift.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/clift.F90	(revision 5105)
@@ -71,4 +71,4 @@
 
 
-  RETURN
+
 END SUBROUTINE clift
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/clouds_bigauss.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/clouds_bigauss.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/clouds_bigauss.F90	(revision 5105)
@@ -113,5 +113,5 @@
   END DO  ! K
 
-  RETURN
+
   END SUBROUTINE clouds_bigauss
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/clouds_gno.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/clouds_gno.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/clouds_gno.F90	(revision 5105)
@@ -255,5 +255,5 @@
   END DO
   ! K
-  RETURN
+
 END SUBROUTINE clouds_gno
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/coefcdrag.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/coefcdrag.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/coefcdrag.F90	(revision 5105)
@@ -159,4 +159,4 @@
 
       END DO
-      RETURN 
+
       END SUBROUTINE coefcdrag
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/coefkzmin.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/coefkzmin.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/coefkzmin.F90	(revision 5105)
@@ -129,4 +129,4 @@
 
 
-  RETURN
+
 END SUBROUTINE coefkzmin
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/conccm.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/conccm.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/conccm.F90	(revision 5105)
@@ -134,5 +134,5 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE conccm
 SUBROUTINE cmfmca(deltat, p, dp, gz, tb, shb, cmfprt, cmfprs, cnt, cnb)
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/concvl.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/concvl.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/concvl.F90	(revision 5105)
@@ -586,5 +586,5 @@
   END IF !(prt_level.EQ.20) THEN
 
-  RETURN
+
 END SUBROUTINE concvl
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/condsurf.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/condsurf.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/condsurf.F90	(revision 5105)
@@ -129,4 +129,4 @@
   ! PRINT*, 'lmt_bils est lu pour jour: ', jour
 
-  RETURN
+
 END SUBROUTINE condsurf
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/conema3.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/conema3.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/conema3.F90	(revision 5105)
@@ -408,5 +408,5 @@
 
 
-  RETURN
+
 END SUBROUTINE conema3
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/conemav.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/conemav.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/conemav.F90	(revision 5105)
@@ -142,5 +142,5 @@
 
 
-  RETURN
+
 END SUBROUTINE conemav
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/conf_phys_m.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/conf_phys_m.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/conf_phys_m.F90	(revision 5105)
@@ -2874,5 +2874,5 @@
   !$OMP END MASTER
 
-  RETURN
+
 
 END SUBROUTINE conf_interface
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/conflx.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/conflx.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/conflx.F90	(revision 5105)
@@ -198,5 +198,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE conflx
 ! --------------------------------------------------------------------
@@ -473,5 +473,5 @@
 
 1000 CONTINUE
-  RETURN
+
 END SUBROUTINE flxmain
 SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh, pqenh, pqsenh, &
@@ -596,5 +596,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE flxini
 SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, ptu, pqu, plu, ldcum, kcbot, &
@@ -676,5 +676,5 @@
 290 END DO
 
-  RETURN
+
 END SUBROUTINE flxbase
 SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen, pgeo, pgeoh, pap, &
@@ -975,5 +975,5 @@
 
 800 CONTINUE
-  RETURN
+
 END SUBROUTINE flxasc
 SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap, paph, ldland, &
@@ -1221,5 +1221,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE flxflux
 SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten, pmfus, pmfds, pmfuq, &
@@ -1283,5 +1283,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE flxdtdq
 SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
@@ -1390,5 +1390,5 @@
 290 END DO
 
-  RETURN
+
 END SUBROUTINE flxdlfs
 SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, ptd, pqd, pmfd, pmfds, &
@@ -1504,5 +1504,5 @@
 
 180 END DO
-  RETURN
+
 END SUBROUTINE flxddraf
 SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
@@ -1579,5 +1579,5 @@
 
 230 CONTINUE
-  RETURN
+
 END SUBROUTINE flxadjtq
 SUBROUTINE flxsetup
@@ -1605,4 +1605,4 @@
   lmfdudv = .TRUE.
 
-  RETURN
+
 END SUBROUTINE flxsetup
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/conlmd.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/conlmd.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/conlmd.F90	(revision 5105)
@@ -86,5 +86,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE conlmd
 SUBROUTINE conman(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, &
@@ -293,5 +293,5 @@
   ncpt = ncpt + 1
 
-  RETURN
+
 END SUBROUTINE conman
 SUBROUTINE conmanv(dtime, paprs, pplay, t, q, afaire, opt_cld, d_t, d_q, &
@@ -1041,5 +1041,5 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE conmanv
 SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
@@ -1550,5 +1550,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE conkuo
 SUBROUTINE kuofcl(pt, pq, pg, pp, ldcum, kcbot)
@@ -1650,5 +1650,5 @@
 290 END DO
 
-  RETURN
+
 END SUBROUTINE kuofcl
 SUBROUTINE adjtq(pp, pt, pq, ldflag, kcall)
@@ -1756,5 +1756,5 @@
 
 230 CONTINUE
-  RETURN
+
 END SUBROUTINE adjtq
 SUBROUTINE fiajh(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, &
@@ -2041,5 +2041,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE fiajh
 SUBROUTINE fiajc(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
@@ -2247,4 +2247,4 @@
   END IF ! fin de teste sur vector
 
-  RETURN
+
 END SUBROUTINE fiajc
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/convect1.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/convect1.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/convect1.F90	(revision 5105)
@@ -638,4 +638,4 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE convect1
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/convect2.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/convect2.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/convect2.F90	(revision 5105)
@@ -1369,5 +1369,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE convect2
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/convect3.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/convect3.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/convect3.F90	(revision 5105)
@@ -1403,5 +1403,5 @@
 
 
-  RETURN
+
 END SUBROUTINE convect3
 ! ---------------------------------------------------------------------------
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv30_routines.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv30_routines.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv30_routines.F90	(revision 5105)
@@ -80,5 +80,5 @@
   betad = 10.0 ! original value (from convect 4.3)
 
-  RETURN
+
 END SUBROUTINE cv30_param
 
@@ -155,5 +155,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_prelim
 
@@ -338,5 +338,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_feed
 
@@ -620,5 +620,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_undilute1
 
@@ -724,5 +724,5 @@
   ! fin oct3 --
 
-  RETURN
+
 END SUBROUTINE cv30_trigger
 
@@ -832,5 +832,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_compress
 
@@ -1207,5 +1207,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_undilute2
 
@@ -1412,5 +1412,5 @@
   ! !      sig(icb-1)=sig(icb)
 
-  RETURN
+
 END SUBROUTINE cv30_closure
 
@@ -1808,5 +1808,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_mixing
 
@@ -2174,5 +2174,5 @@
 400 END DO
 
-  RETURN
+
 END SUBROUTINE cv30_unsat
 
@@ -3026,5 +3026,5 @@
   END DO ! cld
 
-  RETURN
+
 END SUBROUTINE cv30_yield
 
@@ -3138,5 +3138,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_tracer
 ! RomP <<<
@@ -3268,5 +3268,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_uncompress
 
@@ -3355,5 +3355,5 @@
       endif !if (coef_epmax_cape.gt.1e-12) then
 
-      return
+
       END SUBROUTINE  cv30_epmax_fn_cape
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_buoy.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_buoy.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_buoy.F90	(revision 5105)
@@ -152,4 +152,4 @@
   ENDIF
 
-  RETURN
+
 END SUBROUTINE cv3_buoy
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_cine.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_cine.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_cine.F90	(revision 5105)
@@ -458,4 +458,4 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_cine
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_crit.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_crit.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_crit.F90	(revision 5105)
@@ -56,4 +56,4 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_crit
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_enthalpmix.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_enthalpmix.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_enthalpmix.F90	(revision 5105)
@@ -211,5 +211,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_enthalpmix
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_estatmix.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_estatmix.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_estatmix.F90	(revision 5105)
@@ -194,5 +194,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_estatmix
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_inicp.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_inicp.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_inicp.F90	(revision 5105)
@@ -115,4 +115,4 @@
   END IF !  (iflag_mix .gt. 0)
 
-  RETURN
+
 END SUBROUTINE cv3_inicp
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_inip.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_inip.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_inip.F90	(revision 5105)
@@ -143,4 +143,4 @@
   END IF !  (iflag_mix .gt. 0)
 
-  RETURN
+
 END SUBROUTINE cv3_inip
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_mixscale.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_mixscale.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_mixscale.F90	(revision 5105)
@@ -31,4 +31,4 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_mixscale
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_routines.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_routines.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3_routines.F90	(revision 5105)
@@ -105,7 +105,7 @@
      CALL getin_p('wbmax',wbmax)
      ok_convstop=.False.
-     CALL getin_p('ok_convstop',ok_convstop)
+     CALL getin_p('ok_convstop ',ok_convstop)
      tau_stop=15000.
-     CALL getin_p('tau_stop',tau_stop)
+     CALL getin_p('tau_stop ',tau_stop)
      ok_intermittent=.False.
      CALL getin_p('ok_intermittent',ok_intermittent)
@@ -178,5 +178,5 @@
   noconv_stop = max(2.,tau_stop/delt)
 
-  RETURN
+
 END SUBROUTINE cv3_param
 
@@ -218,5 +218,5 @@
 !    print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd)
 
-  RETURN
+
 END SUBROUTINE cv3_incrcount
 
@@ -300,5 +300,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_prelim
 
@@ -598,5 +598,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_feed
 
@@ -874,5 +874,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_undilute1
 
@@ -977,5 +977,5 @@
 ! fin oct3 --
 
-  RETURN
+
 END SUBROUTINE cv3_trigger
 
@@ -1093,5 +1093,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_compress
 
@@ -1125,5 +1125,5 @@
   END DO
 
-  RETURN
+
 
 END SUBROUTINE icefrac
@@ -2038,5 +2038,5 @@
   END IF  ! (cvflag_ice)
 
-  RETURN
+
 END SUBROUTINE cv3_undilute2
 
@@ -2279,5 +2279,5 @@
 !!      sig(icb-1)=sig(icb)
 
-  RETURN
+
 END SUBROUTINE cv3_closure
 
@@ -2698,5 +2698,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_mixing
 
@@ -3429,5 +3429,5 @@
 
 
-  RETURN
+
 
 END SUBROUTINE cv3_unsat
@@ -4936,5 +4936,5 @@
 ! PRINT*,'cv3_yield fin'
 
-  RETURN
+
 END SUBROUTINE cv3_yield
 
@@ -5036,5 +5036,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_tracer
 !AC! et !RomP <<<
@@ -5122,5 +5122,5 @@
 !AC! 2100   continue
 
-  RETURN
+
 END SUBROUTINE cv3_uncompress
 
@@ -5265,5 +5265,5 @@
       !write(*,*) 'cv3_routines check 4367'
 
-      return
+
       END SUBROUTINE  cv3_epmax_fn_cape
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_compress.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_compress.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_compress.F90	(revision 5105)
@@ -246,4 +246,4 @@
 !>jyg
 
-  RETURN
+
 END SUBROUTINE cv3a_compress
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_uncompress.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_uncompress.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_uncompress.F90	(revision 5105)
@@ -334,5 +334,5 @@
 !>jyg
 
-  RETURN
+
 END SUBROUTINE cv3a_uncompress
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p1_closure.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p1_closure.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p1_closure.F90	(revision 5105)
@@ -768,5 +768,5 @@
 
   IF (prt_level>=20) PRINT *, 'cv3p1_param FIN'
-  RETURN
+
 END SUBROUTINE cv3p1_closure
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p2_closure.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p2_closure.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p2_closure.F90	(revision 5105)
@@ -862,5 +862,5 @@
 
   IF (prt_level>=20) PRINT *, 'cv3p2_closure FIN'
-  RETURN
+
 END SUBROUTINE cv3p2_closure
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p_mixing.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p_mixing.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv3p_mixing.F90	(revision 5105)
@@ -697,5 +697,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3p_mixing
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv_driver.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv_driver.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv_driver.F90	(revision 5105)
@@ -676,5 +676,5 @@
 
   ! print *, 'fin cv_driver ->'      !jyg
-  RETURN
+
 END SUBROUTINE cv_driver
 
@@ -710,5 +710,5 @@
   CALL getin_p('icvflag_Tpa', icvflag_Tpa)
 
-  RETURN
+
 END SUBROUTINE cv_flag
 
@@ -771,4 +771,4 @@
   hrd = 0.5*rrd
 
-  RETURN
+
 END SUBROUTINE cv_thermo
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cv_routines.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cv_routines.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cv_routines.F90	(revision 5105)
@@ -71,5 +71,5 @@
   delta = 0.01 ! cld
 
-  RETURN
+
 END SUBROUTINE cv_param
 
@@ -128,5 +128,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_prelim
 
@@ -249,5 +249,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_feed
 
@@ -359,5 +359,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_undilute1
 
@@ -389,5 +389,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_trigger
 
@@ -476,5 +476,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_compress
 
@@ -759,5 +759,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_undilute2
 
@@ -841,5 +841,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_closure
 
@@ -1093,5 +1093,5 @@
 789 END DO
 
-  RETURN
+
 END SUBROUTINE cv_mixing
 
@@ -1294,5 +1294,5 @@
 899 END DO
 
-  RETURN
+
 END SUBROUTINE cv_unsat
 
@@ -1663,5 +1663,5 @@
   END DO ! cld
 
-  RETURN
+
 END SUBROUTINE cv_yield
 
@@ -1709,5 +1709,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_uncompress
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/cva_driver.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/cva_driver.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/cva_driver.F90	(revision 5105)
@@ -1281,4 +1281,4 @@
 
 
-  RETURN
+
 END SUBROUTINE cva_driver
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/diagphy.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/diagphy.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/diagphy.F90	(revision 5105)
@@ -399,4 +399,4 @@
   ec_pre(idiag) = ec_tot
 
-  RETURN
+
 END SUBROUTINE diagetpq
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90	(revision 5105)
@@ -978,5 +978,5 @@
     ENDDO
 
-    RETURN
+
   END SUBROUTINE dyn1dredem
 
@@ -1017,5 +1017,5 @@
     ENDDO
 
-    RETURN
+
   END SUBROUTINE gr_fi_dyn
 
@@ -1470,5 +1470,5 @@
     print *, 'rh_targ', rh_targ
 
-    RETURN
+
   END SUBROUTINE nudge_rht_init
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_amma_read.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_amma_read.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_amma_read.F90	(revision 5105)
@@ -341,5 +341,5 @@
 !          write(*,*)'lecture pp ok',pp
 
-         return 
+
          END SUBROUTINE  read_amma
 !======================================================================
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read.F90	(revision 5105)
@@ -799,5 +799,5 @@
 
 
-         return
+
          END SUBROUTINE  read_cas
 !======================================================================
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read2.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read2.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read2.F90	(revision 5105)
@@ -639,5 +639,5 @@
   enddo
 
-  return 
+
 END SUBROUTINE  read_cas2
 !======================================================================
@@ -807,5 +807,5 @@
 
 
-  return 
+
 END SUBROUTINE  read2_cas
 
@@ -1016,5 +1016,5 @@
   !-----------------------------------------------------------------------
 
-  return 
+
 END SUBROUTINE  old_read_SCM
 !======================================================================
@@ -1221,5 +1221,5 @@
   enddo
 
-  return
+
 END SUBROUTINE interp_case_time2
 
@@ -1458,5 +1458,5 @@
   enddo
 
-  return
+
 END SUBROUTINE interp2_case_time
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read_std.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read_std.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/mod_1D_cases_read_std.F90	(revision 5105)
@@ -619,5 +619,5 @@
     !-----------------------------------------------------------------------
 
-    return 
+
   END SUBROUTINE read_SCM
   !======================================================================
@@ -904,5 +904,5 @@
     enddo
 
-    return
+
   END SUBROUTINE interp_case_time_std
 
@@ -1207,5 +1207,5 @@
 
 
-    return
+
   END SUBROUTINE  interp2_case_vertical_std
   !***************************************************************************** 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/old_1DUTILS_read_interp.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/old_1DUTILS_read_interp.h	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/old_1DUTILS_read_interp.h	(revision 5105)
@@ -487,5 +487,5 @@
 !         write(*,*)'lecture T_srf ok', T_srf
 
-         return 
+
          end subroutine read_twpice
 !=====================================================================
@@ -2370,5 +2370,5 @@
 !          write(*,*)'lecture thl_rad ok',thl_rad
 
-         return 
+
          end subroutine read_fire
 !=====================================================================
@@ -2706,5 +2706,5 @@
 !          write(*,*)'lecture omega ok',omega
 
-         return 
+
          end subroutine read_dice
 !=====================================================================
@@ -2949,5 +2949,5 @@
            hadvq(k,:)=hadvq_i(nlevel+1-k,:)
          enddo
-         return 
+
  end subroutine read_gabls4
 !=====================================================================
@@ -3055,5 +3055,5 @@
       close(16)
  
-      return 
+
       end subroutine read_circ
 !=====================================================================
@@ -3092,5 +3092,5 @@
       close(12)
  
-      return 
+
       end subroutine read_rtmip
 !=====================================================================
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/fisrtilp_tr.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/fisrtilp_tr.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/fisrtilp_tr.F90	(revision 5105)
@@ -426,4 +426,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE fisrtilp_tr
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/flxtr.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/flxtr.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/flxtr.F90	(revision 5105)
@@ -199,4 +199,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE flxtr
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/freinage.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/freinage.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/freinage.F90	(revision 5105)
@@ -129,5 +129,5 @@
         d_v(1:knon,k) =(-1)*drag_pro(1:knon,k)*vv(1:knon,k)*wind(1:knon,k)
       enddo
-      return
+
 
  END SUBROUTINE freinage
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/haut2bas.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/haut2bas.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/haut2bas.F90	(revision 5105)
@@ -16,4 +16,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE haut2bas
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/hbtm2l.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/hbtm2l.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/hbtm2l.F90	(revision 5105)
@@ -697,4 +697,4 @@
   END DO ! end of level loop
   ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ end k loop
-  RETURN
+
 END SUBROUTINE hbtm2l
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/hines_gwd.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/hines_gwd.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/hines_gwd.F90	(revision 5105)
@@ -447,5 +447,5 @@
 
 
-  RETURN
+
 END SUBROUTINE hines_gwd
 ! /
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/histo_o500_pctau.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/histo_o500_pctau.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/histo_o500_pctau.F90	(revision 5105)
@@ -62,4 +62,4 @@
   END DO !nreg
 
-  RETURN
+
 END SUBROUTINE histo_o500_pctau
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/homogene.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/homogene.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/homogene.F90	(revision 5105)
@@ -95,4 +95,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE homogene
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/hydrol.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/hydrol.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/hydrol.F90	(revision 5105)
@@ -115,4 +115,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE hydrol
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/ice_sursat_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/ice_sursat_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/ice_sursat_mod.F90	(revision 5105)
@@ -281,5 +281,5 @@
   ENDDO
   
-  RETURN
+
 END SUBROUTINE flight_init
 
@@ -898,5 +898,5 @@
      ENDIF !-- Gcontr > 0.1
 
-  RETURN
+
 END SUBROUTINE ice_sursat
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/icefrac_lsc_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/icefrac_lsc_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/icefrac_lsc_mod.F90	(revision 5105)
@@ -51,5 +51,5 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE icefrac_lsc
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/ini_undefSTD.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/ini_undefSTD.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/ini_undefSTD.F90	(revision 5105)
@@ -82,4 +82,4 @@
     END IF !
   END DO !n
-  RETURN
+
 END SUBROUTINE ini_undefstd
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/ini_wake.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/ini_wake.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/ini_wake.F90	(revision 5105)
@@ -85,4 +85,4 @@
   PRINT *, 'Initialisation de la BL: ALP, ALE imposees =', alp_bl_prescr, &
     ale_bl_prescr
-  RETURN
+
 END SUBROUTINE ini_wake
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/iniorbit.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/iniorbit.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/iniorbit.F90	(revision 5105)
@@ -100,4 +100,4 @@
   PRINT *, 'longitude solaire du perihelie timeperi = ', timeperi
 
-  RETURN
+
 END SUBROUTINE iniorbit
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/iniradia.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/iniradia.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/iniradia.F90	(revision 5105)
@@ -35,4 +35,4 @@
 #endif
 
-  RETURN
+
 END SUBROUTINE iniradia
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/inlandsis.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/inlandsis.F	(revision 5104)
+++ 	(revision )
@@ -1,1510 +1,0 @@
-      SUBROUTINE INLANDSIS(SnoMod,BloMod,jjtime,debut)
-
-      USE dimphy
-
-!--------------------------------------------------------------------------+
-!     INLANDSIS module                                                     |
-!     Simplified SISVAT module, containing ice and snow processes for      |
-!     ice-covered surfaces                                                 |
-!     version MARv3, november 2020                                         |
-!     SubRoutine INLANDSIS contains the fortran 77 code of the             |
-!                Soil/Ice Snow Vegetation Atmosphere Transfer Scheme       |
-!                                                                          |
-!--------------------------------------------------------------------------+
-!     PARAMETERS:  klonv: Total Number of columns =                        |
-!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-!                       X       Number of Mosaic Cell per grid box         |
-!                                                                          |
-!     INPUT:   daHost   : Date Host Model                                  |
-!     ^^^^^                                                                |
-!                                                                          |
-!     INPUT:   LSmask   : 1:          Land       MASK                      |
-!     ^^^^^               0:          Sea        MASK                      |
-!              isotSV   = 0,...,12:   Soil       Type                      |
-!                         0:          Water,          Liquid (Sea, Lake)   |
-!                        12:          Water, Solid           (Ice)         |
-!                                                                          |
-!     INPUT:   coszSV   : Cosine of the Sun Zenithal Distance          [-] |
-!     ^^^^^    sol_SV   : Surface Downward  Solar      Radiation    [W/m2] |
-!              IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
-!              drr_SV   : Rain  Intensity                        [kg/m2/s] |
-!              dsn_SV   : Snow  Intensity                      [mm w.e./s] |
-!              dsnbSV   : Snow  Intensity,  Drift Fraction             [-] |
-!              dbs_SV   : Drift Amount                           [mm w.e.] |
-!              za__SV   : Surface Boundary Layer (SBL) Height          [m] |
-!              VV__SV   :(SBL Top)   Wind Velocity                   [m/s] |
-!              TaT_SV   : SBL Top    Temperature                       [K] |
-!              rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
-!              QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
-!              qsnoSV   : SBL Mean   Snow      Content             [kg/kg] |
-!              alb0SV   : Soil Basic Albedo                            [-] |
-!              slopSV   : Surface    Slope                             [-] |
-!              dt__SV   : Time  Step                                   [s] |
-!                                                                          |
-!     INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
-!     OUTPUT:  ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
-!     ^^^^^^   iiceSV   = total Nb of Ice      Layers                      |
-!              istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
-!                                                                          |
-!     INPUT /  alb_SV   : Surface        Albedo                        [-] |
-!     OUTPUT:  emi_SV   : Surface        Emissivity                    [-] |
-!     ^^^^^^   IRs_SV   : Soil           IR Flux  (negative)        [W/m2] |
-!              LMO_SV   : Monin-Obukhov               Scale            [m] |
-!              us__SV   : Friction          Velocity                 [m/s] |
-!              uts_SV   : Temperature       Turbulent Scale          [m/s] |
-!              uqs_SV   : Specific Humidity Velocity                 [m/s] |
-!              uss_SV   : Blowing Snow      Turbulent Scale          [m/s] |
-!              usthSV   : Blowing Snow      Erosion   Threshold      [m/s] |
-!              Z0m_SV   : Momentum     Roughness Length                [m] |
-!              Z0mmSV   : Momentum     Roughness Length (time mean)    [m] |
-!              Z0mnSV   : Momentum     Roughness Length (instantaneous)[m] |
-!              Z0SaSV   : Sastrugi     Roughness Length                [m] |
-!              Z0e_SV   : Erosion Snow Roughness Length                [m] |
-!              Z0emSV   : Erosion Snow Roughness Length (time mean)    [m] |
-!              Z0enSV   : Erosion Snow Roughness Length (instantaneous)[m] |
-!              Z0roSV   : Subgrid Topo Roughness Length                [m] |
-!              Z0h_SV   : Heat         Roughness Length                [m] |
-!              TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
-!                       & Snow     Temperatures (layers  1,2,...,nsno) [K] |
-!              ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
-!              eta_SV   : Soil/Snow Water   Content                [m3/m3] |
-!              G1snSV   : snow dendricity/sphericity                       |
-!              G2snSV   : snow sphericity/grain size                       |
-!              dzsnSV   : Snow Layer        Thickness                  [m] |
-!              agsnSV   : Snow       Age                             [day] |
-!              BufsSV   : Snow Buffer Layer              [kg/m2] .OR. [mm] |
-!              BrosSV   : Snow Buffer Layer Density      [kg/m3]           |
-!              BG1sSV   : Snow Buffer Layer Dendricity / Sphericity    [-] |
-!              BG2sSV   : Snow Buffer Layer Sphericity / Size [-] [0.1 mm] |
-!              rusnSV   : Surficial   Water              [kg/m2] .OR. [mm] |
-!                                                                          |
-!     OUTPUT:  no__SV   : OUTPUT file Unit Number                      [-] |
-!     ^^^^^^   i___SV   : OUTPUT point   i Coordinate                  [-] |
-!              j___SV   : OUTPUT point   j Coordinate                  [-] |
-!              n___SV   : OUTPUT point   n Coordinate                  [-] |
-!              lwriSV   : OUTPUT point vec Index                       [-] |
-!                                                                          |
-!     OUTPUT:  IRu_SV   : Upward     IR Flux (+, upw., effective)      [K] |
-!     ^^^^^^   hSalSV   : Saltating Layer Height                       [m] |
-!              qSalSV   : Saltating Snow  Concentration            [kg/kg] |
-!              RnofSV   : RunOFF Intensity                       [kg/m2/s] |
-!                                                                          |
-!     Internal Variables:                                                  |
-!     ^^^^^^^^^^^^^^^^^^                                                   |
-!              NLaysv   = New            Snow Layer Switch             [-] |
-!              albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
-!              SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
-!              TBr_sv   : Brightness Temperature                       [K] |
-!              IRupsv   : Upward     IR Flux (-, upw.)              [W/m2] |
-!              ram_sv   : Aerodynamic Resistance for Momentum        [s/m] |
-!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
-!              Evp_sv   : Evaporation                              [kg/m2] |
-!              EvT_sv   : Evapotranspiration                       [kg/m2] |
-!              HSs_sv   : Surface    Sensible Heat Flux + => absorb.[W/m2] |
-!              HLs_sv   : Surface    Latent   Heat Flux + => absorb.[W/m2] |
-!              Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
-!              Tsrfsv   : Surface    Temperature                       [K] |
-!              sEX_sv   : Verticaly Integrated Extinction Coefficient  [-] |
-!              LSdzsv   : Vertical   Discretization Factor             [-] |
-!                       =    1. Soil                                       |
-!                       = 1000. Ocean                                      |
-!              z_snsv   : Snow Pack  Thickness                         [m] |
-!              zzsnsv   : Snow Pack  Thickness                         [m] |
-!              albssv   : Soil       Albedo                            [-] |
-!              Eso_sv   : Soil+Snow       Emissivity                   [-] |
-!              Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
-!                                                                          |
-!              ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
-!              ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
-!              ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
-!              EqSn_0   : Snow      Energy, before Phase Change     [J/m2] |
-!              EqSn_1   : Snow      Energy, after  Phase Change     [J/m2] |
-!              EqSn_d   : Snow      Energy,       net    Forcing    [J/m2] |
-!              Enrsvd   : SVAT      Energy Power         Forcing    [W/m2] |
-!              Enrbal   : SVAT      Energy Balance                  [W/m2] |
-!              Wats_0   : Soil Water,  before Forcing                 [mm] |
-!              Wats_1   : Soil Water,  after  Forcing                 [mm] |
-!              Wats_d   : Soil Water          Forcing                 [mm] |
-!              SIWm_0   : Snow        initial Mass               [mm w.e.] |
-!              SIWm_1   : Snow        final   Mass               [mm w.e.] |
-!              SIWa_i   : Snow Atmos. initial Forcing            [mm w.e.] |
-!              SIWa_f   : Snow Atmos. final   Forcing(noConsumed)[mm w.e.] |
-!              SIWe_i   : SnowErosion initial Forcing            [mm w.e.] |
-!              SIWe_f   : SnowErosion final   Forcing(noConsumed)[mm w.e.] |
-!              SIsubl   : Snow sublimed/deposed  Mass            [mm w.e.] |
-!              SImelt   : Snow Melted            Mass            [mm w.e.] |
-!              SIrnof   : Surficial Water + Run OFF Change       [mm w.e.] |
-!              SIvAcr   : Sea-Ice    vertical Acretion           [mm w.e.] |
-!              Watsvd   : SVAT Water          Forcing                 [mm] |
-!              Watbal   : SVAT Water  Balance                       [W/m2] |
-!                                                                          |
-!              vk2      : Square of Von Karman Constant                [-] |
-!              sqrCm0   : Factor of   Neutral Drag Coeffic.Momentum  [s/m] |
-!              sqrCh0   : Factor of   Neutral Drag Coeffic.Heat      [s/m] |
-!              EmiSol   : Soil          Emissivity                     [-] |
-!              EmiSno   : Snow          Emissivity                     [-] |
-!              EmiWat   : Water         Emissivity                     [-] |
-!              Z0mLnd   :          Land Roughness Length               [m] |
-!              sqrrZ0   : u*t/u*                                           |
-!              f_eff    : Marticorena & B. 1995 JGR (20)                   |
-!              A_Fact   : Fundamental * Roughness                          |
-!              Z0mBSn   :         BSnow Roughness Length               [m] |
-!              Z0mBS0   : Mimimum BSnow Roughness Length (blown* )     [m] |
-!              Z0m_Sn   :          Snow Roughness Length (surface)     [m] |
-!              Z0m_S0   : Mimimum  Snow Roughness Length               [m] |
-!              Z0m_S1   : Maximum  Snow Roughness Length               [m] |
-!              Z0_GIM   : Minimum GIMEX Roughness Length               [m] |
-!              Z0_ICE   : Sea Ice ISW   Roughness Length               [m] |
-!                                                                          |
-!                                                                          |
-!--------------------------------------------------------------------------+
-     
-
-
-! Global Variables
-! ================
-
-
-      USE VARphy
-      USE VAR_SV
-      USE VARdSV
-      USE VAR0SV
-      USE VARxSV
-      USE VARySV
-      USE VARtSV
-      USE surface_data, ONLY: is_ok_z0h_rn,
-     .                        is_ok_density_kotlyakov,
-     .                        prescribed_z0m_snow,
-     .                        iflag_z0m_snow,
-     .                        iflag_tsurf_inlandsis,
-     .                        iflag_temp_inlandsis,
-     .                        discret_xf, buf_sph_pol,buf_siz_pol      
-
-      IMPLICIT NONE
-
-      logical   SnoMod
-      logical   BloMod
-      logical   debut
-      integer   jjtime
-
-
-! Internal Variables
-! ==================
-
-! Non Local
-! ---------
-
-      real      TBr_sv(klonv)                 ! Brightness Temperature
-      real      IRdwsv(klonv)                 ! DOWNward   IR Flux
-      real      IRupsv(klonv)                 ! UPward     IR Flux
-      real      d_Bufs,Bufs_N                 ! Buffer Snow Layer Increment
-      real      Buf_ro,Bros_N                 ! Buffer Snow Layer Density
-      real      BufPro                        ! Buffer Snow Layer Density
-      real      Buf_G1,BG1__N                 ! Buffer Snow Layer Dendr/Sphe[-]
-      real      Buf_G2,BG2__N                 ! Buffer Snow Layer Spher/Size[-]
-      real      Bdzssv(klonv)                 ! Buffer Snow Layer Thickness
-      real      z_snsv(klonv)                 ! Snow-Ice, current Thickness
-
-
-
-! Local
-! -----
-
-      integer   iwr
-      integer   ikl   ,isn   ,isl   ,ist      !
-      integer   ist__s,ist__w                 ! Soil/Water Body Identifier
-      integer   growth                        ! Seasonal               Mask
-      integer   LISmsk                        ! Land+Ice / Open    Sea Mask
-      integer   LSnMsk                        ! Snow-Ice / No Snow-Ice Mask
-      integer   IceMsk,IcIndx(klonv)          !      Ice / No      Ice Mask
-      integer   SnoMsk                        ! Snow     / No Snow     Mask
-      real      roSMin,roSMax,roSn_1,roSn_2,roSn_3   ! Fallen Snow Density (PAHAUT)
-      real      Dendr1,Dendr2,Dendr3          ! Fallen Snow Dendric.(GIRAUD)
-      real      Spher1,Spher2,Spher3,Spher4   ! Fallen Snow Spheric.(GIRAUD)
-      real      Polair                        ! Polar  Snow Switch
-      real      PorSno,Salt_f,PorRef   !
-c #sw real      PorVol,rWater                 !
-c #sw real      rusNEW,rdzNEW,etaNEW          !
-      real      ro_new                        !
-      real      TaPole                        ! Maximum     Polar Temperature
-      real      T__Min                        ! Minimum realistic Temperature
-      real      EmiSol                        ! Emissivity of       Soil
-      real      EmiSno                        ! Emissivity of            Snow
-      real      EmiWat                        ! Emissivity of a Water Area
-      real      vk2                           ! Square of Von Karman Constant
-      real      u2star                        !(u*)**2
-      real      Z0mLnd                        !          Land Roughness Length
-c #ZN real      sqrrZ0                        ! u*t/u*
-      real      f_eff                         ! Marticorena & B. 1995 JGR (20)
-      real      A_Fact                        ! Fundamental * Roughness
-      real      Z0m_nu                        ! Smooth R Snow Roughness Length
-      real      Z0mBSn                        !         BSnow Roughness Length
-      real      Z0mBS0                        ! Mimimum BSnow Roughness Length
-      real      Z0m_S0                        ! Mimimum  Snow Roughness Length
-      real      Z0m_S1                        ! Maximum  Snow Roughness Length
-c #SZ real      Z0Sa_N                        ! Regime   Snow Roughness Length
-c #SZ real      Z0SaSi                        ! 1.IF Rgm Snow Roughness Length 
-c #GL real      Z0_GIM                        ! Mimimum GIMEX Roughness Length
-      real      Z0_ICE                        ! Ice ISW   Roughness Length
-      real      Z0m_Sn,Z0m_90                 ! Snow  Surface Roughness Length
-      real      SnoWat                        ! Snow Layer    Switch
-      real      rstar,alors                   !
-      real      rstar0,rstar1,rstar2          !
-      real      SameOK                        ! 1. => Same Type of Grains
-      real      G1same                        ! Averaged G1,  same Grains
-      real      G2same                        ! Averaged G2,  same Grains
-      real      typ__1                        ! 1. => Lay1 Type: Dendritic
-      real      zroNEW                        ! dz X ro, if fresh Snow
-      real      G1_NEW                        ! G1,      if fresh Snow
-      real      G2_NEW                        ! G2,      if fresh Snow
-      real      zroOLD                        ! dz X ro, if old   Snow
-      real      G1_OLD                        ! G1,      if old   Snow
-      real      G2_OLD                        ! G2,      if old   Snow
-      real      SizNEW                        ! Size,    if fresh Snow
-      real      SphNEW                        ! Spheric.,if fresh Snow
-      real      SizOLD                        ! Size,    if old   Snow
-      real      SphOLD                        ! Spheric.,if old   Snow
-      real      Siz_av                        ! Averaged    Grain Size
-      real      Sph_av                        ! Averaged    Grain Spher.
-      real      Den_av                        ! Averaged    Grain Dendr.
-      real      G1diff                        ! Averaged G1, diff. Grains
-      real      G2diff                        ! Averaged G2, diff. Grains
-      real      G1                            ! Averaged G1
-      real      G2                            ! Averaged G2
-      real      param                         ! Polynomial   fit z0=f(T)
-      real      Z0_obs                        ! Fit Z0_obs=f(T) (m)
-      real      tamin                         ! min T of linear fit (K)
-      real      tamax                         ! max T of linear fit (K)
-      real      coefa,coefb,coefc,coefd       ! Coefs for z0=f(T)
-      real      ta1,ta2,ta3                   ! Air temperature thresholds
-      real      z01,z02,z03                   ! z0 thresholds
-      real      tt_c,vv_c                     ! Critical param.
-      real      tt_tmp,vv_tmp,vv_virt         ! Temporary variables
-      real      e_prad,e1pRad,A_Rad0,absg_V,absgnI,exdRad ! variables for SoSosv calculations
-      real      zm1, zm2, coefslope                    ! variables for surface temperature extrapolation
-! for Aeolian erosion and blowing snow
-      integer   nit   ,iit
-      real      Fac                           ! Correc. factor for drift ratio
-      real      dusuth,signus
-      real      sss__F,sss__N
-      real      sss__K,sss__G
-      real      us_127,us_227,us_327,us_427,us_527
-      real      VVa_OK, usuth0
-      real      ssstar
-      real      SblPom
-      real      rCd10n                        ! Square root of drag coefficient
-      real      DendOK                        ! Dendricity Switch
-      real      SaltOK                        ! Saltation  Switch
-      real      MeltOK                        ! Saltation  Switch (Melting Snow)
-      real      SnowOK                        ! Pack Top   Switch
-      real      SaltM1,SaltM2,SaltMo,SaltMx   ! Saltation  Parameters
-      real      ShearX, ShearS                ! Arg. Max Shear Stress
-      real      Por_BS                        ! Snow Porosity
-      real      Salt_us                       ! New thresh.friction velocity u*t
-      real      Fac_Mo,ArguSi,FacRho          ! Numerical factors for u*t
-      real      SaltSI(klonv,0:nsno)          ! Snow Drift Index              !
-      real      MIN_Mo                        ! Minimum Mobility Fresh Fallen *
-      character*3    qsalt_param              ! Switch for saltation flux param.
-      character*3    usth_param               ! Switch for u*t param
-
-
-! Internal DATA
-! =============
-
-      data      T__Min / 200.00/              ! Minimum realistic Temperature
-      data      TaPole / 268.15/              ! Maximum Polar Temperature (value from C. Agosta)
-      data      roSMin / 300.  /              ! Minimum Snow  Density
-      data      roSMax / 400.  /              ! Max Fresh Snow Density
-      data      tt_c   / -2.0  /              ! Critical Temp. (degC)
-      data      vv_c   / 14.3  /              ! Critical Wind speed (m/s)
-      data      roSn_1 / 109.  /              ! Fall.Sno.Density, Indep. Param.
-      data      roSn_2 /   6.  /              ! Fall.Sno.Density, Temper.Param.
-      data      roSn_3 /  26.  /              ! Fall.Sno.Density, Wind   Param.
-      data      Dendr1 /  17.12/              ! Fall.Sno.Dendric.,Wind 1/Param.
-      data      Dendr2 / 128.  /              ! Fall.Sno.Dendric.,Wind 2/Param.
-      data      Dendr3 / -20.  /              ! Fall.Sno.Dendric.,Indep. Param.
-      data      Spher1 /   7.87/              ! Fall.Sno.Spheric.,Wind 1/Param.
-      data      Spher2 /  38.  /              ! Fall.Sno.Spheric.,Wind 2/Param.
-      data      Spher3 /  50.  /              ! Fall.Sno.Spheric.,Wind 3/Param.
-      data      Spher4 /  90.  /              ! Fall.Sno.Spheric.,Indep. Param.
-      data      EmiSol /   0.99999999/        ! 0.94Emissivity of Soil
-      data      EmiWat /   0.99999999/        ! Emissivity of a Water Area
-      data      EmiSno /   0.99999999/        ! Emissivity of Snow
-
-      
-!     DATA      Emissivities                  ! Pielke, 1984, pp. 383,409
-
-      data      Z0mBS0 /   0.5e-6/            ! MINimum Snow Roughness Length 
-                                              ! for Momentum if Blowing Snow
-                                              ! Gallee et al. 2001 BLM 99 (19)
-      data      Z0m_S0/    0.00005/           ! MINimum Snow Roughness Length
-                                              ! MegaDunes    included
-      data      Z0m_S1/    0.030  /           ! MAXimum Snow Roughness Length
-                                              !        (Sastrugis)
-c #GL data      Z0_GIM/    0.0013/            ! Ice Min Z0 = 0.0013 m (Broeke)
-!                                             ! Old Ice Z0 = 0.0500 m (Bruce)
-!                                             !              0.0500 m (Smeets)
-!                                             !              0.1200 m (Broeke)
-      data      Z0_ICE/    0.0010/            ! Sea-Ice Z0 = 0.0010 m (Andreas)
-!                                             !    (Ice Station Weddel -- ISW)
-! for aerolian erosion
-      data      SblPom/ 1.27/   ! Lower Boundary Height Parameter
-C +                             ! for Suspension
-C +                             ! Pommeroy, Gray and Landine 1993,
-C +                             ! J. Hydrology, 144(8) p.169
-      data      nit   / 5   /   ! us(is0,uth) recursivity: Nb Iterations
-cc#AE data      qsalt_param/"bin"/ ! saltation part. conc. from Bintanja 2001 (p
-      data      qsalt_param/"pom"/ ! saltation part. conc. from Pomeroy and Gray
-cc#AE data      usth_param/"lis"/  ! u*t from Liston et al. 2007
-      data      usth_param/"gal"/  ! u*t from Gallee et al. 2001
-      data      SaltMx/-5.83e-2/
-
-      vk2    =  vonKrm  *  vonKrm             ! Square of Von Karman Constant
-
-
-! BEGIN.main.
-! ===========================
-
-
-
-
-! "Soil" Humidity of Water Bodies
-! ===============================
-
-      DO ikl=1,knonv
-
-          ist    =      isotSV(ikl)                       ! Soil Type
-          ist__s =  min(ist, 1)                           ! 1 => Soil
-          ist__w =  1 - ist__s                            ! 1 => Water Body
-        DO isl=-nsol,0
-          eta_SV(ikl,isl) = eta_SV(ikl,isl) * ist__s      ! Soil 
-     .                    + etadSV(ist)     * ist__w      ! Water Body
-        END DO
-
-
-! Vertical Discretization Factor
-! ==============================
-
-          LSdzsv(ikl)     =                   ist__s      ! Soil
-     .                    + OcndSV          * ist__w      ! Water Body
-      END DO
-
-
-
-
-
-      IF (SnoMod)                            THEN
-
- 
-C +--Aeolian erosion and Blowing Snow
-C +==================================
-
-
-
-        DO ikl=1,knonv
-            usthSV(ikl) =                     1.0e+2
-        END DO
-
-
-        IF (BloMod) THEN
- 
-        if (klonv==1) then
-          if(isnoSV(1)>=2                   .and.
-     .         TsisSV(1,max(1,isnoSV(1)))<273.  .and.
-     .         ro__SV(1,max(1,isnoSV(1)))<500.  .and.
-     .         eta_SV(1,max(1,isnoSV(1)))<epsi) then
-C +                       **********
-                     CALL SISVAT_BSn
-          endif
-         else
-                     CALL SISVAT_BSn
-C +                       **********
-        endif
-
-
-
-
-
-
-
-! Calculate threshold erosion velocity for next time step
-! Unlike in sisvat, computation is of threshold velocity made here (instead of sisvaesbl)
-! since we do not use sisvatesbl for the coupling with LMDZ
-
-C +--Computation of threshold friction velocity for snow erosion
-C --------------------------------------------------------------- 
-
-        rCd10n =  1. / 26.5 ! Vt / u*t = 26.5
-                     ! Budd et al. 1965, Antarct. Res. Series Fig.13
-                     ! ratio developped during assumed neutral conditions
- 
-
-C +--Snow Properties
-C +  ~~~~~~~~~~~~~~~
-
-        DO ikl = 1,knonv
-
-          isn      =  isnoSV(ikl)
-
-
- 
-          DendOK   =  max(zero,sign(unun,epsi-G1snSV(ikl,isn)  ))  !
-          SaltOK   =  min(1   , max(istdSV(2)-istoSV(ikl,isn),0))  !
-          MeltOK   =     (unun                                     !
-     .             -max(zero,sign(unun,TfSnow-epsi                 !
-     .             -TsisSV(ikl,isn)  )))                           ! Melting Snow
-     .             *  min(unun,DendOK                              !
-     .                  +(1.-DendOK)                               !
-     .                      *sign(unun,     G2snSV(ikl,isn)-1.0))  ! 1.0 for 1mm
-          SnowOK   =  min(1   , max(isnoSV(ikl)      +1 -isn ,0))  ! Snow Switch
- 
-          G1snSV(ikl,isn) =      SnowOK *    G1snSV(ikl,isn)
-     .                  + (1.- SnowOK)*min(G1snSV(ikl,isn),G1_dSV)
-          G2snSV(ikl,isn) =      SnowOK *    G2snSV(ikl,isn)
-     .                  + (1.- SnowOK)*min(G2snSV(ikl,isn),G1_dSV)
- 
-          SaltOK   =  min(unun, SaltOK + MeltOK) * SnowOK
- 
- 
-C +--Mobility Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.)
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          SaltM1   = -0.750e-2 * G1snSV(ikl,isn)
-     .             -0.500e-2 * G2snSV(ikl,isn)+ 0.500e00 !dendritic case
-C +     CAUTION:  Guyomarc'h & Merindol Dendricity Sign is +
-C +     ^^^^^^^^                    MAR Dendricity Sign is -
-          SaltM2   = -0.833d-2 * G1snSV(ikl,isn)
-     .             -0.583d-2 * G2snSV(ikl,isn)+ 0.833d00 !non-dendritic case
- 
-c       SaltMo   = (DendOK   * SaltM1 + (1.-DendOK) *     SaltM2       )
-          SaltMo   = 0.625 !SaltMo pour d=s=0.5
- 
-!weighting SaltMo with surface snow density (Vionnet et al. 2012)
-cc#AE   FacRho   = 1.25 - 0.0042 * ro__SV(ikl,isn)
-cc#AE   SaltMo   = 0.34 * SaltMo + 0.66 * FacRho !needed for polar snow
-          MIN_Mo   =  0.
-c       SaltMo   =  max(SaltMo,MIN_Mo)
-c       SaltMo   =  SaltOK   * SaltMo + (1.-SaltOK) * min(SaltMo,SaltMx)
-c #TUNE SaltMo   =  SaltOK   * SaltMo - (1.-SaltOK) *     0.9500
-          SaltMo   =  max(SaltMo,epsi-unun)
- 
-C +--Influence of Density on Threshold Shear Stress
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          Por_BS =  1. - 300. / ro_Ice
-          ShearS = Por_BS / (1.-Por_BS)
-C +...         SheaBS =  Arg(sqrt(shear = max shear stress in snow)):
-C +            shear  =  3.420d00 * exp(-(Por_BS      +Por_BS)
-C +  .                                  /(unun        -Por_BS))
-C +            SheaBS :  see de Montmollin         (1978),
-C +                      These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124
- 
-C +--Snow Drift Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.)
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          ArguSi      =     -0.085 *us__SV(ikl)/rCd10n
-!V=u*/sqrt(CD) eqs 2 to 4 Gallee et al. 2001
- 
-          SaltSI(ikl,isn) = -2.868 * exp(ArguSi) + 1 + SaltMo
- 
-
-C +--Threshold Friction Velocity
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          if(ro__SV(ikl,isn)>300.) then
-             Por_BS      =  1.000       - ro__SV(ikl,isn)     /ro_Ice
-          else
-             Por_BS      =  1.000  - 300. /ro_Ice
-          endif
- 
-          ShearX =  Por_BS/max(epsi,1.-Por_BS)
-          Fac_Mo = exp(-ShearX+ShearS)
-C +     Gallee et al., 2001    eq 5, p5
- 
-          if (usth_param == "gal") then
-            Salt_us   =   (log(2.868) - log(1 + SaltMo)) * rCd10n/0.085
-            Salt_us   = Salt_us * Fac_Mo
-C +...  Salt_us   :  Extension of  Guyomarc'h & Merindol 1998 with
-C +...              de Montmollin (1978). Gallee et al. 2001
-          endif
- 
-          if (usth_param == "lis") then !Liston et al. 2007
-            if(ro__SV(ikl,isn)>300.) then
-              Salt_us   = 0.005*exp(0.013*ro__SV(ikl,isn))
-            else
-              Salt_us   = 0.01*exp(0.003*ro__SV(ikl,isn))
-            endif
-          endif
- 
-          SnowOK   =  1 -min(1,iabs(isn-isnoSV(ikl))) !Switch new vs old snow
- 
-          usthSV(ikl) =     SnowOK *   (Salt_us)
-     .                + (1.-SnowOK)*    usthSV(ikl)
- 
-        END DO
-
-
- 
-!  Feeback between blowing snow turbulent Scale  u* (commented here
-!  since ustar is an input variable (not in/out) of inlandsis)
-!  -----------------------------------------------------------------
-
-
-!           VVa_OK      =  max(0.000001,       VVaSBL(ikl))
-!           sss__N      =  vonkar      *       VVa_OK
-!           sss__F      = (sqrCm0(ikl) - psim_z + psim_0)
-!           usuth0      =  sss__N /sss__F                ! u* if NO Blow. Snow
- 
-!           sss__G      =  0.27417     * gravit
- 
-! !  ______________               _____
-! !  Newton-Raphson (! Iteration, BEGIN)
-! !  ~~~~~~~~~~~~~~               ~~~~~
-!           DO iit=1,nit
-!           sss__K      =  gravit      * r_Turb * A_Turb *za__SV(ikl)
-!      .                                     *rCDmSV(ikl)*rCDmSV(ikl)
-!      .                           /(1.+0.608*QaT_SV(ikl)-qsnoSV(ikl))
-!           us_127      =  exp(    SblPom *log(us__SV(ikl)))
-!           us_227      =  us_127         *    us__SV(ikl)
-!           us_327      =  us_227         *    us__SV(ikl)
-!           us_427      =  us_327         *    us__SV(ikl)
-!           us_527      =  us_427         *    us__SV(ikl)
- 
-!           us__SV(ikl) =  us__SV(ikl)
-!      .    - (  us_527     *sss__F     /sss__N
-!      .      -  us_427
-!      .      -  us_227     *qsnoSV(ikl)*sss__K
-!      .      + (us__SV(ikl)*us__SV(ikl)-usthSV(ikl)*usthSV(ikl))/sss__G)
-!      .     /(  us_427*5.27*sss__F     /sss__N
-!      .      -  us_327*4.27
-!      .      -  us_127*2.27*qsnoSV(ikl)*sss__K
-!      .      +  us__SV(ikl)*2.0                                 /sss__G)
- 
-!           us__SV(ikl)= min(us__SV(ikl),usuth0)
-!           us__SV(ikl)= max(us__SV(ikl),epsi  )
-!           rCDmSV(ikl)=     us__SV(ikl)/VVa_OK
-! ! #AE     sss__F     =     vonkar     /rCDmSV(ikl)
-!           ENDDO
- 
-! !  ______________               ___
-! !  Newton-Raphson (! Iteration, END  )
-! !  ~~~~~~~~~~~~~~               ~~~
- 
-!           us_127      =  exp(    SblPom *log(us__SV(ikl)))
-!           us_227      =  us_127         *    us__SV(ikl)
- 
-! !  Momentum            Turbulent Scale  u*: 0-Limit in case of no Blow. Snow
-! !  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-!           dusuth      =  us__SV(ikl) - usthSV(ikl)       ! u* - uth*
-!           signus      =  max(sign(unun,dusuth),zero)     ! 1 <=> u* - uth* > 0
-!           us__SV(ikl) =                                  !
-!      .                   us__SV(ikl)  *signus  +         ! u* (_BS)
-!      .                   usuth0                          ! u* (nBS)
-!      .                            *(1.-signus)           !        
-
-
-
-
-!  Blowing Snow        Turbulent Scale ss*
-!  ---------------------------------------
- 
-        hSalSV(ikl) = 8.436e-2  * us__SV(ikl)**SblPom
- 
-        if (qsalt_param == "pom") then
-          qSalSV(ikl) = (us__SV(ikl)**2 - usthSV(ikl)**2) *signus
-     .               / (hSalSV(ikl) * gravit * us__SV(ikl) * 3.25)
-        endif
- 
-        if (qsalt_param == "bin") then
-          qSalSV(ikl) = (us__SV(ikl) * us__SV(ikl)
-     .                -usthSV(ikl) * usthSV(ikl))*signus
-     .                * 0.535 / (hSalSV(ikl) * gravit)
-        endif
- 
-        qSalSV(ikl) = qSalSV(ikl)/rht_SV(ikl) ! conversion kg/m3 to kg/kg
- 
-        ssstar      = rCDmSV(ikl) * (qsnoSV(ikl) - qSalSV(ikl))
-     .              * r_Turb !Bintanja 2000, BLM
-!r_Turb compensates for an overestim. of the blown snow part. fall velocity
- 
-        uss_SV(ikl) = min(zero    , us__SV(ikl) *ssstar)
-        uss_SV(ikl) = max(-0.0001 , uss_SV(ikl))   
-
-
-
-
-        ENDIF   ! BloMod
- 
-C + ------------------------------------------------------
-C +--Buffer Layer
-C +  -----------------------------------------------------
- 
-          DO ikl=1,knonv
-c  BufsSV(ikl) [mm w.e.] i.e, i.e., [kg/m2]
-            d_Bufs      =  max(dsn_SV(ikl) *dt__SV,0.)  !
-            dsn_SV(ikl) =      0.                       !
-            Bufs_N      =      BufsSV(ikl) +d_Bufs      !
- 
- 
-C +--Snow Density
-C +  ^^^^^^^^^^^^
-            Polair      =      zero
-c #NP       Polair      =  max(zero,                    !
-c #NP.                         sign(unun,TaPole         !
-c #NP.                                  -TaT_SV(ikl)))  !
-            Polair      =  max(zero,                    !
-     .                         sign(unun,TaPole         !
-     .                                  -TaT_SV(ikl)))  !
-            Buf_ro      =  max( rosMin,                 ! Fallen Snow Density
-     .      roSn_1+roSn_2*     (TaT_SV(ikl)-TfSnow)     ! [kg/m3]
-     .            +roSn_3*sqrt( VV__SV(ikl)))           ! Pahaut    (CEN), Etienne: use wind speed at first model level instead of 10m wind
-c #NP       BufPro      =  max( rosMin,                 ! Fallen Snow Density
-c #NP.         104. *sqrt( max( VV10SV(ikl)-6.0,0.0)))  ! Kotlyakov (1961)
- 
-!          C.Agosta option for snow density, same as for BS i.e.
-!          is_ok_density_kotlyakov=.FALSE.
-c #BS       density_kotlyakov = .FALSE.  !C.Amory BS 2018
-C + ...     Fallen Snow Density, Adapted for Antarctica
-            if (is_ok_density_kotlyakov) then
-                tt_tmp = TaT_SV(ikl)-TfSnow
-                !vv_tmp = VV10SV(ikl)
-                vv_tmp=VV__SV(ikl) ! Etienne: use wind speed at first model level instead of 10m wind
-C + ...         [ A compromise between
-C + ...           Kotlyakov (1961) and Lenaerts (2012, JGR, Part1) ]
-                if (tt_tmp>=-10) then
-                  BufPro   =  max( rosMin,
-     .            104. *sqrt( max( vv_tmp-6.0,0.0))) ! Kotlyakov (1961)
-                else
-                  vv_virt = (tt_c*vv_tmp+vv_c*(tt_tmp+10))
-     .                     /(tt_c+tt_tmp+10)
-                  BufPro  = 104. *sqrt( max( vv_virt-6.0,0.0))
-                endif
-            else
-C + ...         [ density derived from observations of the first 50cm of
-C + ...           snow - cf. Rajashree Datta - and multiplied by 0.8 ]
-C + ...           C. Agosta, 2016-09
-cc #SD           BufPro = 149.2 + 6.84*VV10SV(ikl) + 0.48*Tsrfsv(ikl)
-cc #SD           BufPro = 125 + 14*VV10SV(ikl) + 0.6*Tsrfsv(ikl) !MAJ CK and CAm
-!                BufPro = 200 + 21 * VV10SV(ikl)!CK 29/07/19
-                 BufPro = 200 + 21 * VV__SV(ikl)!Etienne: use wind speed at first model level instead of 10m wind
-            endif
- 
-            Bros_N      = (1. - Polair) *   Buf_ro      ! Temperate Snow
-     .                        + Polair  *   BufPro      ! Polar     Snow
- 
-            Bros_N = max( 20.,max(rosMin,  Bros_N))
-            Bros_N = min(400.,min(rosMax-1,Bros_N)) ! for dz_min in SISVAT_zSn
- 
- 
-!    Density of deposited blown snow
-!    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- 
-         if (BloMod) then
-         Bros_N      = frsno
-         ro_new      = ro__SV(ikl,max(1,isnoSV(ikl)))
-         ro_new      = max(Bros_N,min(roBdSV,ro_new))
-         Fac         = 1-((ro__SV(ikl,max(1,isnoSV(ikl)))
-     .               -roBdSV)/(500.-roBdSV))
-         Fac         = max(0.,min(1.,Fac))
-         dsnbSV(ikl) = Fac*dsnbSV(ikl)
-         Bros_N      = Bros_N     * (1.0-dsnbSV(ikl))
-     .               + ro_new     *      dsnbSV(ikl)
-         endif
-
- 
-!    Time averaged Density of deposited blown Snow
-!    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-           
-            BrosSV(ikl) =(Bros_N     *      d_Bufs      !
-     .                   +BrosSV(ikl)*      BufsSV(ikl))!
-     .                   /         max(epsi,Bufs_N)     !
- 
- 
-C +-- S.Falling Snow Properties (computed as in SISVAT_zAg)
-C +     ^^^^^^^^^^^^^^^^^^^^^^^
-            Buf_G1      =  max(-G1_dSV,                 ! Temperate Snow
-     .               min(Dendr1*VV__SV(ikl)-Dendr2,     !     Dendricity
-     .                   Dendr3                   ))    !
-            Buf_G2      =  min( Spher4,                 ! Temperate Snow
-     .               max(Spher1*VV__SV(ikl)+Spher2,     !     Sphericity
-     .                   Spher3                   ))    !
-! EV: now control buf_sph_pol and bug_siz_pol in physiq.def
-            Buf_G1      = (1. - Polair) *   Buf_G1      ! Temperate Snow
-     .                        + Polair  *   buf_sph_pol ! Polar Snow 
-            Buf_G2      = (1. - Polair) *   Buf_G2      ! Temperate Snow
-     .                        + Polair  *   buf_siz_pol ! Polar Snow
-                G1      =                   Buf_G1      ! NO  Blown Snow
-                G2      =                   Buf_G2      ! NO  Blown Snow
-
-
-
-            IF (BloMod) THEN 
-
-!     S.1. Meme  Type  de Neige  / same Grain Type
-!          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-           SameOK  =  max(zero,
-     .         sign(unun,    Buf_G1             *G1_dSV
-     .                            - eps_21                    ))
-           G1same  = ((1.0-dsnbSV(ikl))*Buf_G1+dsnbSV(ikl) *G1_dSV)
-           G2same  = ((1.0-dsnbSV(ikl))*Buf_G2+dsnbSV(ikl) *ADSdSV)
-!           Blowing Snow Properties:                         G1_dSV, ADSdSV
- 
-!     S.2. Types differents / differents Types
-!          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-           typ__1  =  max(zero,sign(unun,epsi-Buf_G1))   ! =1.=> Dendritic
-           zroNEW  =     typ__1  *(1.0-dsnbSV(ikl))      ! fract.Dendr.Lay.
-     .            + (1.-typ__1) *     dsnbSV(ikl)       !
-           G1_NEW  =     typ__1  *Buf_G1                 ! G1 of Dendr.Lay.
-     .            + (1.-typ__1) *G1_dSV                 !
-           G2_NEW  =     typ__1  *Buf_G2                 ! G2 of Dendr.Lay.
-     .            + (1.-typ__1) *ADSdSV                 !
-           zroOLD  = (1.-typ__1) *(1.0-dsnbSV(ikl))      ! fract.Spher.Lay.
-     .            +     typ__1  *     dsnbSV(ikl)       !
-           G1_OLD  = (1.-typ__1) *Buf_G1                 ! G1 of Spher.Lay.
-     .            +     typ__1  *G1_dSV                 !
-           G2_OLD  = (1.-typ__1) *Buf_G2                 ! G2 of Spher.Lay.
-     .            +     typ__1  *ADSdSV                 !
-           SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV          ! Size  Dendr.Lay.
-     .            +(1.+G1_NEW         /G1_dSV)          !
-     .                  *(G2_NEW  *DScdSV/G1_dSV        !
-     .            +(1.-G2_NEW         /G1_dSV)*DFcdSV)  !
-           SphNEW  =     G2_NEW         /G1_dSV          ! Spher.Dendr.Lay.
-           SizOLD  =     G2_OLD                          ! Size  Spher.Lay.
-           SphOLD  =     G1_OLD         /G1_dSV          ! Spher.Spher.Lay.
-           Siz_av  =     (zroNEW*SizNEW+zroOLD*SizOLD)   ! Averaged Size
-           Sph_av  = min( zroNEW*SphNEW+zroOLD*SphOLD    !
-     .                 ,  unun)                         ! Averaged Sphericity
-           Den_av  = min((Siz_av -(    Sph_av *DScdSV    !
-     .            +(1.-Sph_av)*DFcdSV))                 !
-     .            / (DDcdSV -(    Sph_av *DScdSV        !
-     .            +(1.-Sph_av)*DFcdSV))                 !
-     .                   ,  unun)                       !
-           DendOK  = max(zero,                           !
-     .                    sign(unun,     Sph_av *DScdSV   ! Small   Grains
-     .                              +(1.-Sph_av)*DFcdSV   ! Faceted Grains
-     .                              -    Siz_av        )) !
-C +...      REMARQUE: le  type moyen (dendritique ou non) depend
-C +         ^^^^^^^^  de la  comparaison avec le diametre optique
-C +                   d'une neige recente de   dendricite nulle
-C +...      REMARK:   the mean type  (dendritic   or not) depends
-C +         ^^^^^^    on the comparaison with the optical diameter
-C +                   of a recent snow    having zero dendricity
- 
-           G1diff  =(   -DendOK *Den_av
-     .            +(1.-DendOK)*Sph_av) *G1_dSV
-           G2diff  =     DendOK *Sph_av  *G1_dSV
-     .            +(1.-DendOK)*Siz_av
-           G1      =     SameOK *G1same
-     .            +(1.-SameOK)*G1diff
-           G2      =     SameOK *G2same
-     .            +(1.-SameOK)*G2diff
-           ENDIF
-
-
- 
-!     S.1. Meme  Type  de Neige  / same Grain Type
-!          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-            SameOK  =  max(zero,
-     .                     sign(unun,    Buf_G1 *BG1sSV(ikl)
-     .                                 - eps_21                    ))
-            G1same  = (d_Bufs*Buf_G1+BufsSV(ikl)*BG1sSV(ikl))
-     .                     /max(epsi,Bufs_N)
-            G2same  = (d_Bufs*Buf_G2+BufsSV(ikl)*BG2sSV(ikl))
-     .                     /max(epsi,Bufs_N)
- 
-!     S.2. Types differents / differents Types
-!          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-            typ__1  =  max(zero,sign(unun,epsi-Buf_G1))   ! =1.=> Dendritic
-            zroNEW  =(    typ__1  *d_Bufs                 ! fract.Dendr.Lay.
-     .              + (1.-typ__1) *BufsSV(ikl))           !
-     .                   /max(epsi,Bufs_N)                !
-            G1_NEW  =     typ__1  *Buf_G1                 ! G1 of Dendr.Lay.
-     .              + (1.-typ__1) *BG1sSV(ikl)            !
-            G2_NEW  =     typ__1  *Buf_G2                 ! G2 of Dendr.Lay.
-     .              + (1.-typ__1) *BG2sSV(ikl)            !
-            zroOLD  =((1.-typ__1) *d_Bufs                 ! fract.Spher.Lay.
-     .              +     typ__1  *BufsSV(ikl))           !
-     .                   /max(epsi,Bufs_N)                !
-            G1_OLD  = (1.-typ__1) *Buf_G1                 ! G1 of Spher.Lay.
-     .              +     typ__1  *BG1sSV(ikl)            !
-            G2_OLD  = (1.-typ__1) *Buf_G2                 ! G2 of Spher.Lay.
-     .              +     typ__1  *BG2sSV(ikl)            !
-            SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV          ! Size  Dendr.Lay.
-     .               +(1.+G1_NEW         /G1_dSV)         !
-     .                  *(G2_NEW  *DScdSV/G1_dSV          !
-     .               +(1.-G2_NEW         /G1_dSV)*DFcdSV) !
-            SphNEW  =     G2_NEW         /G1_dSV          ! Spher.Dendr.Lay.
-            SizOLD  =     G2_OLD                          ! Size  Spher.Lay.
-            SphOLD  =     G1_OLD         /G1_dSV          ! Spher.Spher.Lay.
-            Siz_av  =   ( zroNEW  *SizNEW+zroOLD*SizOLD)  ! Averaged Size
-            Sph_av = min( zroNEW  *SphNEW+zroOLD*SphOLD   !
-     .                  ,   unun                       )  ! Averaged Sphericity
-            Den_av = min((Siz_av  - (    Sph_av *DScdSV   !
-     .                              +(1.-Sph_av)*DFcdSV)) !
-     .                 / (DDcdSV  - (    Sph_av *DScdSV   !
-     .                              +(1.-Sph_av)*DFcdSV)) !
-     .                  ,   unun                         )!
-            DendOK  = max(zero,                           !
-     .                    sign(unun,     Sph_av *DScdSV   ! Small   Grains
-     .                              +(1.-Sph_av)*DFcdSV   ! Faceted Grains
-     .                              -    Siz_av        )) !
-C +...      REMARQUE: le  type moyen (dendritique ou non) depend
-C +         ^^^^^^^^  de la  comparaison avec le diametre optique
-C +                   d'une neige recente de   dendricite nulle
-C +...      REMARK:   the mean type  (dendritic   or not) depends
-C +         ^^^^^^    on the comparaison with the optical diameter
-C +                   of a recent snow    having zero dendricity
- 
-            G1diff  =(   -DendOK *Den_av
-     .               +(1.-DendOK)*Sph_av) *G1_dSV
-            G2diff  =     DendOK *Sph_av  *G1_dSV
-     .               +(1.-DendOK)*Siz_av
-            G1      =     SameOK *G1same
-     .               +(1.-SameOK)*G1diff
-            G2      =     SameOK *G2same
-     .               +(1.-SameOK)*G2diff
- 
-            BG1sSV(ikl) =                       G1      !
-     .                  *       Bufs_N/max(epsi,Bufs_N) !
-            BG2sSV(ikl) =                       G2      !
-     .                  *       Bufs_N/max(epsi,Bufs_N) !
- 
-
-C +--Update of Buffer Layer Content & Decision about creating a new snow layer
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-            BufsSV(ikl) =       Bufs_N                  !     [mm w.e.]
-            NLaysv(ikl) = min(unun,                     !
-     .                    max(zero,                     ! Allows to create
-     .                        sign(unun,BufsSV(ikl)     ! a new snow Layer
-     .                                 -SMndSV     ))   ! if Buffer > SMndSV
-     .                   *max(zero,                     ! Except if * Erosion
-     .                        sign(unun,0.50            ! dominates
-     .                                 -dsnbSV(ikl)))   !
-     .                   +max(zero,                     ! Allows to create
-     .                        sign(unun,BufsSV(ikl)     ! a new snow Layer
-     .                                 -SMndSV*3.00)))  ! is Buffer > SMndSV*3
-            Bdzssv(ikl) = 1.e-3*BufsSV(ikl)*ro_Wat      ! [mm w.e.] -> [m w.e.]
-     .                            /max(epsi,BrosSV(ikl))!& [m w.e.] -> [m]
- 
- 
-          END DO
- 
-
-
-! Snow Pack Discretization(option XF in MAR)
-! ==========================================
-
-          
-      if (discret_xf.AND.klonv==1) then
-
-       if(isnoSV(1)>=1.or.NLaysv(1)>=1) then
-C +          **********
-         CALL SISVAT_zSn
-C +          **********
-       endif
-      else
-C +          **********
-        CALL SISVAT_zSn
-C +          **********
-      endif
- 
-C +          **********
-! #ve   CALL SISVAT_wEq('_zSn  ',0)
-C +          **********
-
-! Add a new Snow Layer
-! ====================
-
-          DO ikl=1,knonv
-
-            isnoSV(ikl)     = isnoSV(ikl)         +NLaysv(ikl)
-            isn             = isnoSV(ikl)
-            dzsnSV(ikl,isn) = dzsnSV(ikl,isn) * (1-NLaysv(ikl))
-     .                      + Bdzssv(ikl)     *    NLaysv(ikl) 
-            TsisSV(ikl,isn) = TsisSV(ikl,isn) * (1-NLaysv(ikl))
-     .                  + min(TaT_SV(ikl),Tf_Sno) *NLaysv(ikl) 
-            ro__SV(ikl,isn) = ro__SV(ikl,isn) * (1-NLaysv(ikl))
-     .                      + Brossv(ikl)     *    NLaysv(ikl) 
-            eta_SV(ikl,isn) = eta_SV(ikl,isn) * (1-NLaysv(ikl))   ! + 0. 
-            agsnSV(ikl,isn) = agsnSV(ikl,isn) * (1-NLaysv(ikl))   ! + 0. 
-            G1snSV(ikl,isn) = G1snSV(ikl,isn) * (1-NLaysv(ikl))
-     .                      + BG1ssv(ikl)     *    NLaysv(ikl)
-            G2snSV(ikl,isn) = G2snSV(ikl,isn) * (1-NLaysv(ikl))
-     .                      + BG2ssv(ikl)     *    NLaysv(ikl)
-            istoSV(ikl,isn) = istoSV(ikl,isn) * (1-NLaysv(ikl))
-     .   + max(zer0,sign(un_1,TaT_SV(ikl)
-     .                       -Tf_Sno-eps_21)) *    istdSV(2)
-     .                                        *    NLaysv(ikl)
-            BufsSV(ikl)     = BufsSV(ikl)     * (1-NLaysv(ikl))
-            NLaysv(ikl)     = 0
-
-
-          END DO
-
-
-! Snow Pack Thickness
-! -------------------
-
-        DO ikl=1,knonv
-            z_snsv(ikl)     = 0.0
-        END DO
-        DO   isn=1,nsno
-          DO ikl=1,knonv
-            z_snsv(ikl)     = z_snsv(ikl) + dzsnSV(ikl,isn)
-            zzsnsv(ikl,isn) = z_snsv(ikl)
-          END DO
-        END DO
-
-
-
-      END IF  ! SnoMod
-
-
-
-! Soil Albedo: Soil Humidity Correction
-! ==========================================
-
-!         REFERENCE: McCumber and Pielke (1981), Pielke (1984)
-!         ^^^^^^^^^
-          DO ikl=1,knonv
-            albssv(ikl) = 
-     .      alb0SV(ikl) *(1.0-min(half,eta_SV(       ikl,0)
-     .                                /etadSV(isotSV(ikl))))
-!         REMARK:    Albedo of Water Surfaces (isotSV=0): 
-!         ^^^^^^     alb0SV := 2  X  effective value, while 
-!                    eta_SV :=          etadSV
-          END DO
-
-
-! Snow Pack Optical Properties
-! ============================
-
-      IF (SnoMod)                                                 THEN
-
-!            ******
-        CALL SnOptP(jjtime)
-!            ******
-
-      ELSE
-        DO ikl=1,knonv
-          sEX_sv(ikl,1) = 1.0
-          sEX_sv(ikl,0) = 0.0
-          albisv(ikl)   = albssv(ikl)
-        END DO
-      END IF
-
-
-
-! Soil optical properties
-! =============================
-!Etienne: as in inlandis we do not CALL vgopt, we need to define
-!the albedo alb_SV and to calculate the
-!absorbed Solar Radiation by Surfac (Normaliz)[-] SoSosv
-
- 
-      DO ikl=1,klonv
-
-            e_pRad = 2.5   *  coszSV(ikl)       ! exponential argument,
-                                                ! V/nIR radiation partitioning,
-                                                ! DR97, 2, eqn (2.53) & (2.54)
-            e1pRad = 1.-exp(-e_pRad)            ! exponential, V/nIR Rad. Part.
-            exdRad= 1.
- 
-! Visible Part of the Solar Radiation Spectrum (V,   0.4--0.7mi.m) 
-            A_Rad0 =      0.25 + 0.697 * e1pRad ! Absorbed    Vis. Radiation
-            absg_V = (1.-albisv(ikl))*(A_Rad0*exdRad)  !
- 
-! Near-IR Part of the Solar Radiation Spectrum (nIR, 0.7--2.8mi.m)
- 
-            A_Rad0 =      0.80 + 0.185 * e1pRad ! Absorbed    nIR. Radiation
-            absgnI = (1.-albisv(ikl))*(A_Rad0*exdRad)  !
-
-            SoSosv(ikl) = (absg_V+absgnI)*0.5d0
-
-            alb_SV(ikl) = albisv(ikl)
-
-      END DO
- 
-!            **********
-! #ve   CALL SISVAT_wEq('SnOptP',0)
-!            **********
-
-
-! Surface Emissivity (Etienne: simplified calculation for landice)
-! =============================================================
-
-       DO ikl=1,knonv
-            LSnMsk     =     min( 1,isnoSV(ikl))
-            Eso_sv(ikl)=  EmiSol*(1-LSnMsk)+EmiSno*LSnMsk  ! Sol+Sno Emissivity
-            emi_SV(ikl)= EmiSol*(1-LSnMsk) + EmiSno*LSnMsk
-        END DO
-
-
-
-
-!  Upward IR (INPUT, from previous time step)
-! ===================================================================
-
-        DO ikl=1,knonv
-! #e1     Enrsvd(ikl) =    - IRs_SV(ikl)
-           IRupsv(ikl) =      IRs_SV(ikl) 
-        END DO
-
-
-! Turbulence
-! ==========
-
-! Latent Heat of Vaporization/Sublimation
-! ---------------------------------------
-
-        DO ikl=1,knonv
-          SnoWat      =                     min(isnoSV(ikl),0)
-          Lx_H2O(ikl) =
-     .    (1.-SnoWat) * LhvH2O 
-     .  +     SnoWat  *(LhsH2O * (1.-eta_SV(ikl,isnoSV(ikl)))
-     .                 +LhvH2O *     eta_SV(ikl,isnoSV(ikl)) )
-        END DO
-
-
-
-
-! Aerodynamic Resistance (calculated from drags given by LMDZ)
-! Commented because already calculated in surf_inlandsis_mod
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-!       DO ikl=1,knonv
-!          ram_sv(ikl) = 1./(cdM_SV(ikl)*max(VV__SV(ikl),eps6))
-!          rah_sv(ikl) = 1./(cdH_SV(ikl)*max(VV__SV(ikl),eps6))
-!        END DO
-
-
-
-! Soil   Energy Balance
-! =====================
-
-
-      if (iflag_temp_inlandsis == 0) then
-
-       CALL SISVAT_TSo
-
-      else
-        DO ikl=1,knonv
-        Tsf_SV(ikl)=Tsrfsv(ikl)
-        END DO
-
-       CALL SISVAT_TS2
-
-      end if
-
-
-!            **********
-! #ve   CALL SISVAT_wEq('_TSo  ',0)
-!            **********
-
-
-
-! Soil Water     Potential
-! ------------------------
-
-      DO   isl=-nsol,0
-        DO ikl=1,knonv
-          ist             =     isotSV(ikl)        ! Soil Type
-          psi_sv(ikl,isl) =     psidSV(ist)        ! DR97, Eqn.(3.34)
-     .  *(etadSV(ist) /max(eps6,eta_SV(ikl,isl)))  !
-     .  **bCHdSV(ist)                              !
-
-
-! Soil Hydraulic Conductivity
-! ---------------------------
-
-          Khydsv(ikl,isl) =    s2__SV(ist)         ! DR97, Eqn.(3.35)
-     .  *(eta_SV(ikl,isl)**(2.*bCHdSV(ist)+3.))    !  
-        END DO
-      END DO
-
-
-! Melting / Refreezing in the Snow Pack
-! =====================================
-
-      IF (SnoMod)                                                 THEN
-
-!            **********
-        CALL SISVAT_qSn
-!            **********
-
-!            **********
-! #ve   CALL SISVAT_wEq('_qSn  ',0)
-!            **********
-
-
-! Snow Pack Thickness
-! -------------------
-
-          DO ikl=1,knonv
-            z_snsv(ikl)     = 0.0
-          END DO
-        DO   isn=1,nsno
-          DO ikl=1,knonv
-            z_snsv(ikl)     = z_snsv(ikl) + dzsnSV(ikl,isn)
-            zzsnsv(ikl,isn) = z_snsv(ikl)
-          END DO
-        END DO
-
-
-! Energy in Excess is added to the first Soil Layer
-! -------------------------------------------------
-        DO ikl=1,knonv
-            z_snsv(ikl)   = max(zer0,
-     .                          sign(un_1,eps6-z_snsv(ikl)))
-            TsisSV(ikl,0) = TsisSV(ikl,0)    + EExcsv(ikl)
-     .                                       /(rocsSV(isotSV(ikl))
-     .                                        +rcwdSV*eta_SV(ikl,0))
-            EExcsv(ikl)   = 0.
-        END DO
-
-
-      END IF
-
-
-! Soil   Water  Balance
-! =====================
-
-!            **********
-        CALL SISVAT_qSo
-! #m0.                 (Wats_0,Wats_1,Wats_d)
-!            **********
-
-
-! Surface Fluxes
-! =====================
-
-        DO ikl=1,knonv
-         IRdwsv(ikl)=IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR
-!         IRdwsv(ikl)=tau_sv(ikl) *IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR
-!    .          +(1.0-tau_sv(ikl))*IRd_SV(ikl)*Evg_sv(ikl) !  ! Etienne, remove vegetation component
-          IRupsv(ikl) =      IRupsv(ikl)                   ! Upward   IR
-          IRu_SV(ikl) =     -IRupsv(ikl)                   ! Upward   IR
-     .                      +IRd_SV(ikl)                   ! (effective)
-     .                      -IRdwsv(ikl)                   ! (positive)
-
-          TBr_sv(ikl) =sqrt(sqrt(IRu_SV(ikl)/StefBo))      ! Brightness
-!                                                          ! Temperature
-          uts_SV(ikl) =     (HSv_sv(ikl) +HSs_sv(ikl))     ! u*T*
-     .                     /(rhT_SV(ikl) *cp)          !
-          uqs_SV(ikl) =     (HLv_sv(ikl) +HLs_sv(ikl))     ! u*q*
-     .                     /(rhT_SV(ikl) *LhvH2O)          !
-          LMO_SV(ikl) = TaT_SV(ikl)*(us__SV(ikl)**3)
-     .                     /gravit/uts_SV(ikl)/vonKrm      ! MO length
-     
-
-! Surface Temperature
-! ^^^^^^^^^^^^^^^^^^^^
-
-          IF (iflag_tsurf_inlandsis == 0) THEN
-
-            Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl))
-
-          ELSE IF (iflag_tsurf_inlandsis > 0) THEN
-! Etienne: extrapolation from the two uppermost levels:
-
-         if (isnoSV(ikl) >=2) then
-           zm1=-dzsnSV(ikl,isnoSV(ikl))/2.
-           zm2=-(dzsnSV(ikl,isnoSV(ikl)) + dzsnSV(ikl,isnoSV(ikl)-1)/2.)
-         else if (isnoSV(ikl) == 1) then
-           zm1=-dzsnSV(ikl,isnoSV(ikl))/2.
-           zm2=-(dzsnSV(ikl,isnoSV(ikl))+dz_dSV(0)/2.)
-         else
-           zm1=-dz_dSV(0)/2.
-           zm2=-(dz_dSV(0)+dz_dSV(-1)/2.)
-
-         end if
-
-           coefslope=(TsisSV(ikl,isnoSV(ikl))-TsisSV(ikl,isnoSV(ikl)-1)) 
-     .               /(zm1-zm2)
-           Tsrfsv(ikl)=TsisSV(ikl,isnoSV(ikl))+coefslope*(0. - zm1)
-
-
-         ELSE !(default)
-
-           Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl))
-
-         END IF
-
-
-         END DO
-
-! Snow Pack Properties (sphericity, dendricity, size)
-! ===================================================
-
-      IF (SnoMod)                                                 THEN
-
-      if (discret_xf .AND. klonv==1) then
-      if(isnoSV(1)>=1) then
-C +          **********
-      CALL SISVAT_GSn
-C +          **********
-      endif
-      else
-C +          **********
-        CALL SISVAT_GSn
-C +          **********
-      endif
-
-
-      END IF
-
-
-! Roughness Length for next time step
-!====================================
-
-! Note that in INLANDSIS, we treat only ice covered surfaces so calculation
-! of z0 is much simpler (no subgrid fraction of ocean or land)
-! old calculations are commented below
-
-
-C +--Roughness Length for Momentum
-C +  -----------------------------
-
-! ETIENNE WARNING: changes have been made wrt original SISVAT
- 
-C +--Land+Sea-Ice / Ice-free Sea Mask
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=1,knonv
-          IcIndx(ikl) = 0
-        ENDDO
-        DO isn=1,nsno
-        DO ikl=1,knonv
-
-          IcIndx(ikl) = max(IcIndx(ikl),
-     .                  isn*max(0,
-     .                  sign(1,
-     .                  int(ro__SV(ikl,isn)-900.))))
-        ENDDO
-        ENDDO
- 
-        DO ikl=1,knonv
-          LISmsk    =     1. ! in inlandsis, land only
-          IceMsk    =     max(0,sign(1   ,IcIndx(ikl)-1)  )
-          SnoMsk    = max(min(isnoSV(ikl)-iiceSV(ikl),1),0)
-
-
-C +--Z0 Smooth Regime over Snow (Andreas 1995, CRREL Report 95-16, p. 8)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-          Z0m_nu =       5.e-5 ! z0s~(10-d)*exp(-vonkar/sqrt(1.1e-03))
-
-C +--Z0 Saltat.Regime over Snow (Gallee  et al., 2001, BLM 99 (19) p.11)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-          u2star =       us__SV(ikl) *us__SV(ikl)
-          Z0mBSn =       u2star      *0.536e-3   -  61.8e-6
-          Z0mBSn =   max(Z0mBS0      ,Z0mBSn)
-
-C +--Z0 Smooth + Saltat. Regime
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-          Z0enSV(ikl) =  Z0m_nu
-     .                +  Z0mBSn
-
-        
-! Calculation of snow roughness length
-!=====================================
-          IF (iflag_z0m_snow == 0) THEN
-
-          Z0m_Sn=prescribed_z0m_snow
-
-          ELSE IF (iflag_z0m_snow == 1) THEN
-
-          Z0m_Sn=Z0enSV(ikl) 
-
-          ELSE IF (iflag_z0m_snow == 2) THEN
-
-C +--Rough   Snow Surface Roughness Length (Variable Sastrugi Height)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          A_Fact      =  1.0000        ! Andreas et al., 2004, p.4
-                                       ! ams.confex.com/ams/pdfpapers/68601.pdf
- 
-! Parameterization of z0 dependance on Temperature (C. Amory, 2017)
-! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-! Z0=f(T) deduced from observations, Adelie Land, dec2012-dec2013
-
-          
-          coefa = 0.1658 !0.1862 !Ant
-          coefb = -50.3869 !-55.7718 !Ant
-          ta1 = 253.15 !255. Ant
-          ta2 = 273.15
-          ta3 = 273.15+3
-          z01 = exp(coefa*ta1 + coefb) !~0.2 ! ~0.25 mm
-          z02 = exp(coefa*ta2 + coefb) !~6  !~7 mm
-          z03 = z01
-          coefc = log(z03/z02)/(ta3-ta2)
-          coefd = log(z03)-coefc*ta3
-
-          if (TaT_SV(ikl) < ta1) then
-            Z0_obs = z01
-          else if (TaT_SV(ikl)>=ta1 .and. TaT_SV(ikl)<ta2) then
-            Z0_obs = exp(coefa*TaT_SV(ikl) + coefb)
-          else if (TaT_SV(ikl)>=ta2 .and. TaT_SV(ikl)<ta3) then
-            ! if st > 0, melting induce smooth surface
-            Z0_obs = exp(coefc*TaT_SV(ikl) + coefd)
-          else
-            Z0_obs = z03
-          endif
- 
-          Z0m_Sn=Z0_obs
-
-
-          ELSE
-
-          Z0m_Sn=0.500e-3  ! default=0.500e-3m (tuning of MAR) 
-
-          ENDIF
- 
-
-
-!          param = Z0_obs/1. ! param(s) | 1.(m/s)=TUNING 
-c #SZ     Z0Sa_N =                   (us__SV(ikl) -0.2)*param   ! 0.0001=TUNING
-c #SZ.           * max(zero,sign(unun,TfSnow-eps9
-c #SZ.                               -TsisSV(ikl , isnoSV(ikl))))
-!!#SZ     Z0SaSi = max(zero,sign(unun,Z0Sa_N                  ))! 1 if erosion
-c #SZ     Z0SaSi = max(zero,sign(unun,zero  -eps9 -uss_SV(ikl)))!
-c #SZ     Z0Sa_N = max(zero,          Z0Sa_N)
-c #SZ     Z0SaSV(ikl) =
-c #SZ.             max(Z0SaSV(ikl)   ,Z0SaSV(ikl)
-c #SZ.               + Z0SaSi*(Z0Sa_N-Z0SaSV(ikl))*exp(-dt__SV/43200.))
-c #SZ.               -            min(dz0_SV(ikl) ,     Z0SaSV(ikl))
- 
-c #SZ     A_Fact      =               Z0SaSV(ikl) *  5.0/0.15   ! A=5 if h~10cm
-C +...    CAUTION: The influence of the sastrugi direction is not yet included
- 
-c #SZ     Z0m_Sn =                    Z0SaSV(ikl)               !
-c #SZ.                              - Z0m_nu                    !
- 
-C +--Z0 Saltat.Regime over Snow (Shao & Lin, 1999, BLM 91 (46)  p.222)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-c #ZN     sqrrZ0 =       usthSV(ikl)/max( us__SV(ikl),0.001)
-c #ZN     sqrrZ0 =                   min( sqrrZ0     ,0.999)
-c #ZN     Z0mBSn =       0.55 *0.55 *exp(-sqrrZ0     *sqrrZ0)
-c #ZN.                  *us__SV(ikl)*     us__SV(ikl)*grvinv*0.5
- 
-C +--Z0 Smooth + Saltat. Regime (Shao & Lin, 1999, BLM 91 (46)  p.222)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-c #ZN     Z0enSV(ikl) = (Z0m_nu     **    sqrrZ0 )
-c #ZN.                * (Z0mBSn     **(1.-sqrrZ0))
-c #ZN     Z0enSV(ikl) =  max(Z0enSV(ikl), Z0m_nu)
- 
-
-C +--Z0 Smooth Regime over Snow (Andreas etAl., 2004
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^  ams.confex.com/ams/pdfpapers/68601.pdf)
-c #ZA     Z0m_nu = 0.135*akmol  / max(us__SV(ikl) , epsi)
- 
-C +--Z0 Saltat.Regime over Snow (Andreas etAl., 2004
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^  ams.confex.com/ams/pdfpapers/68601.pdf)
-c #ZA     Z0mBSn = 0.035*u2star      *grvinv
- 
-C +--Z0 Smooth + Saltat. Regime (Andreas etAl., 2004
-!    (      used by Erosion)     ams.confex.com/ams/pdfpapers/68601.pdf)
-!    ^^^^^^^^^^^^^^^^^^^^^^^^^^
-c #ZA     Z0enSV(ikl) =  Z0m_nu
-c #ZA.                +  Z0mBSn
- 
-C +--Z0 Rough  Regime over Snow (Andreas etAl., 2004
-C +  (.NOT. used by Erosion)     ams.confex.com/ams/pdfpapers/68601.pdf)
-!    ^^^^^^^^^^^^^^^^^^^^^^^^^^
-!!#ZA     u2star =      (us__SV(ikl) -0.1800)     / 0.1
-!!#ZA     Z0m_Sn =A_Fact*Z0mBSn *exp(-u2star*u2star)
-c #ZA     Z0m_90 =(10.-0.025*VVs_SV(ikl)/5.)
-c #ZA.            *exp(-0.4/sqrt(.00275+.00001*max(0.,VVs_SV(ikl)-5.)))
-c #ZA     Z0m_Sn =           DDs_SV(ikl)* Z0m_90 / 45.
-c #ZA.         - DDs_SV(ikl)*DDs_SV(ikl)* Z0m_90 /(90.*90.)
-
-
-
-
-C +--Z0  (Erosion)    over Snow (instantaneous)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-          Z0e_SV(ikl) =  Z0enSV(ikl)
- 
-C +--Momentum  Roughness Length (Etienne: changes wrt original SISVAT)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                              
-          Z0mnSV(ikl) =  Z0m_nu *(1-SnoMsk)                     ! Ice z0
-     .                + (Z0m_Sn)*SnoMsk                         ! Snow Sastrugi Form and Snow Erosion
- 
-
-C +--GIS  Roughness Length
-C +  ^^^^^^^^^^^^^^^^^^^^^
-c #GL     Z0mnSV(ikl) =
-c #GL.      (1-LSmask(ikl)) *     Z0mnSV(ikl)
-c #GL.    +    LSmask(ikl)  * max(Z0mnSV(ikl),max(Z0_GIM,
-c #GL.                                            Z0_GIM+
-c #GL.      (0.0032-Z0_GIM)*(ro__SV(ikl,isnoSV(ikl))-600.)   !
-c #GL.                     /(920.00                 -600.))) !
- 
-C +--Mom. Roughness Length, Instantaneous
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          Z0m_SV(ikl) =  Z0mnSV(ikl)                         ! Z0mnSV  instant.
- 
- 
-C +--Roughness Length for Scalars
-C +  ----------------------------
- 
-          Z0hnSV(ikl) =     Z0mnSV(ikl)/  7.4
- 
-          IF (is_ok_z0h_rn) THEN
-
-          rstar       =     Z0mnSV(ikl) * us__SV(ikl) / akmol
-          rstar       = max(epsi,min(rstar,R_1000))
-          alors       =          log(rstar)
-          rstar0      = 1.250e0 * max(zero,sign(unun,0.135e0 - rstar))
-     .                +(1.      - max(zero,sign(unun,0.135e0 - rstar)))
-     .                *(0.149e0 * max(zero,sign(unun,2.500e0 - rstar))
-     .                + 0.317e0
-     .                *(1.      - max(zero,sign(unun,2.500e0 - rstar))))
-          rstar1      = 0.      * max(zero,sign(unun,0.135e0 - rstar))
-     .                +(1.      - max(zero,sign(unun,0.135e0 - rstar)))
-     .                *(-0.55e0 * max(zero,sign(unun,2.500e0 - rstar))
-     .                - 0.565
-     .                *(1.      - max(zero,sign(unun,2.500e0 - rstar))))
-          rstar2      = 0.      * max(zero,sign(unun,0.135e0 - rstar))
-     .                +(1.      - max(zero,sign(unun,0.135e0 - rstar)))
-     .                *(0.      * max(zero,sign(unun,2.500e0 - rstar))
-     .                - 0.183
-     .                *(unun    - max(zero,sign(unun,2.500e0 - rstar))))
- 
-          
-
-!XF    #RN (is_ok_z0h_rn) does not work well over bare ice
-!XF    MAR is then too warm and not enough melt
- 
-         if(ro__SV(ikl,isnoSV(ikl))>50
-     .  .and.ro__SV(ikl,isnoSV(ikl))<roSdSV)then
- 
-             Z0hnSV(ikl) = max(zero
-     .                , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi))
-     .                * exp(rstar0+rstar1*alors+rstar2*alors*alors)
-     .                * 0.001e0 + Z0hnSV(ikl) * ( 1. - max(zero
-     .                , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi)))
- 
-          endif
-
-
-          ENDIF
-  
-          Z0h_SV(ikl) =     Z0hnSV(ikl)
- 
-
-c #MT     Z0m_SV(ikl) = max(2.0e-6     ,Z0m_SV(ikl)) ! Min Z0_m (Garrat Scheme)
-!          Z0m_SV(ikl) = min(Z0m_SV(ikl),za__SV(ikl)*0.3333)
-     
-
-       END DO
- 
-
-       return
-       end
-
-
-
-
-
-
-
-
-
-
- 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/inlandsis.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/inlandsis.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/inlandsis.f90	(revision 5105)
@@ -0,0 +1,1510 @@
+SUBROUTINE INLANDSIS(SnoMod,BloMod,jjtime,debut)
+
+  USE dimphy
+
+  !--------------------------------------------------------------------------+
+  ! INLANDSIS module                                                     |
+  ! Simplified SISVAT module, containing ice and snow processes for      |
+  ! ice-covered surfaces                                                 |
+  ! version MARv3, november 2020                                         |
+  ! SubRoutine INLANDSIS contains the fortran 77 code of the             |
+  !            Soil/Ice Snow Vegetation Atmosphere Transfer Scheme       |
+  !                                                                      |
+  !--------------------------------------------------------------------------+
+  ! PARAMETERS:  klonv: Total Number of columns =                        |
+  ! ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  !                   X       Number of Mosaic Cell per grid box         |
+  !                                                                      |
+  ! INPUT:   daHost   : Date Host Model                                  |
+  ! ^^^^^                                                                |
+  !                                                                      |
+  ! INPUT:   LSmask   : 1:          Land       MASK                      |
+  ! ^^^^^               0:          Sea        MASK                      |
+  !          isotSV   = 0,...,12:   Soil       Type                      |
+  !                     0:          Water,          Liquid (Sea, Lake)   |
+  !                    12:          Water, Solid           (Ice)         |
+  !                                                                      |
+  ! INPUT:   coszSV   : Cosine of the Sun Zenithal Distance          [-] |
+  ! ^^^^^    sol_SV   : Surface Downward  Solar      Radiation    [W/m2] |
+  !          IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
+  !          drr_SV   : Rain  Intensity                        [kg/m2/s] |
+  !          dsn_SV   : Snow  Intensity                      [mm w.e./s] |
+  !          dsnbSV   : Snow  Intensity,  Drift Fraction             [-] |
+  !          dbs_SV   : Drift Amount                           [mm w.e.] |
+  !          za__SV   : Surface Boundary Layer (SBL) Height          [m] |
+  !          VV__SV   :(SBL Top)   Wind Velocity                   [m/s] |
+  !          TaT_SV   : SBL Top    Temperature                       [K] |
+  !          rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
+  !          QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
+  !          qsnoSV   : SBL Mean   Snow      Content             [kg/kg] |
+  !          alb0SV   : Soil Basic Albedo                            [-] |
+  !          slopSV   : Surface    Slope                             [-] |
+  !          dt__SV   : Time  Step                                   [s] |
+  !                                                                      |
+  ! INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! OUTPUT:  ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
+  ! ^^^^^^   iiceSV   = total Nb of Ice      Layers                      |
+  !          istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
+  !                                                                      |
+  ! INPUT /  alb_SV   : Surface        Albedo                        [-] |
+  ! OUTPUT:  emi_SV   : Surface        Emissivity                    [-] |
+  ! ^^^^^^   IRs_SV   : Soil           IR Flux  (negative)        [W/m2] |
+  !          LMO_SV   : Monin-Obukhov               Scale            [m] |
+  !          us__SV   : Friction          Velocity                 [m/s] |
+  !          uts_SV   : Temperature       Turbulent Scale          [m/s] |
+  !          uqs_SV   : Specific Humidity Velocity                 [m/s] |
+  !          uss_SV   : Blowing Snow      Turbulent Scale          [m/s] |
+  !          usthSV   : Blowing Snow      Erosion   Threshold      [m/s] |
+  !          Z0m_SV   : Momentum     Roughness Length                [m] |
+  !          Z0mmSV   : Momentum     Roughness Length (time mean)    [m] |
+  !          Z0mnSV   : Momentum     Roughness Length (instantaneous)[m] |
+  !          Z0SaSV   : Sastrugi     Roughness Length                [m] |
+  !          Z0e_SV   : Erosion Snow Roughness Length                [m] |
+  !          Z0emSV   : Erosion Snow Roughness Length (time mean)    [m] |
+  !          Z0enSV   : Erosion Snow Roughness Length (instantaneous)[m] |
+  !          Z0roSV   : Subgrid Topo Roughness Length                [m] |
+  !          Z0h_SV   : Heat         Roughness Length                [m] |
+  !          TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+  !                   & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  !          ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
+  !          eta_SV   : Soil/Snow Water   Content                [m3/m3] |
+  !          G1snSV   : snow dendricity/sphericity                       |
+  !          G2snSV   : snow sphericity/grain size                       |
+  !          dzsnSV   : Snow Layer        Thickness                  [m] |
+  !          agsnSV   : Snow       Age                             [day] |
+  !          BufsSV   : Snow Buffer Layer              [kg/m2] .OR. [mm] |
+  !          BrosSV   : Snow Buffer Layer Density      [kg/m3]           |
+  !          BG1sSV   : Snow Buffer Layer Dendricity / Sphericity    [-] |
+  !          BG2sSV   : Snow Buffer Layer Sphericity / Size [-] [0.1 mm] |
+  !          rusnSV   : Surficial   Water              [kg/m2] .OR. [mm] |
+  !                                                                      |
+  ! OUTPUT:  no__SV   : OUTPUT file Unit Number                      [-] |
+  ! ^^^^^^   i___SV   : OUTPUT point   i Coordinate                  [-] |
+  !          j___SV   : OUTPUT point   j Coordinate                  [-] |
+  !          n___SV   : OUTPUT point   n Coordinate                  [-] |
+  !          lwriSV   : OUTPUT point vec Index                       [-] |
+  !                                                                      |
+  ! OUTPUT:  IRu_SV   : Upward     IR Flux (+, upw., effective)      [K] |
+  ! ^^^^^^   hSalSV   : Saltating Layer Height                       [m] |
+  !          qSalSV   : Saltating Snow  Concentration            [kg/kg] |
+  !          RnofSV   : RunOFF Intensity                       [kg/m2/s] |
+  !                                                                      |
+  ! Internal Variables:                                                  |
+  ! ^^^^^^^^^^^^^^^^^^                                                   |
+  !          NLaysv   = New            Snow Layer Switch             [-] |
+  !          albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
+  !          SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
+  !          TBr_sv   : Brightness Temperature                       [K] |
+  !          IRupsv   : Upward     IR Flux (-, upw.)              [W/m2] |
+  !          ram_sv   : Aerodynamic Resistance for Momentum        [s/m] |
+  !          rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
+  !          Evp_sv   : Evaporation                              [kg/m2] |
+  !          EvT_sv   : Evapotranspiration                       [kg/m2] |
+  !          HSs_sv   : Surface    Sensible Heat Flux + => absorb.[W/m2] |
+  !          HLs_sv   : Surface    Latent   Heat Flux + => absorb.[W/m2] |
+  !          Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
+  !          Tsrfsv   : Surface    Temperature                       [K] |
+  !          sEX_sv   : Verticaly Integrated Extinction Coefficient  [-] |
+  !          LSdzsv   : Vertical   Discretization Factor             [-] |
+  !                   =    1. Soil                                       |
+  !                   = 1000. Ocean                                      |
+  !          z_snsv   : Snow Pack  Thickness                         [m] |
+  !          zzsnsv   : Snow Pack  Thickness                         [m] |
+  !          albssv   : Soil       Albedo                            [-] |
+  !          Eso_sv   : Soil+Snow       Emissivity                   [-] |
+  !          Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
+  !                                                                      |
+  !          ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
+  !          ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
+  !          ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
+  !          EqSn_0   : Snow      Energy, before Phase Change     [J/m2] |
+  !          EqSn_1   : Snow      Energy, after  Phase Change     [J/m2] |
+  !          EqSn_d   : Snow      Energy,       net    Forcing    [J/m2] |
+  !          Enrsvd   : SVAT      Energy Power         Forcing    [W/m2] |
+  !          Enrbal   : SVAT      Energy Balance                  [W/m2] |
+  !          Wats_0   : Soil Water,  before Forcing                 [mm] |
+  !          Wats_1   : Soil Water,  after  Forcing                 [mm] |
+  !          Wats_d   : Soil Water          Forcing                 [mm] |
+  !          SIWm_0   : Snow        initial Mass               [mm w.e.] |
+  !          SIWm_1   : Snow        final   Mass               [mm w.e.] |
+  !          SIWa_i   : Snow Atmos. initial Forcing            [mm w.e.] |
+  !          SIWa_f   : Snow Atmos. final   Forcing(noConsumed)[mm w.e.] |
+  !          SIWe_i   : SnowErosion initial Forcing            [mm w.e.] |
+  !          SIWe_f   : SnowErosion final   Forcing(noConsumed)[mm w.e.] |
+  !          SIsubl   : Snow sublimed/deposed  Mass            [mm w.e.] |
+  !          SImelt   : Snow Melted            Mass            [mm w.e.] |
+  !          SIrnof   : Surficial Water + Run OFF Change       [mm w.e.] |
+  !          SIvAcr   : Sea-Ice    vertical Acretion           [mm w.e.] |
+  !          Watsvd   : SVAT Water          Forcing                 [mm] |
+  !          Watbal   : SVAT Water  Balance                       [W/m2] |
+  !                                                                      |
+  !          vk2      : Square of Von Karman Constant                [-] |
+  !          sqrCm0   : Factor of   Neutral Drag Coeffic.Momentum  [s/m] |
+  !          sqrCh0   : Factor of   Neutral Drag Coeffic.Heat      [s/m] |
+  !          EmiSol   : Soil          Emissivity                     [-] |
+  !          EmiSno   : Snow          Emissivity                     [-] |
+  !          EmiWat   : Water         Emissivity                     [-] |
+  !          Z0mLnd   :          Land Roughness Length               [m] |
+  !          sqrrZ0   : u*t/u*                                           |
+  !          f_eff    : Marticorena & B. 1995 JGR (20)                   |
+  !          A_Fact   : Fundamental * Roughness                          |
+  !          Z0mBSn   :         BSnow Roughness Length               [m] |
+  !          Z0mBS0   : Mimimum BSnow Roughness Length (blown* )     [m] |
+  !          Z0m_Sn   :          Snow Roughness Length (surface)     [m] |
+  !          Z0m_S0   : Mimimum  Snow Roughness Length               [m] |
+  !          Z0m_S1   : Maximum  Snow Roughness Length               [m] |
+  !          Z0_GIM   : Minimum GIMEX Roughness Length               [m] |
+  !          Z0_ICE   : Sea Ice ISW   Roughness Length               [m] |
+  !                                                                      |
+  !                                                                      |
+  !--------------------------------------------------------------------------+
+
+
+
+  ! Global Variables
+  ! ================
+
+
+  USE VARphy
+  USE VAR_SV
+  USE VARdSV
+  USE VAR0SV
+  USE VARxSV
+  USE VARySV
+  USE VARtSV
+  USE surface_data, ONLY: is_ok_z0h_rn, &
+        is_ok_density_kotlyakov, &
+        prescribed_z0m_snow, &
+        iflag_z0m_snow, &
+        iflag_tsurf_inlandsis, &
+        iflag_temp_inlandsis, &
+        discret_xf, buf_sph_pol,buf_siz_pol
+
+  IMPLICIT NONE
+
+  logical :: SnoMod
+  logical :: BloMod
+  logical :: debut
+  integer :: jjtime
+
+
+  ! Internal Variables
+  ! ==================
+
+  ! Non Local
+  ! ---------
+
+  real :: TBr_sv(klonv)                 ! Brightness Temperature
+  real :: IRdwsv(klonv)                 ! DOWNward   IR Flux
+  real :: IRupsv(klonv)                 ! UPward     IR Flux
+  real :: d_Bufs,Bufs_N                 ! Buffer Snow Layer Increment
+  real :: Buf_ro,Bros_N                 ! Buffer Snow Layer Density
+  real :: BufPro                        ! Buffer Snow Layer Density
+  real :: Buf_G1,BG1__N                 ! Buffer Snow Layer Dendr/Sphe[-]
+  real :: Buf_G2,BG2__N                 ! Buffer Snow Layer Spher/Size[-]
+  real :: Bdzssv(klonv)                 ! Buffer Snow Layer Thickness
+  real :: z_snsv(klonv)                 ! Snow-Ice, current Thickness
+
+
+
+  ! Local
+  ! -----
+
+  integer :: iwr
+  integer :: ikl   ,isn   ,isl   ,ist      !
+  integer :: ist__s,ist__w                 ! Soil/Water Body Identifier
+  integer :: growth                        ! Seasonal               Mask
+  integer :: LISmsk                        ! Land+Ice / Open    Sea Mask
+  integer :: LSnMsk                        ! Snow-Ice / No Snow-Ice Mask
+  integer :: IceMsk,IcIndx(klonv)          !      Ice / No      Ice Mask
+  integer :: SnoMsk                        ! Snow     / No Snow     Mask
+  real :: roSMin,roSMax,roSn_1,roSn_2,roSn_3   ! Fallen Snow Density (PAHAUT)
+  real :: Dendr1,Dendr2,Dendr3          ! Fallen Snow Dendric.(GIRAUD)
+  real :: Spher1,Spher2,Spher3,Spher4   ! Fallen Snow Spheric.(GIRAUD)
+  real :: Polair                        ! Polar  Snow Switch
+  real :: PorSno,Salt_f,PorRef   !
+  ! #sw real      PorVol,rWater                 !
+  ! #sw real      rusNEW,rdzNEW,etaNEW          !
+  real :: ro_new                        !
+  real :: TaPole                        ! Maximum     Polar Temperature
+  real :: T__Min                        ! Minimum realistic Temperature
+  real :: EmiSol                        ! Emissivity of       Soil
+  real :: EmiSno                        ! Emissivity of            Snow
+  real :: EmiWat                        ! Emissivity of a Water Area
+  real :: vk2                           ! Square of Von Karman Constant
+  real :: u2star                        !(u*)**2
+  real :: Z0mLnd                        !          Land Roughness Length
+  ! #ZN real      sqrrZ0                        ! u*t/u*
+  real :: f_eff                         ! Marticorena & B. 1995 JGR (20)
+  real :: A_Fact                        ! Fundamental * Roughness
+  real :: Z0m_nu                        ! Smooth R Snow Roughness Length
+  real :: Z0mBSn                        !         BSnow Roughness Length
+  real :: Z0mBS0                        ! Mimimum BSnow Roughness Length
+  real :: Z0m_S0                        ! Mimimum  Snow Roughness Length
+  real :: Z0m_S1                        ! Maximum  Snow Roughness Length
+  ! #SZ real      Z0Sa_N                        ! Regime   Snow Roughness Length
+  ! #SZ real      Z0SaSi                        ! 1.IF Rgm Snow Roughness Length
+  ! #GL real      Z0_GIM                        ! Mimimum GIMEX Roughness Length
+  real :: Z0_ICE                        ! Ice ISW   Roughness Length
+  real :: Z0m_Sn,Z0m_90                 ! Snow  Surface Roughness Length
+  real :: SnoWat                        ! Snow Layer    Switch
+  real :: rstar,alors                   !
+  real :: rstar0,rstar1,rstar2          !
+  real :: SameOK                        ! 1. => Same Type of Grains
+  real :: G1same                        ! Averaged G1,  same Grains
+  real :: G2same                        ! Averaged G2,  same Grains
+  real :: typ__1                        ! 1. => Lay1 Type: Dendritic
+  real :: zroNEW                        ! dz X ro, if fresh Snow
+  real :: G1_NEW                        ! G1,      if fresh Snow
+  real :: G2_NEW                        ! G2,      if fresh Snow
+  real :: zroOLD                        ! dz X ro, if old   Snow
+  real :: G1_OLD                        ! G1,      if old   Snow
+  real :: G2_OLD                        ! G2,      if old   Snow
+  real :: SizNEW                        ! Size,    if fresh Snow
+  real :: SphNEW                        ! Spheric.,if fresh Snow
+  real :: SizOLD                        ! Size,    if old   Snow
+  real :: SphOLD                        ! Spheric.,if old   Snow
+  real :: Siz_av                        ! Averaged    Grain Size
+  real :: Sph_av                        ! Averaged    Grain Spher.
+  real :: Den_av                        ! Averaged    Grain Dendr.
+  real :: G1diff                        ! Averaged G1, diff. Grains
+  real :: G2diff                        ! Averaged G2, diff. Grains
+  real :: G1                            ! Averaged G1
+  real :: G2                            ! Averaged G2
+  real :: param                         ! Polynomial   fit z0=f(T)
+  real :: Z0_obs                        ! Fit Z0_obs=f(T) (m)
+  real :: tamin                         ! min T of linear fit (K)
+  real :: tamax                         ! max T of linear fit (K)
+  real :: coefa,coefb,coefc,coefd       ! Coefs for z0=f(T)
+  real :: ta1,ta2,ta3                   ! Air temperature thresholds
+  real :: z01,z02,z03                   ! z0 thresholds
+  real :: tt_c,vv_c                     ! Critical param.
+  real :: tt_tmp,vv_tmp,vv_virt         ! Temporary variables
+  real :: e_prad,e1pRad,A_Rad0,absg_V,absgnI,exdRad ! variables for SoSosv calculations
+  real :: zm1, zm2, coefslope                    ! variables for surface temperature extrapolation
+  ! for Aeolian erosion and blowing snow
+  integer :: nit   ,iit
+  real :: Fac                           ! Correc. factor for drift ratio
+  real :: dusuth,signus
+  real :: sss__F,sss__N
+  real :: sss__K,sss__G
+  real :: us_127,us_227,us_327,us_427,us_527
+  real :: VVa_OK, usuth0
+  real :: ssstar
+  real :: SblPom
+  real :: rCd10n                        ! Square root of drag coefficient
+  real :: DendOK                        ! Dendricity Switch
+  real :: SaltOK                        ! Saltation  Switch
+  real :: MeltOK                        ! Saltation  Switch (Melting Snow)
+  real :: SnowOK                        ! Pack Top   Switch
+  real :: SaltM1,SaltM2,SaltMo,SaltMx   ! Saltation  Parameters
+  real :: ShearX, ShearS                ! Arg. Max Shear Stress
+  real :: Por_BS                        ! Snow Porosity
+  real :: Salt_us                       ! New thresh.friction velocity u*t
+  real :: Fac_Mo,ArguSi,FacRho          ! Numerical factors for u*t
+  real :: SaltSI(klonv,0:nsno)          ! Snow Drift Index              !
+  real :: MIN_Mo                        ! Minimum Mobility Fresh Fallen *
+  character(len=3) :: qsalt_param              ! Switch for saltation flux param.
+  character(len=3) :: usth_param               ! Switch for u*t param
+
+
+  ! Internal DATA
+  ! =============
+
+  data      T__Min / 200.00/              ! Minimum realistic Temperature
+  data      TaPole / 268.15/              ! Maximum Polar Temperature (value from C. Agosta)
+  data      roSMin / 300.  /              ! Minimum Snow  Density
+  data      roSMax / 400.  /              ! Max Fresh Snow Density
+  data      tt_c   / -2.0  /              ! Critical Temp. (degC)
+  data      vv_c   / 14.3  /              ! Critical Wind speed (m/s)
+  data      roSn_1 / 109.  /              ! Fall.Sno.Density, Indep. Param.
+  data      roSn_2 /   6.  /              ! Fall.Sno.Density, Temper.Param.
+  data      roSn_3 /  26.  /              ! Fall.Sno.Density, Wind   Param.
+  data      Dendr1 /  17.12/              ! Fall.Sno.Dendric.,Wind 1/Param.
+  data      Dendr2 / 128.  /              ! Fall.Sno.Dendric.,Wind 2/Param.
+  data      Dendr3 / -20.  /              ! Fall.Sno.Dendric.,Indep. Param.
+  data      Spher1 /   7.87/              ! Fall.Sno.Spheric.,Wind 1/Param.
+  data      Spher2 /  38.  /              ! Fall.Sno.Spheric.,Wind 2/Param.
+  data      Spher3 /  50.  /              ! Fall.Sno.Spheric.,Wind 3/Param.
+  data      Spher4 /  90.  /              ! Fall.Sno.Spheric.,Indep. Param.
+  data      EmiSol /   0.99999999/        ! 0.94Emissivity of Soil
+  data      EmiWat /   0.99999999/        ! Emissivity of a Water Area
+  data      EmiSno /   0.99999999/        ! Emissivity of Snow
+
+
+  ! DATA      Emissivities                  ! Pielke, 1984, pp. 383,409
+
+  data      Z0mBS0 /   0.5e-6/            ! MINimum Snow Roughness Length
+                                          ! ! for Momentum if Blowing Snow
+                                          ! ! Gallee et al. 2001 BLM 99 (19)
+  data      Z0m_S0/    0.00005/           ! MINimum Snow Roughness Length
+                                          ! ! MegaDunes    included
+  data      Z0m_S1/    0.030  /           ! MAXimum Snow Roughness Length
+                                          ! !        (Sastrugis)
+  ! #GL data      Z0_GIM/    0.0013/            ! Ice Min Z0 = 0.0013 m (Broeke)
+                                          ! ! Old Ice Z0 = 0.0500 m (Bruce)
+                                          ! !              0.0500 m (Smeets)
+                                          ! !              0.1200 m (Broeke)
+  data      Z0_ICE/    0.0010/            ! Sea-Ice Z0 = 0.0010 m (Andreas)
+                                          ! !    (Ice Station Weddel -- ISW)
+  ! for aerolian erosion
+  data      SblPom/ 1.27/   ! Lower Boundary Height Parameter
+  ! +                             ! for Suspension
+  ! +                             ! Pommeroy, Gray and Landine 1993,
+  ! +                             ! J. Hydrology, 144(8) p.169
+  data      nit   / 5   /   ! us(is0,uth) recursivity: Nb Iterations
+  !c#AE data      qsalt_param/"bin"/ ! saltation part. conc. from Bintanja 2001 (p
+  data      qsalt_param/"pom"/ ! saltation part. conc. from Pomeroy and Gray
+  !c#AE data      usth_param/"lis"/  ! u*t from Liston et al. 2007
+  data      usth_param/"gal"/  ! u*t from Gallee et al. 2001
+  data      SaltMx/-5.83e-2/
+
+  vk2    =  vonKrm  *  vonKrm             ! Square of Von Karman Constant
+
+
+  ! BEGIN.main.
+  ! ===========================
+
+
+
+
+  ! "Soil" Humidity of Water Bodies
+  ! ===============================
+
+  DO ikl=1,knonv
+
+      ist    =      isotSV(ikl)                       ! Soil Type
+      ist__s =  min(ist, 1)                           ! 1 => Soil
+      ist__w =  1 - ist__s                            ! 1 => Water Body
+    DO isl=-nsol,0
+      eta_SV(ikl,isl) = eta_SV(ikl,isl) * ist__s & ! Soil
+            + etadSV(ist)     * ist__w      ! Water Body
+    END DO
+
+
+  ! Vertical Discretization Factor
+  ! ==============================
+
+      LSdzsv(ikl)     =                   ist__s & ! Soil
+            + OcndSV          * ist__w      ! Water Body
+  END DO
+
+
+
+
+
+  IF (SnoMod)                            THEN
+
+
+  ! +--Aeolian erosion and Blowing Snow
+  ! +==================================
+
+
+
+    DO ikl=1,knonv
+        usthSV(ikl) =                     1.0e+2
+    END DO
+
+
+    IF (BloMod) THEN
+
+    if (klonv==1) then
+      if(isnoSV(1)>=2                   .and. &
+            TsisSV(1,max(1,isnoSV(1)))<273.  .and. &
+            ro__SV(1,max(1,isnoSV(1)))<500.  .and. &
+            eta_SV(1,max(1,isnoSV(1)))<epsi) then
+  ! +                       **********
+                 CALL SISVAT_BSn
+      endif
+     else
+                 CALL SISVAT_BSn
+  ! +                       **********
+    endif
+
+
+
+
+
+
+
+  ! Calculate threshold erosion velocity for next time step
+  ! Unlike in sisvat, computation is of threshold velocity made here (instead of sisvaesbl)
+  ! since we do not use sisvatesbl for the coupling with LMDZ
+
+  ! +--Computation of threshold friction velocity for snow erosion
+  ! ---------------------------------------------------------------
+
+    rCd10n =  1. / 26.5 ! Vt / u*t = 26.5
+                 ! ! Budd et al. 1965, Antarct. Res. Series Fig.13
+                 ! ! ratio developped during assumed neutral conditions
+
+
+  ! +--Snow Properties
+  ! +  ~~~~~~~~~~~~~~~
+
+    DO ikl = 1,knonv
+
+      isn      =  isnoSV(ikl)
+
+
+
+      DendOK   =  max(zero,sign(unun,epsi-G1snSV(ikl,isn)  ))  !
+      SaltOK   =  min(1   , max(istdSV(2)-istoSV(ikl,isn),0))  !
+      MeltOK   =     (unun & !
+            -max(zero,sign(unun,TfSnow-epsi & !
+            -TsisSV(ikl,isn)  ))) & ! Melting Snow
+            *  min(unun,DendOK & !
+            +(1.-DendOK) & !
+            *sign(unun,     G2snSV(ikl,isn)-1.0))  ! 1.0 for 1mm
+      SnowOK   =  min(1   , max(isnoSV(ikl)      +1 -isn ,0))  ! Snow Switch
+
+      G1snSV(ikl,isn) =      SnowOK *    G1snSV(ikl,isn) &
+            + (1.- SnowOK)*min(G1snSV(ikl,isn),G1_dSV)
+      G2snSV(ikl,isn) =      SnowOK *    G2snSV(ikl,isn) &
+            + (1.- SnowOK)*min(G2snSV(ikl,isn),G1_dSV)
+
+      SaltOK   =  min(unun, SaltOK + MeltOK) * SnowOK
+
+
+  ! +--Mobility Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.)
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      SaltM1   = -0.750e-2 * G1snSV(ikl,isn) &
+            -0.500e-2 * G2snSV(ikl,isn)+ 0.500e00 !dendritic case
+  ! +     CAUTION:  Guyomarc'h & Merindol Dendricity Sign is +
+  ! +     ^^^^^^^^                    MAR Dendricity Sign is -
+      SaltM2   = -0.833d-2 * G1snSV(ikl,isn) &
+            -0.583d-2 * G2snSV(ikl,isn)+ 0.833d00 !non-dendritic case
+
+    ! SaltMo   = (DendOK   * SaltM1 + (1.-DendOK) *     SaltM2       )
+      SaltMo   = 0.625 !SaltMo pour d=s=0.5
+
+  !weighting SaltMo with surface snow density (Vionnet et al. 2012)
+  !c#AE   FacRho   = 1.25 - 0.0042 * ro__SV(ikl,isn)
+  !c#AE   SaltMo   = 0.34 * SaltMo + 0.66 * FacRho !needed for polar snow
+      MIN_Mo   =  0.
+    ! SaltMo   =  max(SaltMo,MIN_Mo)
+    ! SaltMo   =  SaltOK   * SaltMo + (1.-SaltOK) * min(SaltMo,SaltMx)
+  ! #TUNE SaltMo   =  SaltOK   * SaltMo - (1.-SaltOK) *     0.9500
+      SaltMo   =  max(SaltMo,epsi-unun)
+
+  ! +--Influence of Density on Threshold Shear Stress
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      Por_BS =  1. - 300. / ro_Ice
+      ShearS = Por_BS / (1.-Por_BS)
+  ! +...         SheaBS =  Arg(sqrt(shear = max shear stress in snow)):
+  ! +            shear  =  3.420d00 * exp(-(Por_BS      +Por_BS)
+  ! +  .                                  /(unun        -Por_BS))
+  ! +            SheaBS :  see de Montmollin         (1978),
+  ! +                      These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124
+
+  ! +--Snow Drift Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.)
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      ArguSi      =     -0.085 *us__SV(ikl)/rCd10n
+  !V=u*/sqrt(CD) eqs 2 to 4 Gallee et al. 2001
+
+      SaltSI(ikl,isn) = -2.868 * exp(ArguSi) + 1 + SaltMo
+
+
+  ! +--Threshold Friction Velocity
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      if(ro__SV(ikl,isn)>300.) then
+         Por_BS      =  1.000       - ro__SV(ikl,isn)     /ro_Ice
+      else
+         Por_BS      =  1.000  - 300. /ro_Ice
+      endif
+
+      ShearX =  Por_BS/max(epsi,1.-Por_BS)
+      Fac_Mo = exp(-ShearX+ShearS)
+  ! +     Gallee et al., 2001    eq 5, p5
+
+      if (usth_param == "gal") then
+        Salt_us   =   (log(2.868) - log(1 + SaltMo)) * rCd10n/0.085
+        Salt_us   = Salt_us * Fac_Mo
+  ! +...  Salt_us   :  Extension of  Guyomarc'h & Merindol 1998 with
+  ! +...              de Montmollin (1978). Gallee et al. 2001
+      endif
+
+      if (usth_param == "lis") then !Liston et al. 2007
+        if(ro__SV(ikl,isn)>300.) then
+          Salt_us   = 0.005*exp(0.013*ro__SV(ikl,isn))
+        else
+          Salt_us   = 0.01*exp(0.003*ro__SV(ikl,isn))
+        endif
+      endif
+
+      SnowOK   =  1 -min(1,iabs(isn-isnoSV(ikl))) !Switch new vs old snow
+
+      usthSV(ikl) =     SnowOK *   (Salt_us) &
+            + (1.-SnowOK)*    usthSV(ikl)
+
+    END DO
+
+
+
+  !  Feeback between blowing snow turbulent Scale  u* (commented here
+  !  since ustar is an input variable (not in/out) of inlandsis)
+  !  -----------------------------------------------------------------
+
+
+        ! VVa_OK      =  max(0.000001,       VVaSBL(ikl))
+        ! sss__N      =  vonkar      *       VVa_OK
+        ! sss__F      = (sqrCm0(ikl) - psim_z + psim_0)
+        ! usuth0      =  sss__N /sss__F                ! u* if NO Blow. Snow
+
+        ! sss__G      =  0.27417     * gravit
+
+  ! !  ______________               _____
+  ! !  Newton-Raphson (! Iteration, BEGIN)
+  ! !  ~~~~~~~~~~~~~~               ~~~~~
+        ! DO iit=1,nit
+        ! sss__K      =  gravit      * r_Turb * A_Turb *za__SV(ikl)
+   ! .                                     *rCDmSV(ikl)*rCDmSV(ikl)
+   ! .                           /(1.+0.608*QaT_SV(ikl)-qsnoSV(ikl))
+   !      us_127      =  exp(    SblPom *log(us__SV(ikl)))
+   !      us_227      =  us_127         *    us__SV(ikl)
+   !      us_327      =  us_227         *    us__SV(ikl)
+   !      us_427      =  us_327         *    us__SV(ikl)
+   !      us_527      =  us_427         *    us__SV(ikl)
+
+   !      us__SV(ikl) =  us__SV(ikl)
+   ! .    - (  us_527     *sss__F     /sss__N
+   ! .      -  us_427
+   ! .      -  us_227     *qsnoSV(ikl)*sss__K
+   ! .      + (us__SV(ikl)*us__SV(ikl)-usthSV(ikl)*usthSV(ikl))/sss__G)
+   ! .     /(  us_427*5.27*sss__F     /sss__N
+   ! .      -  us_327*4.27
+   ! .      -  us_127*2.27*qsnoSV(ikl)*sss__K
+   ! .      +  us__SV(ikl)*2.0                                 /sss__G)
+
+   !      us__SV(ikl)= min(us__SV(ikl),usuth0)
+   !      us__SV(ikl)= max(us__SV(ikl),epsi  )
+   !      rCDmSV(ikl)=     us__SV(ikl)/VVa_OK
+  ! ! #AE     sss__F     =     vonkar     /rCDmSV(ikl)
+   !      ENDDO
+
+  ! !  ______________               ___
+  ! !  Newton-Raphson (! Iteration, END  )
+  ! !  ~~~~~~~~~~~~~~               ~~~
+
+   !      us_127      =  exp(    SblPom *log(us__SV(ikl)))
+   !      us_227      =  us_127         *    us__SV(ikl)
+
+  ! !  Momentum            Turbulent Scale  u*: 0-Limit in case of no Blow. Snow
+  ! !  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   !      dusuth      =  us__SV(ikl) - usthSV(ikl)       ! u* - uth*
+   !      signus      =  max(sign(unun,dusuth),zero)     ! 1 <=> u* - uth* > 0
+   !      us__SV(ikl) =                                  !
+   ! .                   us__SV(ikl)  *signus  +         ! u* (_BS)
+   ! .                   usuth0                          ! u* (nBS)
+   ! .                            *(1.-signus)           !
+
+
+
+
+  !  Blowing Snow        Turbulent Scale ss*
+  !  ---------------------------------------
+
+    hSalSV(ikl) = 8.436e-2  * us__SV(ikl)**SblPom
+
+    if (qsalt_param == "pom") then
+      qSalSV(ikl) = (us__SV(ikl)**2 - usthSV(ikl)**2) *signus &
+            / (hSalSV(ikl) * gravit * us__SV(ikl) * 3.25)
+    endif
+
+    if (qsalt_param == "bin") then
+      qSalSV(ikl) = (us__SV(ikl) * us__SV(ikl) &
+            -usthSV(ikl) * usthSV(ikl))*signus &
+            * 0.535 / (hSalSV(ikl) * gravit)
+    endif
+
+    qSalSV(ikl) = qSalSV(ikl)/rht_SV(ikl) ! conversion kg/m3 to kg/kg
+
+    ssstar      = rCDmSV(ikl) * (qsnoSV(ikl) - qSalSV(ikl)) &
+          * r_Turb !Bintanja 2000, BLM
+  !r_Turb compensates for an overestim. of the blown snow part. fall velocity
+
+    uss_SV(ikl) = min(zero    , us__SV(ikl) *ssstar)
+    uss_SV(ikl) = max(-0.0001 , uss_SV(ikl))
+
+
+
+
+    ENDIF   ! BloMod
+
+  ! + ------------------------------------------------------
+  ! +--Buffer Layer
+  ! +  -----------------------------------------------------
+
+      DO ikl=1,knonv
+  !  BufsSV(ikl) [mm w.e.] i.e, i.e., [kg/m2]
+        d_Bufs      =  max(dsn_SV(ikl) *dt__SV,0.)  !
+        dsn_SV(ikl) =      0.                       !
+        Bufs_N      =      BufsSV(ikl) +d_Bufs      !
+
+
+  ! +--Snow Density
+  ! +  ^^^^^^^^^^^^
+        Polair      =      zero
+  ! #NP       Polair      =  max(zero,                    !
+  ! #NP.                         sign(unun,TaPole         !
+  ! #NP.                                  -TaT_SV(ikl)))  !
+        Polair      =  max(zero, & !
+              sign(unun,TaPole & !
+              -TaT_SV(ikl)))  !
+        Buf_ro      =  max( rosMin, & ! Fallen Snow Density
+              roSn_1+roSn_2*     (TaT_SV(ikl)-TfSnow) & ! [kg/m3]
+              +roSn_3*sqrt( VV__SV(ikl)))           ! Pahaut    (CEN), Etienne: use wind speed at first model level instead of 10m wind
+  ! #NP       BufPro      =  max( rosMin,                 ! Fallen Snow Density
+  ! #NP.         104. *sqrt( max( VV10SV(ikl)-6.0,0.0)))  ! Kotlyakov (1961)
+
+       ! C.Agosta option for snow density, same as for BS i.e.
+       ! is_ok_density_kotlyakov=.FALSE.
+  ! #BS       density_kotlyakov = .FALSE.  !C.Amory BS 2018
+  ! + ...     Fallen Snow Density, Adapted for Antarctica
+        if (is_ok_density_kotlyakov) then
+            tt_tmp = TaT_SV(ikl)-TfSnow
+            ! !vv_tmp = VV10SV(ikl)
+            vv_tmp=VV__SV(ikl) ! Etienne: use wind speed at first model level instead of 10m wind
+  ! + ...         [ A compromise between
+  ! + ...           Kotlyakov (1961) and Lenaerts (2012, JGR, Part1) ]
+            if (tt_tmp>=-10) then
+              BufPro   =  max( rosMin, &
+                    104. *sqrt( max( vv_tmp-6.0,0.0))) ! Kotlyakov (1961)
+            else
+              vv_virt = (tt_c*vv_tmp+vv_c*(tt_tmp+10)) &
+                    /(tt_c+tt_tmp+10)
+              BufPro  = 104. *sqrt( max( vv_virt-6.0,0.0))
+            endif
+        else
+  ! + ...         [ density derived from observations of the first 50cm of
+  ! + ...           snow - cf. Rajashree Datta - and multiplied by 0.8 ]
+  ! + ...           C. Agosta, 2016-09
+  !c #SD           BufPro = 149.2 + 6.84*VV10SV(ikl) + 0.48*Tsrfsv(ikl)
+  !c #SD           BufPro = 125 + 14*VV10SV(ikl) + 0.6*Tsrfsv(ikl) !MAJ CK and CAm
+             ! BufPro = 200 + 21 * VV10SV(ikl)!CK 29/07/19
+             BufPro = 200 + 21 * VV__SV(ikl)!Etienne: use wind speed at first model level instead of 10m wind
+        endif
+
+        Bros_N      = (1. - Polair) *   Buf_ro & ! Temperate Snow
+              + Polair  *   BufPro      ! Polar     Snow
+
+        Bros_N = max( 20.,max(rosMin,  Bros_N))
+        Bros_N = min(400.,min(rosMax-1,Bros_N)) ! for dz_min in SISVAT_zSn
+
+
+  !    Density of deposited blown snow
+  !    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+     if (BloMod) then
+     Bros_N      = frsno
+     ro_new      = ro__SV(ikl,max(1,isnoSV(ikl)))
+     ro_new      = max(Bros_N,min(roBdSV,ro_new))
+     Fac         = 1-((ro__SV(ikl,max(1,isnoSV(ikl))) &
+           -roBdSV)/(500.-roBdSV))
+     Fac         = max(0.,min(1.,Fac))
+     dsnbSV(ikl) = Fac*dsnbSV(ikl)
+     Bros_N      = Bros_N     * (1.0-dsnbSV(ikl)) &
+           + ro_new     *      dsnbSV(ikl)
+     endif
+
+
+  !    Time averaged Density of deposited blown Snow
+  !    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+        BrosSV(ikl) =(Bros_N     *      d_Bufs & !
+              +BrosSV(ikl)*      BufsSV(ikl)) & !
+              /         max(epsi,Bufs_N)     !
+
+
+  ! +-- S.Falling Snow Properties (computed as in SISVAT_zAg)
+  ! +     ^^^^^^^^^^^^^^^^^^^^^^^
+        Buf_G1      =  max(-G1_dSV, & ! Temperate Snow
+              min(Dendr1*VV__SV(ikl)-Dendr2, & !     Dendricity
+              Dendr3                   ))    !
+        Buf_G2      =  min( Spher4, & ! Temperate Snow
+              max(Spher1*VV__SV(ikl)+Spher2, & !     Sphericity
+              Spher3                   ))    !
+  ! EV: now control buf_sph_pol and bug_siz_pol in physiq.def
+        Buf_G1      = (1. - Polair) *   Buf_G1 & ! Temperate Snow
+              + Polair  *   buf_sph_pol ! Polar Snow
+        Buf_G2      = (1. - Polair) *   Buf_G2 & ! Temperate Snow
+              + Polair  *   buf_siz_pol ! Polar Snow
+            G1      =                   Buf_G1      ! NO  Blown Snow
+            G2      =                   Buf_G2      ! NO  Blown Snow
+
+
+
+        IF (BloMod) THEN
+
+  ! S.1. Meme  Type  de Neige  / same Grain Type
+  !      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+       SameOK  =  max(zero, &
+             sign(unun,    Buf_G1             *G1_dSV &
+             - eps_21                    ))
+       G1same  = ((1.0-dsnbSV(ikl))*Buf_G1+dsnbSV(ikl) *G1_dSV)
+       G2same  = ((1.0-dsnbSV(ikl))*Buf_G2+dsnbSV(ikl) *ADSdSV)
+        ! Blowing Snow Properties:                         G1_dSV, ADSdSV
+
+  ! S.2. Types differents / differents Types
+  !      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+       typ__1  =  max(zero,sign(unun,epsi-Buf_G1))   ! =1.=> Dendritic
+       zroNEW  =     typ__1  *(1.0-dsnbSV(ikl)) & ! fract.Dendr.Lay.
+             + (1.-typ__1) *     dsnbSV(ikl)       !
+       G1_NEW  =     typ__1  *Buf_G1 & ! G1 of Dendr.Lay.
+             + (1.-typ__1) *G1_dSV                 !
+       G2_NEW  =     typ__1  *Buf_G2 & ! G2 of Dendr.Lay.
+             + (1.-typ__1) *ADSdSV                 !
+       zroOLD  = (1.-typ__1) *(1.0-dsnbSV(ikl)) & ! fract.Spher.Lay.
+             +     typ__1  *     dsnbSV(ikl)       !
+       G1_OLD  = (1.-typ__1) *Buf_G1 & ! G1 of Spher.Lay.
+             +     typ__1  *G1_dSV                 !
+       G2_OLD  = (1.-typ__1) *Buf_G2 & ! G2 of Spher.Lay.
+             +     typ__1  *ADSdSV                 !
+       SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV & ! Size  Dendr.Lay.
+             +(1.+G1_NEW         /G1_dSV) & !
+             *(G2_NEW  *DScdSV/G1_dSV & !
+             +(1.-G2_NEW         /G1_dSV)*DFcdSV)  !
+       SphNEW  =     G2_NEW         /G1_dSV          ! Spher.Dendr.Lay.
+       SizOLD  =     G2_OLD                          ! Size  Spher.Lay.
+       SphOLD  =     G1_OLD         /G1_dSV          ! Spher.Spher.Lay.
+       Siz_av  =     (zroNEW*SizNEW+zroOLD*SizOLD)   ! Averaged Size
+       Sph_av  = min( zroNEW*SphNEW+zroOLD*SphOLD & !
+             ,  unun)                         ! Averaged Sphericity
+       Den_av  = min((Siz_av -(    Sph_av *DScdSV & !
+             +(1.-Sph_av)*DFcdSV)) & !
+             / (DDcdSV -(    Sph_av *DScdSV & !
+             +(1.-Sph_av)*DFcdSV)) & !
+             ,  unun)                       !
+       DendOK  = max(zero, & !
+             sign(unun,     Sph_av *DScdSV & ! Small   Grains
+             +(1.-Sph_av)*DFcdSV & ! Faceted Grains
+             -    Siz_av        )) !
+  ! +...      REMARQUE: le  type moyen (dendritique ou non) depend
+  ! +         ^^^^^^^^  de la  comparaison avec le diametre optique
+  ! +                   d'une neige recente de   dendricite nulle
+  ! +...      REMARK:   the mean type  (dendritic   or not) depends
+  ! +         ^^^^^^    on the comparaison with the optical diameter
+  ! +                   of a recent snow    having zero dendricity
+
+       G1diff  =(   -DendOK *Den_av &
+             +(1.-DendOK)*Sph_av) *G1_dSV
+       G2diff  =     DendOK *Sph_av  *G1_dSV &
+             +(1.-DendOK)*Siz_av
+       G1      =     SameOK *G1same &
+             +(1.-SameOK)*G1diff
+       G2      =     SameOK *G2same &
+             +(1.-SameOK)*G2diff
+       ENDIF
+
+
+
+  ! S.1. Meme  Type  de Neige  / same Grain Type
+  !      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+        SameOK  =  max(zero, &
+              sign(unun,    Buf_G1 *BG1sSV(ikl) &
+              - eps_21                    ))
+        G1same  = (d_Bufs*Buf_G1+BufsSV(ikl)*BG1sSV(ikl)) &
+              /max(epsi,Bufs_N)
+        G2same  = (d_Bufs*Buf_G2+BufsSV(ikl)*BG2sSV(ikl)) &
+              /max(epsi,Bufs_N)
+
+  ! S.2. Types differents / differents Types
+  !      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+        typ__1  =  max(zero,sign(unun,epsi-Buf_G1))   ! =1.=> Dendritic
+        zroNEW  =(    typ__1  *d_Bufs & ! fract.Dendr.Lay.
+              + (1.-typ__1) *BufsSV(ikl)) & !
+              /max(epsi,Bufs_N)                !
+        G1_NEW  =     typ__1  *Buf_G1 & ! G1 of Dendr.Lay.
+              + (1.-typ__1) *BG1sSV(ikl)            !
+        G2_NEW  =     typ__1  *Buf_G2 & ! G2 of Dendr.Lay.
+              + (1.-typ__1) *BG2sSV(ikl)            !
+        zroOLD  =((1.-typ__1) *d_Bufs & ! fract.Spher.Lay.
+              +     typ__1  *BufsSV(ikl)) & !
+              /max(epsi,Bufs_N)                !
+        G1_OLD  = (1.-typ__1) *Buf_G1 & ! G1 of Spher.Lay.
+              +     typ__1  *BG1sSV(ikl)            !
+        G2_OLD  = (1.-typ__1) *Buf_G2 & ! G2 of Spher.Lay.
+              +     typ__1  *BG2sSV(ikl)            !
+        SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV & ! Size  Dendr.Lay.
+              +(1.+G1_NEW         /G1_dSV) & !
+              *(G2_NEW  *DScdSV/G1_dSV & !
+              +(1.-G2_NEW         /G1_dSV)*DFcdSV) !
+        SphNEW  =     G2_NEW         /G1_dSV          ! Spher.Dendr.Lay.
+        SizOLD  =     G2_OLD                          ! Size  Spher.Lay.
+        SphOLD  =     G1_OLD         /G1_dSV          ! Spher.Spher.Lay.
+        Siz_av  =   ( zroNEW  *SizNEW+zroOLD*SizOLD)  ! Averaged Size
+        Sph_av = min( zroNEW  *SphNEW+zroOLD*SphOLD & !
+              ,   unun                       )  ! Averaged Sphericity
+        Den_av = min((Siz_av  - (    Sph_av *DScdSV & !
+              +(1.-Sph_av)*DFcdSV)) & !
+              / (DDcdSV  - (    Sph_av *DScdSV & !
+              +(1.-Sph_av)*DFcdSV)) & !
+              ,   unun                         )!
+        DendOK  = max(zero, & !
+              sign(unun,     Sph_av *DScdSV & ! Small   Grains
+              +(1.-Sph_av)*DFcdSV & ! Faceted Grains
+              -    Siz_av        )) !
+  ! +...      REMARQUE: le  type moyen (dendritique ou non) depend
+  ! +         ^^^^^^^^  de la  comparaison avec le diametre optique
+  ! +                   d'une neige recente de   dendricite nulle
+  ! +...      REMARK:   the mean type  (dendritic   or not) depends
+  ! +         ^^^^^^    on the comparaison with the optical diameter
+  ! +                   of a recent snow    having zero dendricity
+
+        G1diff  =(   -DendOK *Den_av &
+              +(1.-DendOK)*Sph_av) *G1_dSV
+        G2diff  =     DendOK *Sph_av  *G1_dSV &
+              +(1.-DendOK)*Siz_av
+        G1      =     SameOK *G1same &
+              +(1.-SameOK)*G1diff
+        G2      =     SameOK *G2same &
+              +(1.-SameOK)*G2diff
+
+        BG1sSV(ikl) =                       G1 & !
+              *       Bufs_N/max(epsi,Bufs_N) !
+        BG2sSV(ikl) =                       G2 & !
+              *       Bufs_N/max(epsi,Bufs_N) !
+
+
+  ! +--Update of Buffer Layer Content & Decision about creating a new snow layer
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+        BufsSV(ikl) =       Bufs_N                  !     [mm w.e.]
+        NLaysv(ikl) = min(unun, & !
+              max(zero, & ! Allows to create
+              sign(unun,BufsSV(ikl) & ! a new snow Layer
+              -SMndSV     )) & ! if Buffer > SMndSV
+              *max(zero, & ! Except if * Erosion
+              sign(unun,0.50 & ! dominates
+              -dsnbSV(ikl))) & !
+              +max(zero, & ! Allows to create
+              sign(unun,BufsSV(ikl) & ! a new snow Layer
+              -SMndSV*3.00)))  ! is Buffer > SMndSV*3
+        Bdzssv(ikl) = 1.e-3*BufsSV(ikl)*ro_Wat & ! [mm w.e.] -> [m w.e.]
+              /max(epsi,BrosSV(ikl))!& [m w.e.] -> [m]
+
+
+      END DO
+
+
+
+  ! Snow Pack Discretization(option XF in MAR)
+  ! ==========================================
+
+
+  if (discret_xf.AND.klonv==1) then
+
+   if(isnoSV(1)>=1.or.NLaysv(1)>=1) then
+  ! +          **********
+     CALL SISVAT_zSn
+  ! +          **********
+   endif
+  else
+  ! +          **********
+    CALL SISVAT_zSn
+  ! +          **********
+  endif
+
+  ! +          **********
+  ! #ve   CALL SISVAT_wEq('_zSn  ',0)
+  ! +          **********
+
+  ! Add a new Snow Layer
+  ! ====================
+
+      DO ikl=1,knonv
+
+        isnoSV(ikl)     = isnoSV(ikl)         +NLaysv(ikl)
+        isn             = isnoSV(ikl)
+        dzsnSV(ikl,isn) = dzsnSV(ikl,isn) * (1-NLaysv(ikl)) &
+              + Bdzssv(ikl)     *    NLaysv(ikl)
+        TsisSV(ikl,isn) = TsisSV(ikl,isn) * (1-NLaysv(ikl)) &
+              + min(TaT_SV(ikl),Tf_Sno) *NLaysv(ikl)
+        ro__SV(ikl,isn) = ro__SV(ikl,isn) * (1-NLaysv(ikl)) &
+              + Brossv(ikl)     *    NLaysv(ikl)
+        eta_SV(ikl,isn) = eta_SV(ikl,isn) * (1-NLaysv(ikl))   ! + 0.
+        agsnSV(ikl,isn) = agsnSV(ikl,isn) * (1-NLaysv(ikl))   ! + 0.
+        G1snSV(ikl,isn) = G1snSV(ikl,isn) * (1-NLaysv(ikl)) &
+              + BG1ssv(ikl)     *    NLaysv(ikl)
+        G2snSV(ikl,isn) = G2snSV(ikl,isn) * (1-NLaysv(ikl)) &
+              + BG2ssv(ikl)     *    NLaysv(ikl)
+        istoSV(ikl,isn) = istoSV(ikl,isn) * (1-NLaysv(ikl)) &
+              + max(zer0,sign(un_1,TaT_SV(ikl) &
+              -Tf_Sno-eps_21)) *    istdSV(2) &
+              *    NLaysv(ikl)
+        BufsSV(ikl)     = BufsSV(ikl)     * (1-NLaysv(ikl))
+        NLaysv(ikl)     = 0
+
+
+      END DO
+
+
+  ! Snow Pack Thickness
+  ! -------------------
+
+    DO ikl=1,knonv
+        z_snsv(ikl)     = 0.0
+    END DO
+    DO   isn=1,nsno
+      DO ikl=1,knonv
+        z_snsv(ikl)     = z_snsv(ikl) + dzsnSV(ikl,isn)
+        zzsnsv(ikl,isn) = z_snsv(ikl)
+      END DO
+    END DO
+
+
+
+  END IF  ! SnoMod
+
+
+
+  ! Soil Albedo: Soil Humidity Correction
+  ! ==========================================
+
+      ! REFERENCE: McCumber and Pielke (1981), Pielke (1984)
+      ! ^^^^^^^^^
+      DO ikl=1,knonv
+        albssv(ikl) = &
+              alb0SV(ikl) *(1.0-min(half,eta_SV(       ikl,0) &
+              /etadSV(isotSV(ikl))))
+      ! REMARK:    Albedo of Water Surfaces (isotSV=0):
+      ! ^^^^^^     alb0SV := 2  X  effective value, while
+      !            eta_SV :=          etadSV
+      END DO
+
+
+  ! Snow Pack Optical Properties
+  ! ============================
+
+  IF (SnoMod)                                                 THEN
+
+         ! ******
+    CALL SnOptP(jjtime)
+         ! ******
+
+  ELSE
+    DO ikl=1,knonv
+      sEX_sv(ikl,1) = 1.0
+      sEX_sv(ikl,0) = 0.0
+      albisv(ikl)   = albssv(ikl)
+    END DO
+  END IF
+
+
+
+  ! Soil optical properties
+  ! =============================
+  !Etienne: as in inlandis we do not CALL vgopt, we need to define
+  !the albedo alb_SV and to calculate the
+  !absorbed Solar Radiation by Surfac (Normaliz)[-] SoSosv
+
+
+  DO ikl=1,klonv
+
+        e_pRad = 2.5   *  coszSV(ikl)       ! exponential argument,
+                                            ! ! V/nIR radiation partitioning,
+                                            ! ! DR97, 2, eqn (2.53) & (2.54)
+        e1pRad = 1.-exp(-e_pRad)            ! exponential, V/nIR Rad. Part.
+        exdRad= 1.
+
+  ! Visible Part of the Solar Radiation Spectrum (V,   0.4--0.7mi.m)
+        A_Rad0 =      0.25 + 0.697 * e1pRad ! Absorbed    Vis. Radiation
+        absg_V = (1.-albisv(ikl))*(A_Rad0*exdRad)  !
+
+  ! Near-IR Part of the Solar Radiation Spectrum (nIR, 0.7--2.8mi.m)
+
+        A_Rad0 =      0.80 + 0.185 * e1pRad ! Absorbed    nIR. Radiation
+        absgnI = (1.-albisv(ikl))*(A_Rad0*exdRad)  !
+
+        SoSosv(ikl) = (absg_V+absgnI)*0.5d0
+
+        alb_SV(ikl) = albisv(ikl)
+
+  END DO
+
+         ! **********
+  ! #ve   CALL SISVAT_wEq('SnOptP',0)
+         ! **********
+
+
+  ! Surface Emissivity (Etienne: simplified calculation for landice)
+  ! =============================================================
+
+   DO ikl=1,knonv
+        LSnMsk     =     min( 1,isnoSV(ikl))
+        Eso_sv(ikl)=  EmiSol*(1-LSnMsk)+EmiSno*LSnMsk  ! Sol+Sno Emissivity
+        emi_SV(ikl)= EmiSol*(1-LSnMsk) + EmiSno*LSnMsk
+    END DO
+
+
+
+
+  !  Upward IR (INPUT, from previous time step)
+  ! ===================================================================
+
+    DO ikl=1,knonv
+  ! #e1     Enrsvd(ikl) =    - IRs_SV(ikl)
+       IRupsv(ikl) =      IRs_SV(ikl)
+    END DO
+
+
+  ! Turbulence
+  ! ==========
+
+  ! Latent Heat of Vaporization/Sublimation
+  ! ---------------------------------------
+
+    DO ikl=1,knonv
+      SnoWat      =                     min(isnoSV(ikl),0)
+      Lx_H2O(ikl) = &
+            (1.-SnoWat) * LhvH2O &
+            +     SnoWat  *(LhsH2O * (1.-eta_SV(ikl,isnoSV(ikl))) &
+            +LhvH2O *     eta_SV(ikl,isnoSV(ikl)) )
+    END DO
+
+
+
+
+  ! Aerodynamic Resistance (calculated from drags given by LMDZ)
+  ! Commented because already calculated in surf_inlandsis_mod
+  ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    ! DO ikl=1,knonv
+    !    ram_sv(ikl) = 1./(cdM_SV(ikl)*max(VV__SV(ikl),eps6))
+    !    rah_sv(ikl) = 1./(cdH_SV(ikl)*max(VV__SV(ikl),eps6))
+    !  END DO
+
+
+
+  ! Soil   Energy Balance
+  ! =====================
+
+
+  if (iflag_temp_inlandsis == 0) then
+
+   CALL SISVAT_TSo
+
+  else
+    DO ikl=1,knonv
+    Tsf_SV(ikl)=Tsrfsv(ikl)
+    END DO
+
+   CALL SISVAT_TS2
+
+  end if
+
+
+         ! **********
+  ! #ve   CALL SISVAT_wEq('_TSo  ',0)
+         ! **********
+
+
+
+  ! Soil Water     Potential
+  ! ------------------------
+
+  DO   isl=-nsol,0
+    DO ikl=1,knonv
+      ist             =     isotSV(ikl)        ! Soil Type
+      psi_sv(ikl,isl) =     psidSV(ist) & ! DR97, Eqn.(3.34)
+            *(etadSV(ist) /max(eps6,eta_SV(ikl,isl))) & !
+            **bCHdSV(ist)                              !
+
+
+  ! Soil Hydraulic Conductivity
+  ! ---------------------------
+
+      Khydsv(ikl,isl) =    s2__SV(ist) & ! DR97, Eqn.(3.35)
+            *(eta_SV(ikl,isl)**(2.*bCHdSV(ist)+3.))    !
+    END DO
+  END DO
+
+
+  ! Melting / Refreezing in the Snow Pack
+  ! =====================================
+
+  IF (SnoMod)                                                 THEN
+
+         ! **********
+    CALL SISVAT_qSn
+         ! **********
+
+         ! **********
+  ! #ve   CALL SISVAT_wEq('_qSn  ',0)
+         ! **********
+
+
+  ! Snow Pack Thickness
+  ! -------------------
+
+      DO ikl=1,knonv
+        z_snsv(ikl)     = 0.0
+      END DO
+    DO   isn=1,nsno
+      DO ikl=1,knonv
+        z_snsv(ikl)     = z_snsv(ikl) + dzsnSV(ikl,isn)
+        zzsnsv(ikl,isn) = z_snsv(ikl)
+      END DO
+    END DO
+
+
+  ! Energy in Excess is added to the first Soil Layer
+  ! -------------------------------------------------
+    DO ikl=1,knonv
+        z_snsv(ikl)   = max(zer0, &
+              sign(un_1,eps6-z_snsv(ikl)))
+        TsisSV(ikl,0) = TsisSV(ikl,0)    + EExcsv(ikl) &
+              /(rocsSV(isotSV(ikl)) &
+              +rcwdSV*eta_SV(ikl,0))
+        EExcsv(ikl)   = 0.
+    END DO
+
+
+  END IF
+
+
+  ! Soil   Water  Balance
+  ! =====================
+
+         ! **********
+    CALL SISVAT_qSo
+  ! #m0.                 (Wats_0,Wats_1,Wats_d)
+         ! **********
+
+
+  ! Surface Fluxes
+  ! =====================
+
+    DO ikl=1,knonv
+     IRdwsv(ikl)=IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR
+      ! IRdwsv(ikl)=tau_sv(ikl) *IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR
+  !    .          +(1.0-tau_sv(ikl))*IRd_SV(ikl)*Evg_sv(ikl) !  ! Etienne, remove vegetation component
+      IRupsv(ikl) =      IRupsv(ikl)                   ! Upward   IR
+      IRu_SV(ikl) =     -IRupsv(ikl) & ! Upward   IR
+            +IRd_SV(ikl) & ! (effective)
+            -IRdwsv(ikl)                   ! (positive)
+
+      TBr_sv(ikl) =sqrt(sqrt(IRu_SV(ikl)/StefBo))      ! Brightness
+                                                       ! ! Temperature
+      uts_SV(ikl) =     (HSv_sv(ikl) +HSs_sv(ikl)) & ! u*T*
+            /(rhT_SV(ikl) *cp)          !
+      uqs_SV(ikl) =     (HLv_sv(ikl) +HLs_sv(ikl)) & ! u*q*
+            /(rhT_SV(ikl) *LhvH2O)          !
+      LMO_SV(ikl) = TaT_SV(ikl)*(us__SV(ikl)**3) &
+            /gravit/uts_SV(ikl)/vonKrm      ! MO length
+
+
+  ! Surface Temperature
+  ! ^^^^^^^^^^^^^^^^^^^^
+
+      IF (iflag_tsurf_inlandsis == 0) THEN
+
+        Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl))
+
+      ELSE IF (iflag_tsurf_inlandsis > 0) THEN
+  ! Etienne: extrapolation from the two uppermost levels:
+
+     if (isnoSV(ikl) >=2) then
+       zm1=-dzsnSV(ikl,isnoSV(ikl))/2.
+       zm2=-(dzsnSV(ikl,isnoSV(ikl)) + dzsnSV(ikl,isnoSV(ikl)-1)/2.)
+     else if (isnoSV(ikl) == 1) then
+       zm1=-dzsnSV(ikl,isnoSV(ikl))/2.
+       zm2=-(dzsnSV(ikl,isnoSV(ikl))+dz_dSV(0)/2.)
+     else
+       zm1=-dz_dSV(0)/2.
+       zm2=-(dz_dSV(0)+dz_dSV(-1)/2.)
+
+     end if
+
+       coefslope=(TsisSV(ikl,isnoSV(ikl))-TsisSV(ikl,isnoSV(ikl)-1)) &
+             /(zm1-zm2)
+       Tsrfsv(ikl)=TsisSV(ikl,isnoSV(ikl))+coefslope*(0. - zm1)
+
+
+     ELSE !(default)
+
+       Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl))
+
+     END IF
+
+
+     END DO
+
+  ! Snow Pack Properties (sphericity, dendricity, size)
+  ! ===================================================
+
+  IF (SnoMod)                                                 THEN
+
+  if (discret_xf .AND. klonv==1) then
+  if(isnoSV(1)>=1) then
+  ! +          **********
+  CALL SISVAT_GSn
+  ! +          **********
+  endif
+  else
+  ! +          **********
+    CALL SISVAT_GSn
+  ! +          **********
+  endif
+
+
+  END IF
+
+
+  ! Roughness Length for next time step
+  !====================================
+
+  ! Note that in INLANDSIS, we treat only ice covered surfaces so calculation
+  ! of z0 is much simpler (no subgrid fraction of ocean or land)
+  ! old calculations are commented below
+
+
+  ! +--Roughness Length for Momentum
+  ! +  -----------------------------
+
+  ! ETIENNE WARNING: changes have been made wrt original SISVAT
+
+  ! +--Land+Sea-Ice / Ice-free Sea Mask
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=1,knonv
+      IcIndx(ikl) = 0
+    ENDDO
+    DO isn=1,nsno
+    DO ikl=1,knonv
+
+      IcIndx(ikl) = max(IcIndx(ikl), &
+            isn*max(0, &
+            sign(1, &
+            int(ro__SV(ikl,isn)-900.))))
+    ENDDO
+    ENDDO
+
+    DO ikl=1,knonv
+      LISmsk    =     1. ! in inlandsis, land only
+      IceMsk    =     max(0,sign(1   ,IcIndx(ikl)-1)  )
+      SnoMsk    = max(min(isnoSV(ikl)-iiceSV(ikl),1),0)
+
+
+  ! +--Z0 Smooth Regime over Snow (Andreas 1995, CRREL Report 95-16, p. 8)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+      Z0m_nu =       5.e-5 ! z0s~(10-d)*exp(-vonkar/sqrt(1.1e-03))
+
+  ! +--Z0 Saltat.Regime over Snow (Gallee  et al., 2001, BLM 99 (19) p.11)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      u2star =       us__SV(ikl) *us__SV(ikl)
+      Z0mBSn =       u2star      *0.536e-3   -  61.8e-6
+      Z0mBSn =   max(Z0mBS0      ,Z0mBSn)
+
+  ! +--Z0 Smooth + Saltat. Regime
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+      Z0enSV(ikl) =  Z0m_nu &
+            +  Z0mBSn
+
+
+  ! Calculation of snow roughness length
+  !=====================================
+      IF (iflag_z0m_snow == 0) THEN
+
+      Z0m_Sn=prescribed_z0m_snow
+
+      ELSE IF (iflag_z0m_snow == 1) THEN
+
+      Z0m_Sn=Z0enSV(ikl)
+
+      ELSE IF (iflag_z0m_snow == 2) THEN
+
+  ! +--Rough   Snow Surface Roughness Length (Variable Sastrugi Height)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      A_Fact      =  1.0000        ! Andreas et al., 2004, p.4
+                                   ! ! ams.confex.com/ams/pdfpapers/68601.pdf
+
+  ! Parameterization of z0 dependance on Temperature (C. Amory, 2017)
+  ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ! Z0=f(T) deduced from observations, Adelie Land, dec2012-dec2013
+
+
+      coefa = 0.1658 !0.1862 !Ant
+      coefb = -50.3869 !-55.7718 !Ant
+      ta1 = 253.15 !255. Ant
+      ta2 = 273.15
+      ta3 = 273.15+3
+      z01 = exp(coefa*ta1 + coefb) !~0.2 ! ~0.25 mm
+      z02 = exp(coefa*ta2 + coefb) !~6  !~7 mm
+      z03 = z01
+      coefc = log(z03/z02)/(ta3-ta2)
+      coefd = log(z03)-coefc*ta3
+
+      if (TaT_SV(ikl) < ta1) then
+        Z0_obs = z01
+      else if (TaT_SV(ikl)>=ta1 .and. TaT_SV(ikl)<ta2) then
+        Z0_obs = exp(coefa*TaT_SV(ikl) + coefb)
+      else if (TaT_SV(ikl)>=ta2 .and. TaT_SV(ikl)<ta3) then
+        ! ! if st > 0, melting induce smooth surface
+        Z0_obs = exp(coefc*TaT_SV(ikl) + coefd)
+      else
+        Z0_obs = z03
+      endif
+
+      Z0m_Sn=Z0_obs
+
+
+      ELSE
+
+      Z0m_Sn=0.500e-3  ! default=0.500e-3m (tuning of MAR)
+
+      ENDIF
+
+
+
+       ! param = Z0_obs/1. ! param(s) | 1.(m/s)=TUNING
+  ! #SZ     Z0Sa_N =                   (us__SV(ikl) -0.2)*param   ! 0.0001=TUNING
+  ! #SZ.           * max(zero,sign(unun,TfSnow-eps9
+  ! #SZ.                               -TsisSV(ikl , isnoSV(ikl))))
+  !!#SZ     Z0SaSi = max(zero,sign(unun,Z0Sa_N                  ))! 1 if erosion
+  ! #SZ     Z0SaSi = max(zero,sign(unun,zero  -eps9 -uss_SV(ikl)))!
+  ! #SZ     Z0Sa_N = max(zero,          Z0Sa_N)
+  ! #SZ     Z0SaSV(ikl) =
+  ! #SZ.             max(Z0SaSV(ikl)   ,Z0SaSV(ikl)
+  ! #SZ.               + Z0SaSi*(Z0Sa_N-Z0SaSV(ikl))*exp(-dt__SV/43200.))
+  ! #SZ.               -            min(dz0_SV(ikl) ,     Z0SaSV(ikl))
+
+  ! #SZ     A_Fact      =               Z0SaSV(ikl) *  5.0/0.15   ! A=5 if h~10cm
+  ! +...    CAUTION: The influence of the sastrugi direction is not yet included
+
+  ! #SZ     Z0m_Sn =                    Z0SaSV(ikl)               !
+  ! #SZ.                              - Z0m_nu                    !
+
+  ! +--Z0 Saltat.Regime over Snow (Shao & Lin, 1999, BLM 91 (46)  p.222)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+  ! #ZN     sqrrZ0 =       usthSV(ikl)/max( us__SV(ikl),0.001)
+  ! #ZN     sqrrZ0 =                   min( sqrrZ0     ,0.999)
+  ! #ZN     Z0mBSn =       0.55 *0.55 *exp(-sqrrZ0     *sqrrZ0)
+  ! #ZN.                  *us__SV(ikl)*     us__SV(ikl)*grvinv*0.5
+
+  ! +--Z0 Smooth + Saltat. Regime (Shao & Lin, 1999, BLM 91 (46)  p.222)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+  ! #ZN     Z0enSV(ikl) = (Z0m_nu     **    sqrrZ0 )
+  ! #ZN.                * (Z0mBSn     **(1.-sqrrZ0))
+  ! #ZN     Z0enSV(ikl) =  max(Z0enSV(ikl), Z0m_nu)
+
+
+  ! +--Z0 Smooth Regime over Snow (Andreas etAl., 2004
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^  ams.confex.com/ams/pdfpapers/68601.pdf)
+  ! #ZA     Z0m_nu = 0.135*akmol  / max(us__SV(ikl) , epsi)
+
+  ! +--Z0 Saltat.Regime over Snow (Andreas etAl., 2004
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^  ams.confex.com/ams/pdfpapers/68601.pdf)
+  ! #ZA     Z0mBSn = 0.035*u2star      *grvinv
+
+  ! +--Z0 Smooth + Saltat. Regime (Andreas etAl., 2004
+  !    (      used by Erosion)     ams.confex.com/ams/pdfpapers/68601.pdf)
+  !    ^^^^^^^^^^^^^^^^^^^^^^^^^^
+  ! #ZA     Z0enSV(ikl) =  Z0m_nu
+  ! #ZA.                +  Z0mBSn
+
+  ! +--Z0 Rough  Regime over Snow (Andreas etAl., 2004
+  ! +  (.NOT. used by Erosion)     ams.confex.com/ams/pdfpapers/68601.pdf)
+  !    ^^^^^^^^^^^^^^^^^^^^^^^^^^
+  !!#ZA     u2star =      (us__SV(ikl) -0.1800)     / 0.1
+  !!#ZA     Z0m_Sn =A_Fact*Z0mBSn *exp(-u2star*u2star)
+  ! #ZA     Z0m_90 =(10.-0.025*VVs_SV(ikl)/5.)
+  ! #ZA.            *exp(-0.4/sqrt(.00275+.00001*max(0.,VVs_SV(ikl)-5.)))
+  ! #ZA     Z0m_Sn =           DDs_SV(ikl)* Z0m_90 / 45.
+  ! #ZA.         - DDs_SV(ikl)*DDs_SV(ikl)* Z0m_90 /(90.*90.)
+
+
+
+
+  ! +--Z0  (Erosion)    over Snow (instantaneous)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+      Z0e_SV(ikl) =  Z0enSV(ikl)
+
+  ! +--Momentum  Roughness Length (Etienne: changes wrt original SISVAT)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      Z0mnSV(ikl) =  Z0m_nu *(1-SnoMsk) & ! Ice z0
+            + (Z0m_Sn)*SnoMsk                         ! Snow Sastrugi Form and Snow Erosion
+
+
+  ! +--GIS  Roughness Length
+  ! +  ^^^^^^^^^^^^^^^^^^^^^
+  ! #GL     Z0mnSV(ikl) =
+  ! #GL.      (1-LSmask(ikl)) *     Z0mnSV(ikl)
+  ! #GL.    +    LSmask(ikl)  * max(Z0mnSV(ikl),max(Z0_GIM,
+  ! #GL.                                            Z0_GIM+
+  ! #GL.      (0.0032-Z0_GIM)*(ro__SV(ikl,isnoSV(ikl))-600.)   !
+  ! #GL.                     /(920.00                 -600.))) !
+
+  ! +--Mom. Roughness Length, Instantaneous
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      Z0m_SV(ikl) =  Z0mnSV(ikl)                         ! Z0mnSV  instant.
+
+
+  ! +--Roughness Length for Scalars
+  ! +  ----------------------------
+
+      Z0hnSV(ikl) =     Z0mnSV(ikl)/  7.4
+
+      IF (is_ok_z0h_rn) THEN
+
+      rstar       =     Z0mnSV(ikl) * us__SV(ikl) / akmol
+      rstar       = max(epsi,min(rstar,R_1000))
+      alors       =          log(rstar)
+      rstar0      = 1.250e0 * max(zero,sign(unun,0.135e0 - rstar)) &
+            +(1.      - max(zero,sign(unun,0.135e0 - rstar))) &
+            *(0.149e0 * max(zero,sign(unun,2.500e0 - rstar)) &
+            + 0.317e0 &
+            *(1.      - max(zero,sign(unun,2.500e0 - rstar))))
+      rstar1      = 0.      * max(zero,sign(unun,0.135e0 - rstar)) &
+            +(1.      - max(zero,sign(unun,0.135e0 - rstar))) &
+            *(-0.55e0 * max(zero,sign(unun,2.500e0 - rstar)) &
+            - 0.565 &
+            *(1.      - max(zero,sign(unun,2.500e0 - rstar))))
+      rstar2      = 0.      * max(zero,sign(unun,0.135e0 - rstar)) &
+            +(1.      - max(zero,sign(unun,0.135e0 - rstar))) &
+            *(0.      * max(zero,sign(unun,2.500e0 - rstar)) &
+            - 0.183 &
+            *(unun    - max(zero,sign(unun,2.500e0 - rstar))))
+
+
+
+  !XF    #RN (is_ok_z0h_rn) does not work well over bare ice
+  !XF    MAR is then too warm and not enough melt
+
+     if(ro__SV(ikl,isnoSV(ikl))>50 &
+           .and.ro__SV(ikl,isnoSV(ikl))<roSdSV)then
+
+         Z0hnSV(ikl) = max(zero &
+               , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi)) &
+               * exp(rstar0+rstar1*alors+rstar2*alors*alors) &
+               * 0.001e0 + Z0hnSV(ikl) * ( 1. - max(zero &
+               , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi)))
+
+      endif
+
+
+      ENDIF
+
+      Z0h_SV(ikl) =     Z0hnSV(ikl)
+
+
+  ! #MT     Z0m_SV(ikl) = max(2.0e-6     ,Z0m_SV(ikl)) ! Min Z0_m (Garrat Scheme)
+       ! Z0m_SV(ikl) = min(Z0m_SV(ikl),za__SV(ikl)*0.3333)
+
+
+   END DO
+
+
+
+end subroutine inlandsis
+
+
+
+
+
+
+
+
+
+
+
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_bsn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_bsn.F	(revision 5104)
+++ 	(revision )
@@ -1,108 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_BSn
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_BSn                               04-apr-2020  MAR |
-C |   SubRoutine SISVAT_BSn treats Snow Erosion                            |
-C |   (not deposition anymore since 2-jun 2018)                            |
-C |                                                                        |
-C |   SISVAT_bsn computes the snow erosion mass according to both the      |
-C |   theoretical maximum erosion amount computed in inlandsis and the     |
-C |   availability of snow (currently in the uppermost snow layer only)    |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--General Variables
-C +  =================
-
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VARxSV
-      use VARySV
- 
- 
-       IMPLICIT NONE
-
-C +--Local Variables
-C +  ===============
- 
- 
-      integer  ikl   ,isn
-      real     h_mmWE                        ! Eroded Snow Layer Min Thickness
-      real     dbsaux(knonv)                 ! Drift Amount   (Dummy Variable)
-      real     dzweqo,dzweqn,bsno_x          ! Conversion variables for erosion
-      real     dz_new,rho_new
-      real     snofOK                        ! Threshd Snow Fall
-      real     Fac                           ! Correction factor for erosion
-      real     densif                        ! Densification rate if erosion
- 
-C +--DATA
-C +  ====
- 
-      data     h_mmWE  / 0.01e00  /          ! Eroded Snow Layer Min Thickness
- 
-C +--EROSION
-C +  =======
- 
-      !DO isn = nsno,2,-1
-      DO ikl = 1,knonv
- 
-        isn         = isnoSV(ikl)
-        dzweqo      = dzsnSV(ikl,isn) *ro__SV(ikl,isn)      ! [kg/m2, mm w.e.]
- 
-        bsno_x      = min(0.,dbs_SV(ikl))
-c       Fac         = min(1.,max(1-(ro__SV(ikl,isn)/700.),0.)**2)
-c       Fac         = min(1.,max(1-(qsnoSV(ikl)*1000/30.),0.))
-c       bsno_x      = bsno_x*Fac
- 
-        dzweqn      = dzweqo + bsno_x
-        dzweqn      = max(dzweqn,h_mmWE)
-        dzweqn      = min(dzweqn,dzweqo)
-cXF
-        dbs_SV(ikl) = dbs_SV(ikl)    +(dzweqo -dzweqn)
-        dbs_Er(ikl) = dbs_Er(ikl)    +(dzweqo -dzweqn)
-        dzsnSV(ikl,isn) =              dzweqn
-     .                       /max(epsi,ro__SV(ikl,isn))
- 
-        ! Densification of the uppermost snow layer if erosion:
-        if((dzweqo-dzweqn)>0                    .and.
-     .     dzsnSV(ikl,isn)>0                    .and.
-     .     ro__SV(ikl,max(1,isnoSV(ikl)))<roBdSV) then
- 
-        !characteristic time scale for drifting snow compaction set to 24h
-        !linear densification rate [kg/m3/s] over 24h
-        densif         = (450. - frsno) / (3600*24)
- 
-        !Attenuation of compaction rate from 450 to 500 kg/m3
-        Fac         = 1-((ro__SV(ikl,max(1,isnoSV(ikl)))
-     .                        -roBdSV)/(500.-roBdSV))
-        Fac         = max(0.,min(1.,Fac))
- 
-        if (ro__SV(ikl,max(1,isnoSV(ikl)))>roBdSV) then
-          densif=densif*Fac
-        endif
- 
-        rho_new        = min(roBdSV,ro__SV(ikl,isn)+densif*dt__SV)
-        dz_new         = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/rho_new
-        ro__SV(ikl,isn)=rho_new
-        dzsnSV(ikl,isn)=dz_new
-        endif
- 
-        if(dzsnSV(ikl,isn)>0 .and.dzsnSV(ikl,isn)<0.0001)then
-        dbs_SV(ikl) = dbs_SV(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn)
-        dbs_Er(ikl) = dbs_Er(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn)
-        dzsnSV(ikl,isn) = 0
-        ro__SV(ikl,isn) = 0
-        isnoSV(ikl)     = max(0,isnoSV(ikl) - 1)
-        endif
- 
-      END DO
-      !END DO
- 
-      return
-      END
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_bsn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_bsn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_bsn.f90	(revision 5105)
@@ -0,0 +1,108 @@
+
+
+SUBROUTINE SISVAT_BSn
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_BSn                               04-apr-2020  MAR |
+  ! |   SubRoutine SISVAT_BSn treats Snow Erosion                            |
+  ! |   (not deposition anymore since 2-jun 2018)                            |
+  ! |                                                                        |
+  ! |   SISVAT_bsn computes the snow erosion mass according to both the      |
+  ! |   theoretical maximum erosion amount computed in inlandsis and the     |
+  ! |   availability of snow (currently in the uppermost snow layer only)    |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--General Variables
+  ! +  =================
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VARxSV
+  use VARySV
+
+
+   IMPLICIT NONE
+
+  ! +--Local Variables
+  ! +  ===============
+
+
+  integer :: ikl   ,isn
+  real :: h_mmWE                        ! Eroded Snow Layer Min Thickness
+  real :: dbsaux(knonv)                 ! Drift Amount   (Dummy Variable)
+  real :: dzweqo,dzweqn,bsno_x          ! Conversion variables for erosion
+  real :: dz_new,rho_new
+  real :: snofOK                        ! Threshd Snow Fall
+  real :: Fac                           ! Correction factor for erosion
+  real :: densif                        ! Densification rate if erosion
+
+  ! +--DATA
+  ! +  ====
+
+  data     h_mmWE  / 0.01e00  /          ! Eroded Snow Layer Min Thickness
+
+  ! +--EROSION
+  ! +  =======
+
+  ! !DO isn = nsno,2,-1
+  DO ikl = 1,knonv
+
+    isn         = isnoSV(ikl)
+    dzweqo      = dzsnSV(ikl,isn) *ro__SV(ikl,isn)      ! [kg/m2, mm w.e.]
+
+    bsno_x      = min(0.,dbs_SV(ikl))
+    ! Fac         = min(1.,max(1-(ro__SV(ikl,isn)/700.),0.)**2)
+    ! Fac         = min(1.,max(1-(qsnoSV(ikl)*1000/30.),0.))
+    ! bsno_x      = bsno_x*Fac
+
+    dzweqn      = dzweqo + bsno_x
+    dzweqn      = max(dzweqn,h_mmWE)
+    dzweqn      = min(dzweqn,dzweqo)
+  !XF
+    dbs_SV(ikl) = dbs_SV(ikl)    +(dzweqo -dzweqn)
+    dbs_Er(ikl) = dbs_Er(ikl)    +(dzweqo -dzweqn)
+    dzsnSV(ikl,isn) =              dzweqn &
+          /max(epsi,ro__SV(ikl,isn))
+
+    ! ! Densification of the uppermost snow layer if erosion:
+    if((dzweqo-dzweqn)>0                    .and. &
+          dzsnSV(ikl,isn)>0                    .and. &
+          ro__SV(ikl,max(1,isnoSV(ikl)))<roBdSV) then
+
+    ! !characteristic time scale for drifting snow compaction set to 24h
+    ! !linear densification rate [kg/m3/s] over 24h
+    densif         = (450. - frsno) / (3600*24)
+
+    ! !Attenuation of compaction rate from 450 to 500 kg/m3
+    Fac         = 1-((ro__SV(ikl,max(1,isnoSV(ikl))) &
+          -roBdSV)/(500.-roBdSV))
+    Fac         = max(0.,min(1.,Fac))
+
+    if (ro__SV(ikl,max(1,isnoSV(ikl)))>roBdSV) then
+      densif=densif*Fac
+    endif
+
+    rho_new        = min(roBdSV,ro__SV(ikl,isn)+densif*dt__SV)
+    dz_new         = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/rho_new
+    ro__SV(ikl,isn)=rho_new
+    dzsnSV(ikl,isn)=dz_new
+    endif
+
+    if(dzsnSV(ikl,isn)>0 .and.dzsnSV(ikl,isn)<0.0001)then
+    dbs_SV(ikl) = dbs_SV(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn)
+    dbs_Er(ikl) = dbs_Er(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn)
+    dzsnSV(ikl,isn) = 0
+    ro__SV(ikl,isn) = 0
+    isnoSV(ikl)     = max(0,isnoSV(ikl) - 1)
+    endif
+
+  END DO
+  ! !END DO
+
+
+END SUBROUTINE SISVAT_BSn
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_gsn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_gsn.F	(revision 5104)
+++ 	(revision )
@@ -1,925 +1,0 @@
-  
-      SUBROUTINE SISVAT_GSn
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_GSn                                20-09-2003  MAR |
-C |   SubRoutine SISVAT_GSn simulates SNOW Metamorphism                    |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
-C |   OUTPUT:  iiceSV   = total Nb of Ice      Layers                      |
-C |   ^^^^^^   istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
-C |                                                                        |
-C |   INPUT:   TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
-C |   ^^^^^             & Snow     Temperatures (layers  1,2,...,nsno) [K] |
-C |            ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
-C |            eta_SV   : Soil/Snow Water   Content                [m3/m3] |
-C |            slopSV   : Surface Slope                                [-] |
-C |            dzsnSV   : Snow Layer        Thickness                  [m] |
-C |            dt__SV2   : Time  Step                                   [s] |
-C |                                                                        |
-C |   INPUT /  G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
-C |   OUTPUT:  G2snSV   : Sphericity (>0) or Size            of Snow Layer |
-C |   ^^^^^^                                                               |
-C |                                                                        |
-C |   Formalisme adopte pour la Representation des Grains:                 |
-C |   Formalism         for the Representation of  Grains:                 |
-C |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                 |
-C |                                                                        |
-C |             1       - -1                 Neige Fraiche                 |
-C |            / \      |                    -------------                 |
-C |           /   \     |  Dendricite        decrite  par Dendricite       |
-C |          /     \    |  Dendricity                  et Sphericite       |
-C |         /       \   |                                                  |
-C |        2---------3  -  0                 described by Dendricity       |
-C |                                                   and Sphericity       |
-C |        |---------|                                                     |
-C |        0         1                                                     |
-C |        Sphericite                                                      |
-C |        Sphericity                                                      |
-C |                                                                        |
-C |        4---------5  -                                                  |
-C |        |         |  |                                                  |
-C |        |         |  |  Diametre (1/10eme de mm) (ou Taille)            |
-C |        |         |  |  Diameter (1/10th  of mm) (or Size  )            |
-C |        |         |  |                                                  |
-C |        |         |  |                    Neige non dendritique         |
-C |        6---------7  -                    ---------------------         |
-C |                                          decrite  par Sphericite       |
-C |                                                    et     Taille       |
-C |                                          described by Sphericity       |
-C |                                                   and       Size       |
-C |                                                                        |
-C |   Les Variables du Modele:                                             |
-C |   Model         Variables:                                             |
-C |   ^^^^^^^^^^^^^^^^^^^^^^^^                                             |
-C |     Cas Dendritique               Cas non Dendritique                  |
-C |                                                                        |
-C |     G1snSV        : Dendricite    G1snSV        : Sphericite           |
-C |     G2snSV        : Sphericite    G2snSV        : Taille (1/10e mm)    |
-C |                                                   Size                 |
-C |                                                                        |
-C |   Cas Dendritique/ Dendritic Case                                      |
-C |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                                      |
-C |   Dendricite(Dendricity) G1snSV                                        |
-C |            varie     de -G1_dSV (-99 par defaut / etoile)          a 0 |
-C |            division par -G1_dSV pour obtenir des valeurs entre 1  et 0 |
-C |            varies  from -G1_dSV (default -99    / fresh snow)     to 0 |
-C |            division  by -G1_dSV to obtain values       between 1 and 0 |
-C |                                                                        |
-C |   Sphericite(Sphericity) G2snSV                                        |
-C |            varie     de  0         (cas completement anguleux)         |
-C |                       a  G1_dSV (99 par defaut, cas spherique)         |
-C |            division par  G1_dSV pour obtenir des valeurs entre 0  et 1 |
-C |            varies  from  0      (full faceted)               to G1_dSV |
-C |                                                                        |
-C |   Cas non Dendritique / non Dendritic Case                             |
-C |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                             |
-C |   Sphericite(Sphericity) G1snSV                                        |
-C |            varie     de  0         (cas completement anguleux)         |
-C |                       a  G1_dSV (99 par defaut, cas spherique)         |
-C |            division par  G1_dSV pour obtenir des valeurs entre 0  et 1 |
-C |            varies  from  0      (full faceted)               to G1_dSV |
-C |                                                                        |
-C |   Taille    (Size)       G2snSV                                        |
-C |            superieure a  ADSdSV (.4 mm) et ne fait que croitre         |
-C |            greater than  ADSdSV (.4 mm) always increases               |
-C |                                                                        |
-C |   Exemples: Points caracteristiques des Figures ci-dessus              |
-C |   ^^^^^^^^^                                                            |
-C |                                                                        |
-C |               G1snSV    G2snSV     dendricite  sphericite  taille      |
-C |                                    dendricity  sphericity  size        |
-C |   ------------------------------------------------------------------   |
-C |                                                            [1/10 mm]   |
-C |     1        -G1_dSV    sph3SN          1           0.5                |
-C |     2           0         0             0           0                  |
-C |     3           0       G1_dSV          0           1                  |
-C |     4           0       ADSdSV                      0       4.         |
-C |     5         G1_dSV    ADSdSV-vsphe1               1       3.         |
-C |     6           0         --                        0       --         |
-C |     7         G1_dSV      --                        1       --         |
-C |                                                                        |
-C |   par defaut: G1_dSV=99.                                               |
-C |                         sph3SN=50.                                     |
-C |                         ADSdSV= 4.                                     |
-C |                                vsphe1=1.                               |
-C |                                                                        |
-C |   Methode:                                                             |
-C |   ^^^^^^^^                                                             |
-C |   1. Evolution Types de Grains selon Lois de Brun et al. (1992):       |
-C |      Grain metamorphism according to         Brun et al. (1992):       |
-C |      Plusieurs Cas sont a distiguer  /  the different Cases are:       |
-C |       1.1 Metamorphose Neige humide  /  wet Snow                       |
-C |       1.2 Metamorphose Neige seche   /  dry Snow                       |
-C |         1.2.1 Gradient faible        /  low      Temperature Gradient  |
-C |         1.2.2 Gradient moyen         /  moderate Temperature Gradient  |
-C |         1.2.3 Gradient fort          /  high     Temperature Gradient  |
-C |      Dans chaque Cas on separe Neige Dendritique et non Dendritique    |
-C |                           le Passage Dendritique -> non Dendritique    |
-C |                           se fait lorsque  G1snSV devient > 0          |
-C |      the Case of Dentritic or non Dendritic Snow is treated separately |
-C |      the Limit   Dentritic -> non Dendritic is reached when G1snSV > 0 |
-C |                                                                        |
-C |   2. Tassement: Loi de Viscosite adaptee selon le Type de Grains       |
-C |      Snow Settling:    Viscosity depends on the   Grain Type           |
-C |                                                                        |
-C |   3. Update Variables historiques (cas non dendritique seulement)      |
-C |      nhSNow defaut                                                     |
-C |                0    Cas normal                                         |
-C |      istdSV(1) 1    Grains anguleux / faceted cristal                  |
-C |      istdSV(2) 2    Grains ayant ete en presence d eau liquide         |
-C |                     mais n'ayant pas eu de caractere anguleux    /     |
-C |                     liquid water and no faceted cristals before        |
-C |      istdSV(3) 3    Grains ayant ete en presence d eau liquide         |
-C |                     ayant eu auparavant un caractere anguleux    /     |
-C |                     liquid water and    faceted cristals before        |
-C |                                                                        |
-C |   REFER. : Brun et al.      1989, J. Glaciol 35 pp. 333--342           |
-C |   ^^^^^^^^ Brun et al.      1992, J. Glaciol 38 pp.  13-- 22           |
-C |            (CROCUS Model, adapted to MAR at CEN by H.Gallee)           |
-C |                                                                        |
-C |   REFER. : Marbouty, D.     1980, J. Glaciol 26 pp. xxx--xxx           |
-C |   ^^^^^^^^ (CROCUS Model, adapted to MAR at CEN by H.Gallee)           |
-C |            (for angular shapes)                                        |
-C |                                                                        |
-C |   Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
-C |   ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
-C |   FILE                 |      CONTENT                                  |
-C |   ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
-C | # SISVAT_GSn.vp        | #vp: OUTPUT/Verification: Snow   Properties   |
-C |                        |      unit 47, SubRoutines SISVAT_zSn, _GSn    |
-C | # stdout               | #wp: OUTPUT/Verification: Snow   Properties   |
-C |                        |      unit  6, SubRoutine  SISVAT_GSn          |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
-
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VAR0SV
-      use VARxSV
-      use VARtSV
-
-  
-      IMPLICIT NONE
-  
-     
- 
-C +--INPUT/OUTPUT
-C +  ------------
- 
- 
-C +--OUTPUT
-C +  ------
- 
-      integer   dt__SV2
- 
- 
-C +--Local  Variables
-C +  ================
- 
-      logical   vector                        !
-      integer   ikl                           !
-      integer   isn   ,isnp                   !
-      integer   istoOK                        !
-      real      G1_bak,G2_bak                 ! Old Values of G1, G2
-      real      ro_dry(knonv,      nsno)      ! Dry Density            [g/cm3]
-      real      etaSno(knonv,      nsno)      ! Liquid Water Content   [g/cm2]
-      real      SnMass(knonv)                 ! Snow   Mass            [kg/m2]
-      real      dTsndz                        ! Temperature Gradient
-      real      sWater                        !        Water Content       [%]
-      real      exp1Wa                        !
-      real      dDENDR                        ! Dendricity Increment
-      real      DENDRn                        ! Normalized Dendricity
-      real      SPHERn                        ! Normalized Sphericity
-      real      Wet_OK                        ! Wet Metamorphism Switch
-      real      OK__DE                        !
-      real      OK__wd                        ! New G*, from wet Dendritic
-      real      G1__wd                        ! New G1, from wet Dendritic
-      real      G2__wd                        ! New G2, from wet Dendritic
-      real      OKlowT                        !
-      real      facVap                        !
-      real      OK_ldd                        !
-      real      G1_ldd                        !
-      real      G2_ldd                        !
-      real      DiamGx                        !
-      real      DiamOK                        !
-      real      No_Big                        !
-      real      dSPHER                        !
-      real      SPHER0                        !
-      real      SPHbig                        !
-      real      G1_lds                        !
-      real      OK_mdT                        !
-      real      OKmidT                        !
-      real      OKhigT                        !
-      real      OK_mdd                        !
-      real      G1_mdd                        !
-      real      G2_mdd                        !
-      real      G1_mds                        !
-      real      OK_hdd                        !
-      real      G1_hdd                        !
-      real      G2_hdd                        !
-      real      OK_hds                        !
-      real      G1_hds                        !
-      real      T1__OK,T2__OK                 !
-      real      T3_xOK,T3__OK,T3_nOK          !
-      real      ro1_OK,ro2_OK                 !
-      real      dT1_OK,dT2_OK,dT3xOK,dT3_OK   !
-      real      dT4xOK,dT4_OK,dT4nOK,AngSno   !
-      real      G2_hds,SphrOK,HISupd          !
-      real      H1a_OK,H1b_OK,H1__OK          !
-      real      H23aOK,H23bOK,H23_OK          !
-      real      H2__OK,H3__OK                 !
-      real      H45_OK,H4__OK,H5__OK          !
-      real      ViscSn,OK_Liq,OK_Ang,OKxLiq   !
-      real      dSnMas,dzsnew,rosnew,rosmax,smb_old,smb_new
-      real      zn_old,zn_new
- 
-      real      epsi5                         ! Alpha ev67 single precision	
-      real      vdiam1                        ! Small Grains Min.Diam.[.0001m]
-      real      vdiam2                        ! Spher.Variat.Max Diam.    [mm]
-      real      vdiam3                        ! Min.Diam.|Limit Spher.    [mm]
-      real      vdiam4                        ! Min.Diam.|Viscosity Change
-      real      vsphe1                        ! Max Sphericity
-      real      vsphe2                        ! Low T Metamorphism  Coeff.
-      real      vsphe3                        ! Max.Sphericity (history=1)
-      real      vsphe4                        ! Min.Sphericity=>history=1
-      real      vtang1,vtang2,vtang3,vtang4   ! Temperature Contribution
-      real      vtang5,vtang6,vtang7,vtang8   !
-      real      vtang9,vtanga,vtangb,vtangc   !
-      real      vrang1,vrang2                 ! Density     Contribution
-      real      vgang1,vgang2,vgang3,vgang4   ! Grad(T)     Contribution
-      real      vgang5,vgang6,vgang7,vgang8   !
-      real      vgang9,vganga,vgangb,vgangc   !
-      real      vgran6                        ! Max.Sphericity for Settling
-      real      vtelv1                        ! Threshold | history = 2, 3
-      real       vvap1                        ! Vapor Pressure Coefficient
-      real       vvap2                        ! Vapor Pressure Exponent
-      real      vgrat1                        ! Boundary weak/mid   grad(T)
-      real      vgrat2                        ! Boundary mid/strong grad(T)
-      real         vfi                        ! PHI,         strong grad(T)
-      real      vvisc1,vvisc2,vvisc3,vvisc4   ! Viscosity Coefficients
-      real      vvisc5,vvisc6,vvisc7          ! id., wet Snow
-      real      rovisc                        ! Wet Snow Density  Influence
-      real        vdz3                        ! Maximum Layer Densification
-      real      OK__ws                        ! New G2
-      real      G1__ws                        ! New G1, from wet Spheric
-      real      G2__ws                        ! New G2, from wet Spheric
-      real      husi_0,husi_1,husi_2,husi_3   ! Constants for New G2
-      real      vtail1,vtail2                 ! Constants for New G2
-      real      frac_j                        ! Time Step            [Day]
- 
-      real       vdent1                       ! Wet Snow Metamorphism
-      integer   nvdent1                       ! (Coefficients for
-      integer   nvdent2                       !           Dendricity)
- 
-C +--Snow Properties: IO
-C +  ~~~~~~~~~~~~~~~~~~~
-! #vp real      G_curr(18),Gcases(18)
-! #vp common   /GSnLOC/    Gcases
-! #wp real                 D__MAX
-! #wp common   /GSnMAX/    D__MAX
- 
- 
-C +--DATA
-C +  ====
- 
-      data       vector/.TRUE./               ! Vectorization  Switch
-      data       vdent1/ 0.5e8/               ! Wet Snow Metamorphism
-cXF                      tuned for Greenland (2.e8=old value)
-      data      nvdent1/ 3   /                ! (Coefficients for
-      data      nvdent2/16   /                !           Dendricity)
- 
-      data       husi_0 /20.      /           !   10  * 2
-      data       husi_1 / 0.23873 /           ! (3/4) /pi
-      data       husi_2 / 4.18880 /           ! (4/3) *pi
-      data       husi_3 / 0.33333 /           !  1/3
-      data       vtail1 / 1.28e-08/           !  Wet Metamorphism
-      data       vtail2 / 4.22e-10/           ! (NON Dendritic / Spheric)
- 
-      data       epsi5  / 1.0e-5  /           !
- 
-      data       vdiam1 / 4.0     /           ! Small Grains Min.Diameter
- 
-      data       vdiam2 / 0.5     /           ! Spher.Variat.Max Diam.[mm]
-      data       vdiam3 / 3.0     /           ! Min.Diam.|Limit Spher.[mm]
-      data       vdiam4 / 2.0     /           ! Min.Diam.|Viscosity Change
- 
-      data       vsphe1 / 1.0     /           ! Max Sphericity
-      data       vsphe2 / 1.0e9   /           ! Low T Metamorphism  Coeff.
-      data       vsphe3 / 0.5     /           ! Max.Sphericity (history=1)
-      data       vsphe4 / 0.1     /           ! Min.Sphericity=>history=1
- 
-      data       vgran6 / 51.     /           ! Max.Sphericity for Settling
-      data       vtelv1 / 5.e-1   /           ! Threshold | history = 2, 3
- 
-      data        vvap1 /-6.e3    /           ! Vapor Pressure Coefficient
-      data        vvap2 / 0.4     /           ! Vapor Pressure Exponent
- 
-      data       vgrat1 /0.05     /           ! Boundary weak/mid   grad(T)
-      data       vgrat2 /0.15     /           ! Boundary mid/strong grad(T)
-      data          vfi /0.09     /           ! PHI,         strong grad(T)
- 
-      data       vvisc1 / 0.70    /           ! Viscosity Coefficients
-      data       vvisc2 / 1.11e5  /           !
-      data       vvisc3 /23.00    /           !
-      data       vvisc4 / 0.10    /           !
-      data       vvisc5 / 1.00    /           ! id., wet Snow
-      data       vvisc6 / 2.00    /           !
-      data       vvisc7 /10.00    /           !
-      data       rovisc / 0.25    /           ! Wet Snow Density  Influence
-      data         vdz3 / 0.30    /           ! Maximum Layer Densification
- 
- 
-C +--DATA (Coefficient Fonction fort Gradient Marbouty)
-C +  --------------------------------------------------
- 
-      data       vtang1 /40.0/                ! Temperature Contribution
-      data       vtang2 / 6.0/                !
-      data       vtang3 /22.0/                !
-      data       vtang4 / 0.7/                !
-      data       vtang5 / 0.3/                !
-      data       vtang6 / 6.0/                !
-      data       vtang7 / 1.0/                !
-      data       vtang8 / 0.8/                !
-      data       vtang9 /16.0/                !
-      data       vtanga / 0.2/                !
-      data       vtangb / 0.2/                !
-      data       vtangc /18.0/                !
- 
-      data       vrang1 / 0.40/               ! Density     Contribution
-      data       vrang2 / 0.15/               !
- 
-      data       vgang1 / 0.70/               ! Grad(T)     Contribution
-      data       vgang2 / 0.25/               !
-      data       vgang3 / 0.40/               !
-      data       vgang4 / 0.50/               !
-      data       vgang5 / 0.10/               !
-      data       vgang6 / 0.15/               !
-      data       vgang7 / 0.10/               !
-      data       vgang8 / 0.55/               !
-      data       vgang9 / 0.65/               !
-      data       vganga / 0.20/               !
-      data       vgangb / 0.85/               !
-      data       vgangc / 0.15/               !
- 
-! #wp data       D__MAX / 4.00/               !
- 
- 
-C +-- 1. Metamorphoses dans les Strates
-C +      Metamorphism
-C +      ==============================
- 
-      dt__SV2= dt__SV
-      frac_j = dt__SV2 / 86400.                        ! Time Step [Day]
- 
-      zn4_SV = 0
- 
- 
-C +-- 1.1 Initialisation: teneur en eau liquide et gradient de temperature
-C +   ------------------  liquid water content and temperature gradient
- 
-       DO ikl=1,knonv
-        DO   isn=1,isnoSV(ikl)
- 
-          ro_dry(ikl,isn) = 1.e-3 *ro__SV(ikl,isn)    ! Dry Density
-     .                    *(1.    -eta_SV(ikl,isn))   !         [g/cm3]
-          etaSno(ikl,isn) = 1.e-1 *dzsnSV(ikl,isn)    ! Liquid Water
-     .                    *        ro__SV(ikl,isn)    ! Content [g/cm2]
-     .                    *        eta_SV(ikl,isn)    !
-        END DO
-      END DO
- 
-c!$OMP PARALLEL DO default(firstprivate)
-c!$OMP.shared (/xSISVAT_I/,/xSISVAT_R/,/SoR0SV/,/SoI0SV/,/Sn_dSV/)
-       DO ikl=1,knonv
-        DO   isn=1,isnoSV(ikl)
-          isnp   = min(isn+1,isnoSV(ikl))
- 
-          dTsndz = abs( (TsisSV(ikl,isnp)-TsisSV(ikl,isn-1)) *2.e-2
-     .            /max(((dzsnSV(ikl,isnp)+dzsnSV(ikl,isn)  )
-     .                 *(           isnp -           isn)
-     .                 +(dzsnSV(ikl,isn )+dzsnSV(ikl,isn-1))),epsi))
-C +...    Factor 1.d-2 for Conversion K/m --> K/cm
- 
- 
-C +-- 1.2 Metamorphose humide
-C +       Wet Snow Metamorphism
-C +       ---------------------
- 
-          Wet_OK = max(zero,sign(unun,eta_SV(ikl,isn)-epsi))
- 
- 
-C +--     Vitesse de diminution de la dendricite
-C +       Rate of the dendricity decrease
-C +       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          sWater=1.d-1*ro__SV(ikl,isn)*eta_SV(ikl,isn)
-     .       /max(epsi,ro_dry(ikl,isn))
-C +...    sWater:Water Content [%]
-C +              1.d-1= 1.d2(1->%) * 1.d-3(ro__SV*eta_SV:kg/m3->g/cm3)
- 
-          exp1Wa=   sWater**nvdent1
-          dDENDR=max(exp1Wa/nvdent2,vdent1*exp(vvap1/TfSnow))
- 
-C +-- 1.2.1 Cas dendritique/dendritic Case
-C +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          OK__wd=max(zero,                            !
-     .               sign(unun,-G1snSV(ikl,isn)       !
-     .                         -epsi           ))     !
- 
-          DENDRn=-G1snSV(ikl,isn)/G1_dSV  ! Normalized Dendricity (+)
-          SPHERn= G2snSV(ikl,isn)/G1_dSV  ! Normalized Sphericity
-          DENDRn= DENDRn -dDENDR *frac_j  ! New        Dendricity (+)
-          SPHERn= SPHERn +dDENDR *frac_j  ! New        Sphericity
- 
-          OK__DE=max(zero,                            ! IF 1.,
-     .               sign(unun, DENDRn                ! NO change
-     .                         -epsi           ))     ! Dendr. -> Spheric
- 
-          G1__wd=OK__DE *    (      -DENDRn*G1_dSV)   ! Dendritic
-     .      +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV)   ! Dendr. -> Spheric
-          G2__wd=OK__DE * min(G1_dSV,SPHERn*G1_dSV)   ! Spheric
-     .      +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1))  ! Spher. -> Size
- 
-C +-- 1.2.2 Cas non dendritique non completement spherique
-C +         Evolution de la Sphericite seulement.
-C +         Non dendritic and not completely spheric Case
-C +         Evolution of    Sphericity only (not size)
-C +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          OK__ws=max(zero,                            !
-     .               sign(unun, G1_dSV                !
-     .                         -epsi5                 !
-     .                         -G1snSV(ikl,isn)))     !
- 
-          SPHERn= G1snSV(ikl,isn)/G1_dSV
-          SPHERn= SPHERn +dDENDR *frac_j
-          G1__ws=         min(G1_dSV,SPHERn*G1_dSV)
- 
-C +-- 1.2.3 Cas non dendritique et spherique / non dendritic and spheric
-C +         Evolution de la Taille seulement / Evolution of Size only
-C +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          G2__ws =  husi_0
-     .           *( husi_1
-     .            *(husi_2 *( G2snSV(ikl,isn)/husi_0)**3
-     .                      +(vtail1 +vtail2 *exp1Wa    )*dt__SV2))
-     .           ** husi_3
- 
- 
-C +-- 1.3 Metamorposes seches / Dry Metamorphism
-C +       --------------------------------------
- 
- 
-C +-- 1.3.1 Calcul Metamorphose faible/low Gradient (0.00-0.05 deg/cm)
-C +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          OKlowT=max(zero,                            !
-     .               sign(unun, vgrat1                !
-     .                         -dTsndz         ))     !
- 
-          facVap=exp(vvap1/TsisSV(ikl,isn))
- 
-C +-- 1.3.1.1 Cas dendritique / dendritic Case
- 
-          OK_ldd=max(zero,                            !
-     .               sign(unun,-G1snSV(ikl,isn)       !
-     .                         -epsi           ))     !
- 
-          DENDRn=-G1snSV(ikl,isn)     /G1_dSV
-          SPHERn= G2snSV(ikl,isn)     /G1_dSV
-          DENDRn= DENDRn-vdent1*facVap*frac_j
-          SPHERn= SPHERn+vsphe2*facVap*frac_j
- 
-          OK__DE=max(zero,                            ! IF 1.,
-     .               sign(unun, DENDRn                ! NO change
-     .                         -epsi           ))     ! Dendr. -> Spheric
- 
-          G1_ldd= OK__DE *    (      -DENDRn*G1_dSV)  ! Dendritic
-     .       +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV)  ! Dendr. -> Spheric
-          G2_ldd= OK__DE * min(G1_dSV,SPHERn*G1_dSV)  ! Spheric
-     .       +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1)) ! Spher. -> Size
- 
-C +-- 1.3.1.2 Cas non dendritique / non dendritic Case
- 
-          SPHERn=G1snSV(ikl,isn)/G1_dSV
-          DiamGx=G2snSV(ikl,isn)*0.1
- 
-          istoOK=min( abs(istoSV(ikl,isn)-
-     .                    istdSV(1)      ),1)         ! zero if istoSV = 1
-          DiamOK=max(zero,  sign(unun,vdiam2-DiamGx))
-          No_Big=    istoOK+DiamOK
-          No_Big=min(No_Big,unun)
- 
-          dSPHER=           vsphe2*facVap*frac_j      !
-          SPHER0=    SPHERn+dSPHER                    ! small grains
-          SPHbig=    SPHERn+dSPHER                    ! big   grains
-     .        *exp(min(zero,vdiam3-G2snSV(ikl,isn)))  ! (history = 2 or 3)
-          SPHbig=       min(vsphe3,SPHbig)            ! limited sphericity
-          SPHERn= No_Big *  SPHER0
-     .      + (1.-No_Big)*  SPHbig
- 
-          G1_lds=       min(G1_dSV,SPHERn*G1_dSV)
- 
-C +-- 1.3.2 Calcul Metamorphose Gradient Moyen/Moderate (0.05-0.15)
-C +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          OK_mdT=max(zero,                            !
-     .               sign(unun, vgrat2                !
-     .                         -dTsndz))              !
-          OKmidT=               OK_mdT  *(1.-OKlowT)  !
-          OKhigT=          (1. -OK_mdT) *(1.-OKlowT)  !
- 
-          facVap=vdent1*exp(vvap1/TsisSV(ikl,isn))
-     .                 *   (1.e2 *dTsndz)**vvap2
- 
-C +-- 1.3.2.1 cas dendritique / dendritic case.
- 
-          OK_mdd=max(zero,                            !
-     .               sign(unun,-G1snSV(ikl,isn)       !
-     .                         -epsi           ))     !
- 
-          DENDRn=-G1snSV(ikl,isn)/G1_dSV
-          SPHERn= G2snSV(ikl,isn)/G1_dSV
-          DENDRn= DENDRn - facVap*frac_j
-          SPHERn= SPHERn - facVap*frac_j
- 
-          OK__DE=max(zero,                            ! IF 1.,
-     .               sign(unun, DENDRn                ! NO change
-     .                         -epsi           ))     ! Dendr. -> Spheric
- 
-          G1_mdd= OK__DE *    (      -DENDRn*G1_dSV)  ! Dendritic
-     .       +(1.-OK__DE)* max(zero  ,SPHERn*G1_dSV)  ! Dendr. -> Spheric
-          G2_mdd= OK__DE * max(zero  ,SPHERn*G1_dSV)  ! Spheric
-     .       +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero  )) ! Spher. -> Size
- 
-C +-- 1.3.2.2 Cas non dendritique / non dendritic Case
- 
-          SPHERn=G1snSV(ikl,isn)/G1_dSV
-          SPHERn=         SPHERn-facVap*frac_j
-          G1_mds=max(zero,SPHERn*G1_dSV)
- 
-C +-- 1.3.3 Calcul Metamorphose fort / high Gradient
-C +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          facVap=vdent1*exp(vvap1/TsisSV(ikl,isn))
-     .                 *   (1.e2 *dTsndz)**vvap2
- 
-C +-- 1.3.3.1 Cas dendritique / dendritic Case
- 
-          OK_hdd=max(zero,                            !
-     .               sign(unun,-G1snSV(ikl,isn)       !
-     .                         -epsi           ))     !
- 
-          DENDRn=-G1snSV(ikl,isn)/G1_dSV              !
-          SPHERn= G2snSV(ikl,isn)/G1_dSV              !
-          DENDRn= DENDRn - facVap*frac_j              !
-          SPHERn= SPHERn - facVap*frac_j              ! Non dendritic
-C +                                                   ! and angular
-          OK__DE=max(zero,                            ! IF 1.,
-     .               sign(unun, DENDRn                ! NO change
-     .                         -epsi  ))              ! Dendr. -> Spheric
- 
-          G1_hdd= OK__DE *    (      -DENDRn*G1_dSV)  ! Dendritic
-     .       +(1.-OK__DE)* max(zero  ,SPHERn*G1_dSV)  ! Dendr. -> Spheric
-          G2_hdd= OK__DE * max(zero  ,SPHERn*G1_dSV)  ! Spheric
-     .       +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero  )) ! Spher. -> Size
- 
-C +-- 1.3.3.2 Cas non dendritique non completement anguleux.
-C +           non dendritic and spericity gt. 0
- 
-          OK_hds=max(zero,                            !
-     .               sign(unun, G1snSV(ikl,isn)       !
-     .                         -epsi           ))     !
- 
-          SPHERn= G1snSV(ikl,isn)/G1_dSV
-          SPHERn= SPHERn - facVap*frac_j
-          G1_hds= max(zero,SPHERn*G1_dSV)
- 
-C +-- 1.3.3.3 Cas non dendritique et anguleux
-C +           dendritic and spericity = 0.
- 
-          T1__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang1))
-          T2__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang2))
-          T3_xOK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang3))
-          T3__OK =                    T3_xOK  * (1. - T2__OK)
-          T3_nOK =              (1. - T3_xOK) * (1. - T2__OK)
-          ro1_OK = max(zero,sign(unun,vrang1-ro_dry(ikl,isn)))
-          ro2_OK = max(zero,sign(unun,ro_dry(ikl,isn)-vrang2))
-          dT1_OK = max(zero,sign(unun,vgang1-dTsndz         ))
-          dT2_OK = max(zero,sign(unun,vgang2-dTsndz         ))
-          dT3xOK = max(zero,sign(unun,vgang3-dTsndz         ))
-          dT3_OK =                    dT3xOK  * (1. - dT2_OK)
-          dT4xOK = max(zero,sign(unun,vgang4-dTsndz         ))
-          dT4_OK =                    dT4xOK  * (1. - dT3_OK)
-     .                                        * (1. - dT2_OK)
-          dT4nOK =              (1. - dT4xOK) * (1. - dT3_OK)
-     .                                        * (1. - dT2_OK)
- 
-C +-- Influence de la Temperature /Temperature Influence
-C +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-          AngSno =
-     .      T1__OK                                                       ! 11
-     .    *(T2__OK*(vtang4+vtang5*(TfSnow       -TsisSV(ikl,isn))        ! 12
-     .                    /vtang6)                                       !
-     .     +T3__OK*(vtang7-vtang8*(TfSnow-vtang2-TsisSV(ikl,isn))        ! 13
-     .                    /vtang9)                                       !
-     .     +T3_nOK*(vtanga-vtangb*(TfSnow-vtang3-TsisSV(ikl,isn))        ! 14
-     .                    /vtangc))                                      !
- 
-C +-- Influence de la Masse Volumique /Density Influence
-C +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-     .    * ro1_OK
-     .        *(   ro2_OK*(1. - (ro_dry(ikl,isn)-vrang2)                 !
-     .                                  /(vrang1-vrang2))                !
-     .         +1.-ro2_OK                                )               !
- 
-C +-- Influence du Gradient de Temperature /Temperature Gradient Influence
-C +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-     .        *(   dT1_OK*(dT2_OK*vgang5*(dTsndz-vgang6)                 ! 15
-     .                                  /(vgang2-vgang6)                 !
-     .                    +dT3_OK*vgang7                                 ! 16
-     .                    +dT4_OK*vgang9                                 ! 17
-     .                    +dT4nOK*vgangb                )                ! 18
-     .         +1.-dT1_OK                                )               !
-     .    + ro1_OK
-     .        *    dT1_OK*(dT3_OK*vgang8*(dTsndz-vgang2)
-     .                                  /(vgang3-vgang2)
-     .                    +dT4_OK*vganga*(dTsndz-vgang3)
-     .                                  /(vgang4-vgang3)
-     .                    +dT4nOK*vgangc*(dTsndz-vgang4)
-     .                                  /(vgang1-vgang4))
- 
-          G2_hds = G2snSV(ikl,isn) + 1.d2 *AngSno*vfi     *frac_j
- 
- 
-C +--New Properties
-C +  --------------
- 
-          G1_bak          = G1snSV(ikl,isn)
-          G2_bak          = G2snSV(ikl,isn)
- 
-          G1snSV(ikl,isn) = Wet_OK * (    OK__wd             *G1__wd    !  1
-     .                               +(1.-OK__wd)*    OK__ws *G1__ws    !  2
-     .                               +(1.-OK__wd)*(1.-OK__ws)*G1_bak)   !  3
-     .               +(1. - Wet_OK)                                     !
-     .                *(    OKlowT  *(    OK_ldd             *G1_ldd    !  4
-     .                               +(1.-OK_ldd)            *G1_lds)   !  5
-     .                    + OKmidT  *(    OK_mdd             *G1_mdd    !  6
-     .                               +(1.-OK_mdd)            *G1_mds)   !  7
-     .                    + OKhigT  *(    OK_hdd             *G1_hdd    !  8
-     .                               +(1.-OK_hdd)*    OK_hds *G1_hds    !  9
-     .                               +(1.-OK_hdd)*(1.-OK_hds)*G1_bak))  ! 10
- 
-cXF
-      if(G1snSV(ikl,isn)<0.1)
-     .    G2_hds = G2snSV(ikl,isn) + 1.d1 *AngSno*vfi     *frac_j
-cXF
- 
- 
-          G2snSV(ikl,isn) = Wet_OK * (    OK__wd             *G2__wd    !  1
-     .                               +(1.-OK__wd)*    OK__ws *G2_bak    !  2
-     .                               +(1.-OK__wd)*(1.-OK__ws)*G2__ws)   !  3
-     .               +(1. - Wet_OK)                                     !
-     .                *(    OKlowT  *(    OK_ldd             *G2_ldd    !  4
-     .                               +(1.-OK_ldd)            *G2_bak)   !  5
-     .                    + OKmidT  *(    OK_mdd             *G2_mdd    !  6
-     .                               +(1.-OK_mdd)            *G2_bak)   !  7
-     .                    + OKhigT  *(    OK_hdd             *G2_hdd    !  8
-     .                               +(1.-OK_hdd)*    OK_hds *G2_bak    !  9
-     .                               +(1.-OK_hdd)*(1.-OK_hds)*G2_hds))  ! 10
- 
-C +--Snow Properties: IO Set Up
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~
-! #vp     G_curr( 1) =     Wet_OK             *    OK__wd
-! #vp     G_curr( 2) =     Wet_OK             *(1.-OK__wd)*    OK__ws
-! #vp     G_curr( 3) =     Wet_OK             *(1.-OK__wd)*(1.-OK__ws)
-! #vp     G_curr( 4) = (1.-Wet_OK)*    OKlowT *    OK_ldd
-! #vp     G_curr( 5) = (1.-Wet_OK)*    OKlowT *(1.-OK_ldd)
-! #vp     G_curr( 6) = (1.-Wet_OK)*    OKmidT *    OK_mdd
-! #vp     G_curr( 7) = (1.-Wet_OK)*    OKmidT *(1.-OK_mdd)
-! #vp     G_curr( 8) = (1.-Wet_OK)*    OKhigT *    OK_hdd
-! #vp     G_curr( 9) = (1.-Wet_OK)*    OKhigT *(1.-OK_hdd)*    OK_hds
-! #vp     G_curr(10) = (1.-Wet_OK)*    OKhigT *(1.-OK_hdd)*(1.-OK_hds)
-! #vp     G_curr(11) =     T1__OK                         * G_curr(10)
-! #vp     G_curr(12) =     T2__OK                         * G_curr(10)
-! #vp     G_curr(13) =     T3__OK                         * G_curr(10)
-! #vp     G_curr(14) =     T3_nOK                         * G_curr(10)
-! #vp     G_curr(15) =     ro1_OK*     dT1_OK *    dT2_OK * G_curr(10)
-! #vp     G_curr(16) =     ro1_OK*     dT1_OK *    dT3_OK * G_curr(10)
-! #vp     G_curr(17) =     ro1_OK*     dT1_OK *    dT4_OK * G_curr(10)
-! #vp     G_curr(18) =     ro1_OK*     dT1_OK *    dT4nOK * G_curr(10)
- 
-! #vp     Gcases( 1) = max(Gcases( 1),G_curr( 1))
-! #vp     Gcases( 2) = max(Gcases( 2),G_curr( 2))
-! #vp     Gcases( 3) = max(Gcases( 3),G_curr( 3))
-! #vp     Gcases( 4) = max(Gcases( 4),G_curr( 4))
-! #vp     Gcases( 5) = max(Gcases( 5),G_curr( 5))
-! #vp     Gcases( 6) = max(Gcases( 6),G_curr( 6))
-! #vp     Gcases( 7) = max(Gcases( 7),G_curr( 7))
-! #vp     Gcases( 8) = max(Gcases( 8),G_curr( 8))
-! #vp     Gcases( 9) = max(Gcases( 9),G_curr( 9))
-! #vp     Gcases(10) = max(Gcases(10),G_curr(10))
-! #vp     Gcases(11) = max(Gcases(11),G_curr(11))
-! #vp     Gcases(12) = max(Gcases(12),G_curr(12))
-! #vp     Gcases(13) = max(Gcases(13),G_curr(13))
-! #vp     Gcases(14) = max(Gcases(14),G_curr(14))
-! #vp     Gcases(15) = max(Gcases(15),G_curr(15))
-! #vp     Gcases(16) = max(Gcases(16),G_curr(16))
-! #vp     Gcases(17) = max(Gcases(17),G_curr(17))
-! #vp     Gcases(18) = max(Gcases(18),G_curr(18))
- 
-C +--Snow Properties: IO
-C +  ~~~~~~~~~~~~~~~~~~~
-! #vp     IF          (isn    .le.     isnoSV(ikl))
-! #vp.    write(47,471)isn            ,isnoSV(ikl)                    ,
-! #vp.                 TsisSV(ikl,isn),ro__SV(ikl,isn),eta_SV(ikl,isn),
-! #vp.                 G1_bak         ,G2_bak         ,istoSV(ikl,isn),
-! #vp.                 dTsndz,
-! #vp.                (       k ,k=1,18),
-! #vp.                (G_curr(k),k=1,18),
-! #vp.                (Gcases(k),k=1,18),
-! #vp.                 Wet_OK,OK__wd,G1__wd,G2__wd,
-! #vp.                     1.-OK__wd,OK__ws,G1__ws,1.-OK__ws,G2__ws,
-! #vp.              1.-Wet_OK,OKlowT,OK_ldd,G1_ldd,          G2_ldd,
-! #vp.                            1.-OK_ldd,G1_lds,
-! #vp.                        OKmidT,OK_mdd,G1_mdd,          G1_mdd,
-! #vp.                            1.-OK_mdd,G1_mds,
-! #vp.                        OKhigT,OK_hdd,G1_hdd,          G2_hdd,
-! #vp.                            1.-OK_hdd,OK_hds,          G1_hds,
-! #vp.                                             1.-OK_hds,G2_hds,
-! #vp.                 G1snSV(ikl,isn),
-! #vp.                 G2snSV(ikl,isn)
-
-        END DO
-      END DO
-c!$OMP END PARALLEL DO
- 
-C +-- 2. Mise a Jour Variables Historiques (Cas non dendritique)
-C +      Update of the historical Variables
-C +      =======================================================
- 
-      IF (vector)                                                   THEN
-cXF
-         DO  ikl=1,knonv
-          DO isn=1,isnoSV(ikl)
-          SphrOK = max(zero,sign(unun,       G1snSV(ikl,isn)))
-          H1a_OK = max(zero,sign(unun,vsphe4-G1snSV(ikl,isn)))
-          H1b_OK =     1   - min(1   ,       istoSV(ikl,isn))
-          H1__OK =                    H1a_OK*H1b_OK
-          H23aOK = max(zero,sign(unun,vsphe4-G1_dSV
-     .                                      +G1snSV(ikl,isn)))
-          H23bOK = max(zero,sign(unun,etaSno(ikl,isn)
-     .                      /max(epsi,dzsnSV(ikl,isn))
-     .                                      -vtelv1         ))
-          H23_OK =                    H23aOK*H23bOK
-          H2__OK =     1   - min(1   ,       istoSV(ikl,isn))
-          H3__OK =     1   - min(1   ,   abs(istoSV(ikl,isn)-istdSV(1)))
-          H45_OK = max(zero,sign(unun,TfSnow-TsisSV(ikl,isn)+epsi))
-          H4__OK =     1   - min(1   ,   abs(istoSV(ikl,isn)-istdSV(2)))
-          H5__OK =     1   - min(1   ,   abs(istoSV(ikl,isn)-istdSV(3)))
- 
-          HISupd          =
-     .    SphrOK*(H1__OK                             *istdSV(1)
-     .       +(1.-H1__OK)*    H23_OK         *(H2__OK*istdSV(2)
-     .                                        +H3__OK*istdSV(3))
-     .       +(1.-H1__OK)*(1.-H23_OK) *H45_OK*(H4__OK*istdSV(4)
-     .                                        +H5__OK*istdSV(5)))
-          istoSV(ikl,isn) =   HISupd  +
-     .           (1.-min(unun,HISupd))               *istoSV(ikl,isn)
-        END DO
-        END DO
-      ELSE
- 
- 
-C +-- 2. Mise a Jour Variables Historiques (Cas non dendritique)
-C +      Update of the historical Variables
-C +      =======================================================
- 
-        DO ikl=1,knonv
-        DO isn=iiceSV(ikl),isnoSV(ikl)
-          IF  (G1snSV(ikl,isn)>=0.)                               THEN
-            IF(G1snSV(ikl,isn)<vsphe4.and.istoSV(ikl,isn)==0)  THEN
-                   istoSV(ikl,isn)=istdSV(1)
-            ELSEIF(G1_dSV-G1snSV(ikl,isn)         <vsphe4.and.
-     .             etaSno(ikl,isn)/dzsnSV(ikl,isn)>vtelv1)       THEN
-              IF  (istoSV(ikl,isn)==0)
-     .             istoSV(ikl,isn)=   istdSV(2)
-              IF  (istoSV(ikl,isn)==istdSV(1))
-     .             istoSV(ikl,isn)=   istdSV(3)
-            ELSEIF(TsisSV(ikl,isn)<TfSnow)                       THEN
-              IF  (istoSV(ikl,isn)==istdSV(2))
-     .             istoSV(ikl,isn)=   istdSV(4)
-              IF  (istoSV(ikl,isn)==istdSV(3))
-     .             istoSV(ikl,isn)=   istdSV(5)
-            END IF
-          END IF
-        END DO
-        END DO
-      END IF
- 
- 
-C +-- 3. Tassement mecanique /mechanical Settlement
-C +      ==========================================
- 
-        DO ikl=1,knonv
-          SnMass(ikl) = 0.
-        END DO
-cXF
-      DO ikl=1,knonv
- 
-        smb_old = 0.
-         zn_old = 0
-        DO isn  = 1, isnoSV(ikl)
-        smb_old = smb_old + dzsnSV(ikl,isn) *ro__SV(ikl,isn)
-         zn_old = zn_old  + dzsnSV(ikl,isn)
-        ENDDO
- 
-        DO   isn=isnoSV(ikl),1,-1
-          dSnMas     = 100.*dzsnSV(ikl,isn)*ro_dry(ikl,isn)
-          SnMass(ikl)=      SnMass(ikl)+0.5*dSnMas
-          ViscSn     =      vvisc1         *vvisc2
-     .               *exp(vvisc3           *ro_dry(ikl,isn)
-     .                   +vvisc4*abs(TfSnow-TsisSV(ikl,isn)))
-     .                                     *ro_dry(ikl,isn)/rovisc
- 
-C +-- Changement de Viscosite si Teneur en Eau liquide
-C +   Change of the Viscosity if liquid Water Content
-C +   ------------------------------------------------
- 
-          OK_Liq     =    max(zero,sign(unun,etaSno(ikl,isn)-epsi))
-          OK_Ang     =    max(zero,sign(unun,vgran6-G1snSV(ikl,isn)))
-     .                *(1-min(1   , abs(istoSV(ikl,isn)-istdSV(1))))
-! #wp     IF (G1snSV(ikl,isn).gt.0..AND.G1snSV(ikl,isn).lt.vsphe4
-! #wp.                             .AND.istoSV(ikl,isn).eq.     0)
-! #wp.    THEN
-! #wp       write(6,*) ikl,isn,' G1,G2,hist,OK_Ang  ',
-! #wp.          G1snSV(ikl,isn), G2snSV(ikl,isn),istoSV(ikl,isn),OK_Ang
-! #wp       stop "Grains anguleux mal d?finis"
-! #wp     END IF
-          OKxLiq     =    max(zero,sign(unun,vtelv1-etaSno(ikl,isn)
-     .                                    /max(epsi,dzsnSV(ikl,isn))))
-     .               *    max(0   ,sign(1   ,istoSV(ikl,isn)
-     .                                      -istdSV(1)      ))
-          ViscSn     =
-     .    ViscSn*(    OK_Liq/(vvisc5+vvisc6*etaSno(ikl,isn)
-     .                            /max(epsi,dzsnSV(ikl,isn)))
-     .           +(1.-OK_Liq)                               )
-     .          *(    OK_Ang*exp(min(ADSdSV,G2snSV(ikl,isn)-vdiam4))
-     .           +(1.-OK_Ang)                                       )
-     .          *(    OKxLiq*        vvisc7
-     .           +(1.-OKxLiq)              )
- 
- 
-C +-- Calcul nouvelle Epaisseur / new Thickness
-C +   -----------------------------------------
- 
-          dzsnew         =
-     .    dzsnSV(ikl,isn)
-     .     *max(vdz3,
-     .         (unun-dt__SV2*max(SnMass(ikl)*cos(slopSV(ikl)),unun)
-     .                     /max(ViscSn                      ,epsi)))
-          rosnew         = ro__SV(ikl,isn) *dzsnSV(ikl,isn)
-     .                            /max(1e-10,dzsnew)
-          rosmax         = 1.   /( (1. -eta_SV(ikl,isn)) /ro_Ice
-     .                           +      eta_SV(ikl,isn)  /ro_Wat)
-          rosnew         = min(rosnew ,rosmax)
-          dzsnew         = dzsnSV(ikl,isn) *ro__SV(ikl,isn)
-     .                            /max(1e-10,rosnew)
-          ro__SV(ikl,isn)= rosnew
-          dzsnSV(ikl,isn)= dzsnew
-          ro_dry(ikl,isn)= ro__SV(ikl,isn)*(1.-eta_SV(ikl,isn))*1.e-3
-C +...    ro_dry: Dry Density (g/cm3)
-C +
-          SnMass(ikl)    = SnMass(ikl)+dSnMas*0.5
-        END DO
- 
-        smb_new = 0.
-        DO isn  = 1, isnoSV(ikl)
-        smb_new = smb_new + dzsnSV(ikl,isn) *ro__SV(ikl,isn)
-        ENDDO
- 
-        isn=1
-        if (dzsnSV(ikl,isn)>0.and.ro__SV(ikl,isn)>0) then
-        dzsnSV(ikl,isn) = dzsnSV(ikl,isn) +0.9999*(smb_old-smb_new)
-     .                  / ro__SV(ikl,isn)
-        endif
- 
-         zn_new = 0
-        DO isn  = 1, isnoSV(ikl)
-         zn_new = zn_new  + dzsnSV(ikl,isn)
-        ENDDO
-        zn4_SV(ikl) = zn4_SV(ikl) + (zn_new - zn_old)
- 
-      END DO
- 
-
- 
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_gsn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_gsn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_gsn.f90	(revision 5105)
@@ -0,0 +1,925 @@
+
+SUBROUTINE SISVAT_GSn
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_GSn                                20-09-2003  MAR |
+  ! |   SubRoutine SISVAT_GSn simulates SNOW Metamorphism                    |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   OUTPUT:  iiceSV   = total Nb of Ice      Layers                      |
+  ! |   ^^^^^^   istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
+  ! |                                                                        |
+  ! |   INPUT:   TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+  ! |   ^^^^^             & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  ! |            ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
+  ! |            eta_SV   : Soil/Snow Water   Content                [m3/m3] |
+  ! |            slopSV   : Surface Slope                                [-] |
+  ! |            dzsnSV   : Snow Layer        Thickness                  [m] |
+  ! |            dt__SV2   : Time  Step                                   [s] |
+  ! |                                                                        |
+  ! |   INPUT /  G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+  ! |   OUTPUT:  G2snSV   : Sphericity (>0) or Size            of Snow Layer |
+  ! |   ^^^^^^                                                               |
+  ! |                                                                        |
+  ! |   Formalisme adopte pour la Representation des Grains:                 |
+  ! |   Formalism         for the Representation of  Grains:                 |
+  ! |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                 |
+  ! |                                                                        |
+  ! |             1       - -1                 Neige Fraiche                 |
+  ! |            / \      |                    -------------                 |
+  ! |           /   \     |  Dendricite        decrite  par Dendricite       |
+  ! |          /     \    |  Dendricity                  et Sphericite       |
+  ! |         /       \   |                                                  |
+  ! |        2---------3  -  0                 described by Dendricity       |
+  ! |                                                   and Sphericity       |
+  ! |        |---------|                                                     |
+  ! |        0         1                                                     |
+  ! |        Sphericite                                                      |
+  ! |        Sphericity                                                      |
+  ! |                                                                        |
+  ! |        4---------5  -                                                  |
+  ! |        |         |  |                                                  |
+  ! |        |         |  |  Diametre (1/10eme de mm) (ou Taille)            |
+  ! |        |         |  |  Diameter (1/10th  of mm) (or Size  )            |
+  ! |        |         |  |                                                  |
+  ! |        |         |  |                    Neige non dendritique         |
+  ! |        6---------7  -                    ---------------------         |
+  ! |                                          decrite  par Sphericite       |
+  ! |                                                    et     Taille       |
+  ! |                                          described by Sphericity       |
+  ! |                                                   and       Size       |
+  ! |                                                                        |
+  ! |   Les Variables du Modele:                                             |
+  ! |   Model         Variables:                                             |
+  ! |   ^^^^^^^^^^^^^^^^^^^^^^^^                                             |
+  ! |     Cas Dendritique               Cas non Dendritique                  |
+  ! |                                                                        |
+  ! |     G1snSV        : Dendricite    G1snSV        : Sphericite           |
+  ! |     G2snSV        : Sphericite    G2snSV        : Taille (1/10e mm)    |
+  ! |                                                   Size                 |
+  ! |                                                                        |
+  ! |   Cas Dendritique/ Dendritic Case                                      |
+  ! |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                                      |
+  ! |   Dendricite(Dendricity) G1snSV                                        |
+  ! |            varie     de -G1_dSV (-99 par defaut / etoile)          a 0 |
+  ! |            division par -G1_dSV pour obtenir des valeurs entre 1  et 0 |
+  ! |            varies  from -G1_dSV (default -99    / fresh snow)     to 0 |
+  ! |            division  by -G1_dSV to obtain values       between 1 and 0 |
+  ! |                                                                        |
+  ! |   Sphericite(Sphericity) G2snSV                                        |
+  ! |            varie     de  0         (cas completement anguleux)         |
+  ! |                       a  G1_dSV (99 par defaut, cas spherique)         |
+  ! |            division par  G1_dSV pour obtenir des valeurs entre 0  et 1 |
+  ! |            varies  from  0      (full faceted)               to G1_dSV |
+  ! |                                                                        |
+  ! |   Cas non Dendritique / non Dendritic Case                             |
+  ! |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                             |
+  ! |   Sphericite(Sphericity) G1snSV                                        |
+  ! |            varie     de  0         (cas completement anguleux)         |
+  ! |                       a  G1_dSV (99 par defaut, cas spherique)         |
+  ! |            division par  G1_dSV pour obtenir des valeurs entre 0  et 1 |
+  ! |            varies  from  0      (full faceted)               to G1_dSV |
+  ! |                                                                        |
+  ! |   Taille    (Size)       G2snSV                                        |
+  ! |            superieure a  ADSdSV (.4 mm) et ne fait que croitre         |
+  ! |            greater than  ADSdSV (.4 mm) always increases               |
+  ! |                                                                        |
+  ! |   Exemples: Points caracteristiques des Figures ci-dessus              |
+  ! |   ^^^^^^^^^                                                            |
+  ! |                                                                        |
+  ! |               G1snSV    G2snSV     dendricite  sphericite  taille      |
+  ! |                                    dendricity  sphericity  size        |
+  ! |   ------------------------------------------------------------------   |
+  ! |                                                            [1/10 mm]   |
+  ! |     1        -G1_dSV    sph3SN          1           0.5                |
+  ! |     2           0         0             0           0                  |
+  ! |     3           0       G1_dSV          0           1                  |
+  ! |     4           0       ADSdSV                      0       4.         |
+  ! |     5         G1_dSV    ADSdSV-vsphe1               1       3.         |
+  ! |     6           0         --                        0       --         |
+  ! |     7         G1_dSV      --                        1       --         |
+  ! |                                                                        |
+  ! |   par defaut: G1_dSV=99.                                               |
+  ! |                         sph3SN=50.                                     |
+  ! |                         ADSdSV= 4.                                     |
+  ! |                                vsphe1=1.                               |
+  ! |                                                                        |
+  ! |   Methode:                                                             |
+  ! |   ^^^^^^^^                                                             |
+  ! |   1. Evolution Types de Grains selon Lois de Brun et al. (1992):       |
+  ! |      Grain metamorphism according to         Brun et al. (1992):       |
+  ! |      Plusieurs Cas sont a distiguer  /  the different Cases are:       |
+  ! |       1.1 Metamorphose Neige humide  /  wet Snow                       |
+  ! |       1.2 Metamorphose Neige seche   /  dry Snow                       |
+  ! |         1.2.1 Gradient faible        /  low      Temperature Gradient  |
+  ! |         1.2.2 Gradient moyen         /  moderate Temperature Gradient  |
+  ! |         1.2.3 Gradient fort          /  high     Temperature Gradient  |
+  ! |      Dans chaque Cas on separe Neige Dendritique et non Dendritique    |
+  ! |                           le Passage Dendritique -> non Dendritique    |
+  ! |                           se fait lorsque  G1snSV devient > 0          |
+  ! |      the Case of Dentritic or non Dendritic Snow is treated separately |
+  ! |      the Limit   Dentritic -> non Dendritic is reached when G1snSV > 0 |
+  ! |                                                                        |
+  ! |   2. Tassement: Loi de Viscosite adaptee selon le Type de Grains       |
+  ! |      Snow Settling:    Viscosity depends on the   Grain Type           |
+  ! |                                                                        |
+  ! |   3. Update Variables historiques (cas non dendritique seulement)      |
+  ! |      nhSNow defaut                                                     |
+  ! |                0    Cas normal                                         |
+  ! |      istdSV(1) 1    Grains anguleux / faceted cristal                  |
+  ! |      istdSV(2) 2    Grains ayant ete en presence d eau liquide         |
+  ! |                     mais n'ayant pas eu de caractere anguleux    /     |
+  ! |                     liquid water and no faceted cristals before        |
+  ! |      istdSV(3) 3    Grains ayant ete en presence d eau liquide         |
+  ! |                     ayant eu auparavant un caractere anguleux    /     |
+  ! |                     liquid water and    faceted cristals before        |
+  ! |                                                                        |
+  ! |   REFER. : Brun et al.      1989, J. Glaciol 35 pp. 333--342           |
+  ! |   ^^^^^^^^ Brun et al.      1992, J. Glaciol 38 pp.  13-- 22           |
+  ! |            (CROCUS Model, adapted to MAR at CEN by H.Gallee)           |
+  ! |                                                                        |
+  ! |   REFER. : Marbouty, D.     1980, J. Glaciol 26 pp. xxx--xxx           |
+  ! |   ^^^^^^^^ (CROCUS Model, adapted to MAR at CEN by H.Gallee)           |
+  ! |            (for angular shapes)                                        |
+  ! |                                                                        |
+  ! |   Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
+  ! |   ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
+  ! |   FILE                 |      CONTENT                                  |
+  ! |   ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+  ! | # SISVAT_GSn.vp        | #vp: OUTPUT/Verification: Snow   Properties   |
+  ! |                        |      unit 47, SubRoutines SISVAT_zSn, _GSn    |
+  ! | # stdout               | #wp: OUTPUT/Verification: Snow   Properties   |
+  ! |                        |      unit  6, SubRoutine  SISVAT_GSn          |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VAR0SV
+  use VARxSV
+  use VARtSV
+
+
+  IMPLICIT NONE
+
+
+
+  ! +--INPUT/OUTPUT
+  ! +  ------------
+
+
+  ! +--OUTPUT
+  ! +  ------
+
+  integer :: dt__SV2
+
+
+  ! +--Local  Variables
+  ! +  ================
+
+  logical :: vector                        !
+  integer :: ikl                           !
+  integer :: isn   ,isnp                   !
+  integer :: istoOK                        !
+  real :: G1_bak,G2_bak                 ! Old Values of G1, G2
+  real :: ro_dry(knonv,      nsno)      ! Dry Density            [g/cm3]
+  real :: etaSno(knonv,      nsno)      ! Liquid Water Content   [g/cm2]
+  real :: SnMass(knonv)                 ! Snow   Mass            [kg/m2]
+  real :: dTsndz                        ! Temperature Gradient
+  real :: sWater                        !        Water Content       [%]
+  real :: exp1Wa                        !
+  real :: dDENDR                        ! Dendricity Increment
+  real :: DENDRn                        ! Normalized Dendricity
+  real :: SPHERn                        ! Normalized Sphericity
+  real :: Wet_OK                        ! Wet Metamorphism Switch
+  real :: OK__DE                        !
+  real :: OK__wd                        ! New G*, from wet Dendritic
+  real :: G1__wd                        ! New G1, from wet Dendritic
+  real :: G2__wd                        ! New G2, from wet Dendritic
+  real :: OKlowT                        !
+  real :: facVap                        !
+  real :: OK_ldd                        !
+  real :: G1_ldd                        !
+  real :: G2_ldd                        !
+  real :: DiamGx                        !
+  real :: DiamOK                        !
+  real :: No_Big                        !
+  real :: dSPHER                        !
+  real :: SPHER0                        !
+  real :: SPHbig                        !
+  real :: G1_lds                        !
+  real :: OK_mdT                        !
+  real :: OKmidT                        !
+  real :: OKhigT                        !
+  real :: OK_mdd                        !
+  real :: G1_mdd                        !
+  real :: G2_mdd                        !
+  real :: G1_mds                        !
+  real :: OK_hdd                        !
+  real :: G1_hdd                        !
+  real :: G2_hdd                        !
+  real :: OK_hds                        !
+  real :: G1_hds                        !
+  real :: T1__OK,T2__OK                 !
+  real :: T3_xOK,T3__OK,T3_nOK          !
+  real :: ro1_OK,ro2_OK                 !
+  real :: dT1_OK,dT2_OK,dT3xOK,dT3_OK   !
+  real :: dT4xOK,dT4_OK,dT4nOK,AngSno   !
+  real :: G2_hds,SphrOK,HISupd          !
+  real :: H1a_OK,H1b_OK,H1__OK          !
+  real :: H23aOK,H23bOK,H23_OK          !
+  real :: H2__OK,H3__OK                 !
+  real :: H45_OK,H4__OK,H5__OK          !
+  real :: ViscSn,OK_Liq,OK_Ang,OKxLiq   !
+  real :: dSnMas,dzsnew,rosnew,rosmax,smb_old,smb_new
+  real :: zn_old,zn_new
+
+  real :: epsi5                         ! Alpha ev67 single precision	
+  real :: vdiam1                        ! Small Grains Min.Diam.[.0001m]
+  real :: vdiam2                        ! Spher.Variat.Max Diam.    [mm]
+  real :: vdiam3                        ! Min.Diam.|Limit Spher.    [mm]
+  real :: vdiam4                        ! Min.Diam.|Viscosity Change
+  real :: vsphe1                        ! Max Sphericity
+  real :: vsphe2                        ! Low T Metamorphism  Coeff.
+  real :: vsphe3                        ! Max.Sphericity (history=1)
+  real :: vsphe4                        ! Min.Sphericity=>history=1
+  real :: vtang1,vtang2,vtang3,vtang4   ! Temperature Contribution
+  real :: vtang5,vtang6,vtang7,vtang8   !
+  real :: vtang9,vtanga,vtangb,vtangc   !
+  real :: vrang1,vrang2                 ! Density     Contribution
+  real :: vgang1,vgang2,vgang3,vgang4   ! Grad(T)     Contribution
+  real :: vgang5,vgang6,vgang7,vgang8   !
+  real :: vgang9,vganga,vgangb,vgangc   !
+  real :: vgran6                        ! Max.Sphericity for Settling
+  real :: vtelv1                        ! Threshold | history = 2, 3
+  real :: vvap1                        ! Vapor Pressure Coefficient
+  real :: vvap2                        ! Vapor Pressure Exponent
+  real :: vgrat1                        ! Boundary weak/mid   grad(T)
+  real :: vgrat2                        ! Boundary mid/strong grad(T)
+  real :: vfi                        ! PHI,         strong grad(T)
+  real :: vvisc1,vvisc2,vvisc3,vvisc4   ! Viscosity Coefficients
+  real :: vvisc5,vvisc6,vvisc7          ! id., wet Snow
+  real :: rovisc                        ! Wet Snow Density  Influence
+  real :: vdz3                        ! Maximum Layer Densification
+  real :: OK__ws                        ! New G2
+  real :: G1__ws                        ! New G1, from wet Spheric
+  real :: G2__ws                        ! New G2, from wet Spheric
+  real :: husi_0,husi_1,husi_2,husi_3   ! Constants for New G2
+  real :: vtail1,vtail2                 ! Constants for New G2
+  real :: frac_j                        ! Time Step            [Day]
+
+  real :: vdent1                       ! Wet Snow Metamorphism
+  integer :: nvdent1                       ! (Coefficients for
+  integer :: nvdent2                       !           Dendricity)
+
+  ! +--Snow Properties: IO
+  ! +  ~~~~~~~~~~~~~~~~~~~
+  ! #vp real      G_curr(18),Gcases(18)
+  ! #vp common   /GSnLOC/    Gcases
+  ! #wp real                 D__MAX
+  ! #wp common   /GSnMAX/    D__MAX
+
+
+  ! +--DATA
+  ! +  ====
+
+  data       vector/.TRUE./               ! Vectorization  Switch
+  data       vdent1/ 0.5e8/               ! Wet Snow Metamorphism
+  !XF                      tuned for Greenland (2.e8=old value)
+  data      nvdent1/ 3   /                ! (Coefficients for
+  data      nvdent2/16   /                !           Dendricity)
+
+  data       husi_0 /20.      /           !   10  * 2
+  data       husi_1 / 0.23873 /           ! (3/4) /pi
+  data       husi_2 / 4.18880 /           ! (4/3) *pi
+  data       husi_3 / 0.33333 /           !  1/3
+  data       vtail1 / 1.28e-08/           !  Wet Metamorphism
+  data       vtail2 / 4.22e-10/           ! (NON Dendritic / Spheric)
+
+  data       epsi5  / 1.0e-5  /           !
+
+  data       vdiam1 / 4.0     /           ! Small Grains Min.Diameter
+
+  data       vdiam2 / 0.5     /           ! Spher.Variat.Max Diam.[mm]
+  data       vdiam3 / 3.0     /           ! Min.Diam.|Limit Spher.[mm]
+  data       vdiam4 / 2.0     /           ! Min.Diam.|Viscosity Change
+
+  data       vsphe1 / 1.0     /           ! Max Sphericity
+  data       vsphe2 / 1.0e9   /           ! Low T Metamorphism  Coeff.
+  data       vsphe3 / 0.5     /           ! Max.Sphericity (history=1)
+  data       vsphe4 / 0.1     /           ! Min.Sphericity=>history=1
+
+  data       vgran6 / 51.     /           ! Max.Sphericity for Settling
+  data       vtelv1 / 5.e-1   /           ! Threshold | history = 2, 3
+
+  data        vvap1 /-6.e3    /           ! Vapor Pressure Coefficient
+  data        vvap2 / 0.4     /           ! Vapor Pressure Exponent
+
+  data       vgrat1 /0.05     /           ! Boundary weak/mid   grad(T)
+  data       vgrat2 /0.15     /           ! Boundary mid/strong grad(T)
+  data          vfi /0.09     /           ! PHI,         strong grad(T)
+
+  data       vvisc1 / 0.70    /           ! Viscosity Coefficients
+  data       vvisc2 / 1.11e5  /           !
+  data       vvisc3 /23.00    /           !
+  data       vvisc4 / 0.10    /           !
+  data       vvisc5 / 1.00    /           ! id., wet Snow
+  data       vvisc6 / 2.00    /           !
+  data       vvisc7 /10.00    /           !
+  data       rovisc / 0.25    /           ! Wet Snow Density  Influence
+  data         vdz3 / 0.30    /           ! Maximum Layer Densification
+
+
+  ! +--DATA (Coefficient Fonction fort Gradient Marbouty)
+  ! +  --------------------------------------------------
+
+  data       vtang1 /40.0/                ! Temperature Contribution
+  data       vtang2 / 6.0/                !
+  data       vtang3 /22.0/                !
+  data       vtang4 / 0.7/                !
+  data       vtang5 / 0.3/                !
+  data       vtang6 / 6.0/                !
+  data       vtang7 / 1.0/                !
+  data       vtang8 / 0.8/                !
+  data       vtang9 /16.0/                !
+  data       vtanga / 0.2/                !
+  data       vtangb / 0.2/                !
+  data       vtangc /18.0/                !
+
+  data       vrang1 / 0.40/               ! Density     Contribution
+  data       vrang2 / 0.15/               !
+
+  data       vgang1 / 0.70/               ! Grad(T)     Contribution
+  data       vgang2 / 0.25/               !
+  data       vgang3 / 0.40/               !
+  data       vgang4 / 0.50/               !
+  data       vgang5 / 0.10/               !
+  data       vgang6 / 0.15/               !
+  data       vgang7 / 0.10/               !
+  data       vgang8 / 0.55/               !
+  data       vgang9 / 0.65/               !
+  data       vganga / 0.20/               !
+  data       vgangb / 0.85/               !
+  data       vgangc / 0.15/               !
+
+  ! #wp data       D__MAX / 4.00/               !
+
+
+  ! +-- 1. Metamorphoses dans les Strates
+  ! +      Metamorphism
+  ! +      ==============================
+
+  dt__SV2= dt__SV
+  frac_j = dt__SV2 / 86400.                        ! Time Step [Day]
+
+  zn4_SV = 0
+
+
+  ! +-- 1.1 Initialisation: teneur en eau liquide et gradient de temperature
+  ! +   ------------------  liquid water content and temperature gradient
+
+   DO ikl=1,knonv
+    DO   isn=1,isnoSV(ikl)
+
+      ro_dry(ikl,isn) = 1.e-3 *ro__SV(ikl,isn) & ! Dry Density
+            *(1.    -eta_SV(ikl,isn))   !         [g/cm3]
+      etaSno(ikl,isn) = 1.e-1 *dzsnSV(ikl,isn) & ! Liquid Water
+            *        ro__SV(ikl,isn) & ! Content [g/cm2]
+            *        eta_SV(ikl,isn)    !
+    END DO
+  END DO
+
+  !!$OMP PARALLEL DO default(firstprivate)
+  !!$OMP.shared (/xSISVAT_I/,/xSISVAT_R/,/SoR0SV/,/SoI0SV/,/Sn_dSV/)
+   DO ikl=1,knonv
+    DO   isn=1,isnoSV(ikl)
+      isnp   = min(isn+1,isnoSV(ikl))
+
+      dTsndz = abs( (TsisSV(ikl,isnp)-TsisSV(ikl,isn-1)) *2.e-2 &
+            /max(((dzsnSV(ikl,isnp)+dzsnSV(ikl,isn)  ) &
+            *(           isnp -           isn) &
+            +(dzsnSV(ikl,isn )+dzsnSV(ikl,isn-1))),epsi))
+  ! +...    Factor 1.d-2 for Conversion K/m --> K/cm
+
+
+  ! +-- 1.2 Metamorphose humide
+  ! +       Wet Snow Metamorphism
+  ! +       ---------------------
+
+      Wet_OK = max(zero,sign(unun,eta_SV(ikl,isn)-epsi))
+
+
+  ! +--     Vitesse de diminution de la dendricite
+  ! +       Rate of the dendricity decrease
+  ! +       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      sWater=1.d-1*ro__SV(ikl,isn)*eta_SV(ikl,isn) &
+            /max(epsi,ro_dry(ikl,isn))
+  ! +...    sWater:Water Content [%]
+  ! +              1.d-1= 1.d2(1->%) * 1.d-3(ro__SV*eta_SV:kg/m3->g/cm3)
+
+      exp1Wa=   sWater**nvdent1
+      dDENDR=max(exp1Wa/nvdent2,vdent1*exp(vvap1/TfSnow))
+
+  ! +-- 1.2.1 Cas dendritique/dendritic Case
+  ! +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      OK__wd=max(zero, & !
+            sign(unun,-G1snSV(ikl,isn) & !
+            -epsi           ))     !
+
+      DENDRn=-G1snSV(ikl,isn)/G1_dSV  ! Normalized Dendricity (+)
+      SPHERn= G2snSV(ikl,isn)/G1_dSV  ! Normalized Sphericity
+      DENDRn= DENDRn -dDENDR *frac_j  ! New        Dendricity (+)
+      SPHERn= SPHERn +dDENDR *frac_j  ! New        Sphericity
+
+      OK__DE=max(zero, & ! IF 1.,
+            sign(unun, DENDRn & ! NO change
+            -epsi           ))     ! Dendr. -> Spheric
+
+      G1__wd=OK__DE *    (      -DENDRn*G1_dSV) & ! Dendritic
+            +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV)   ! Dendr. -> Spheric
+      G2__wd=OK__DE * min(G1_dSV,SPHERn*G1_dSV) & ! Spheric
+            +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1))  ! Spher. -> Size
+
+  ! +-- 1.2.2 Cas non dendritique non completement spherique
+  ! +         Evolution de la Sphericite seulement.
+  ! +         Non dendritic and not completely spheric Case
+  ! +         Evolution of    Sphericity only (not size)
+  ! +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      OK__ws=max(zero, & !
+            sign(unun, G1_dSV & !
+            -epsi5 & !
+            -G1snSV(ikl,isn)))     !
+
+      SPHERn= G1snSV(ikl,isn)/G1_dSV
+      SPHERn= SPHERn +dDENDR *frac_j
+      G1__ws=         min(G1_dSV,SPHERn*G1_dSV)
+
+  ! +-- 1.2.3 Cas non dendritique et spherique / non dendritic and spheric
+  ! +         Evolution de la Taille seulement / Evolution of Size only
+  ! +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      G2__ws =  husi_0 &
+            *( husi_1 &
+            *(husi_2 *( G2snSV(ikl,isn)/husi_0)**3 &
+            +(vtail1 +vtail2 *exp1Wa    )*dt__SV2)) &
+            ** husi_3
+
+
+  ! +-- 1.3 Metamorposes seches / Dry Metamorphism
+  ! +       --------------------------------------
+
+
+  ! +-- 1.3.1 Calcul Metamorphose faible/low Gradient (0.00-0.05 deg/cm)
+  ! +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      OKlowT=max(zero, & !
+            sign(unun, vgrat1 & !
+            -dTsndz         ))     !
+
+      facVap=exp(vvap1/TsisSV(ikl,isn))
+
+  ! +-- 1.3.1.1 Cas dendritique / dendritic Case
+
+      OK_ldd=max(zero, & !
+            sign(unun,-G1snSV(ikl,isn) & !
+            -epsi           ))     !
+
+      DENDRn=-G1snSV(ikl,isn)     /G1_dSV
+      SPHERn= G2snSV(ikl,isn)     /G1_dSV
+      DENDRn= DENDRn-vdent1*facVap*frac_j
+      SPHERn= SPHERn+vsphe2*facVap*frac_j
+
+      OK__DE=max(zero, & ! IF 1.,
+            sign(unun, DENDRn & ! NO change
+            -epsi           ))     ! Dendr. -> Spheric
+
+      G1_ldd= OK__DE *    (      -DENDRn*G1_dSV) & ! Dendritic
+            +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV)  ! Dendr. -> Spheric
+      G2_ldd= OK__DE * min(G1_dSV,SPHERn*G1_dSV) & ! Spheric
+            +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1)) ! Spher. -> Size
+
+  ! +-- 1.3.1.2 Cas non dendritique / non dendritic Case
+
+      SPHERn=G1snSV(ikl,isn)/G1_dSV
+      DiamGx=G2snSV(ikl,isn)*0.1
+
+      istoOK=min( abs(istoSV(ikl,isn)- &
+            istdSV(1)      ),1)         ! zero if istoSV = 1
+      DiamOK=max(zero,  sign(unun,vdiam2-DiamGx))
+      No_Big=    istoOK+DiamOK
+      No_Big=min(No_Big,unun)
+
+      dSPHER=           vsphe2*facVap*frac_j      !
+      SPHER0=    SPHERn+dSPHER                    ! small grains
+      SPHbig=    SPHERn+dSPHER & ! big   grains
+            *exp(min(zero,vdiam3-G2snSV(ikl,isn)))  ! (history = 2 or 3)
+      SPHbig=       min(vsphe3,SPHbig)            ! limited sphericity
+      SPHERn= No_Big *  SPHER0 &
+            + (1.-No_Big)*  SPHbig
+
+      G1_lds=       min(G1_dSV,SPHERn*G1_dSV)
+
+  ! +-- 1.3.2 Calcul Metamorphose Gradient Moyen/Moderate (0.05-0.15)
+  ! +         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      OK_mdT=max(zero, & !
+            sign(unun, vgrat2 & !
+            -dTsndz))              !
+      OKmidT=               OK_mdT  *(1.-OKlowT)  !
+      OKhigT=          (1. -OK_mdT) *(1.-OKlowT)  !
+
+      facVap=vdent1*exp(vvap1/TsisSV(ikl,isn)) &
+            *   (1.e2 *dTsndz)**vvap2
+
+  ! +-- 1.3.2.1 cas dendritique / dendritic case.
+
+      OK_mdd=max(zero, & !
+            sign(unun,-G1snSV(ikl,isn) & !
+            -epsi           ))     !
+
+      DENDRn=-G1snSV(ikl,isn)/G1_dSV
+      SPHERn= G2snSV(ikl,isn)/G1_dSV
+      DENDRn= DENDRn - facVap*frac_j
+      SPHERn= SPHERn - facVap*frac_j
+
+      OK__DE=max(zero, & ! IF 1.,
+            sign(unun, DENDRn & ! NO change
+            -epsi           ))     ! Dendr. -> Spheric
+
+      G1_mdd= OK__DE *    (      -DENDRn*G1_dSV) & ! Dendritic
+            +(1.-OK__DE)* max(zero  ,SPHERn*G1_dSV)  ! Dendr. -> Spheric
+      G2_mdd= OK__DE * max(zero  ,SPHERn*G1_dSV) & ! Spheric
+            +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero  )) ! Spher. -> Size
+
+  ! +-- 1.3.2.2 Cas non dendritique / non dendritic Case
+
+      SPHERn=G1snSV(ikl,isn)/G1_dSV
+      SPHERn=         SPHERn-facVap*frac_j
+      G1_mds=max(zero,SPHERn*G1_dSV)
+
+  ! +-- 1.3.3 Calcul Metamorphose fort / high Gradient
+  ! +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      facVap=vdent1*exp(vvap1/TsisSV(ikl,isn)) &
+            *   (1.e2 *dTsndz)**vvap2
+
+  ! +-- 1.3.3.1 Cas dendritique / dendritic Case
+
+      OK_hdd=max(zero, & !
+            sign(unun,-G1snSV(ikl,isn) & !
+            -epsi           ))     !
+
+      DENDRn=-G1snSV(ikl,isn)/G1_dSV              !
+      SPHERn= G2snSV(ikl,isn)/G1_dSV              !
+      DENDRn= DENDRn - facVap*frac_j              !
+      SPHERn= SPHERn - facVap*frac_j              ! Non dendritic
+  ! +                                                   ! and angular
+      OK__DE=max(zero, & ! IF 1.,
+            sign(unun, DENDRn & ! NO change
+            -epsi  ))              ! Dendr. -> Spheric
+
+      G1_hdd= OK__DE *    (      -DENDRn*G1_dSV) & ! Dendritic
+            +(1.-OK__DE)* max(zero  ,SPHERn*G1_dSV)  ! Dendr. -> Spheric
+      G2_hdd= OK__DE * max(zero  ,SPHERn*G1_dSV) & ! Spheric
+            +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero  )) ! Spher. -> Size
+
+  ! +-- 1.3.3.2 Cas non dendritique non completement anguleux.
+  ! +           non dendritic and spericity gt. 0
+
+      OK_hds=max(zero, & !
+            sign(unun, G1snSV(ikl,isn) & !
+            -epsi           ))     !
+
+      SPHERn= G1snSV(ikl,isn)/G1_dSV
+      SPHERn= SPHERn - facVap*frac_j
+      G1_hds= max(zero,SPHERn*G1_dSV)
+
+  ! +-- 1.3.3.3 Cas non dendritique et anguleux
+  ! +           dendritic and spericity = 0.
+
+      T1__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang1))
+      T2__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang2))
+      T3_xOK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang3))
+      T3__OK =                    T3_xOK  * (1. - T2__OK)
+      T3_nOK =              (1. - T3_xOK) * (1. - T2__OK)
+      ro1_OK = max(zero,sign(unun,vrang1-ro_dry(ikl,isn)))
+      ro2_OK = max(zero,sign(unun,ro_dry(ikl,isn)-vrang2))
+      dT1_OK = max(zero,sign(unun,vgang1-dTsndz         ))
+      dT2_OK = max(zero,sign(unun,vgang2-dTsndz         ))
+      dT3xOK = max(zero,sign(unun,vgang3-dTsndz         ))
+      dT3_OK =                    dT3xOK  * (1. - dT2_OK)
+      dT4xOK = max(zero,sign(unun,vgang4-dTsndz         ))
+      dT4_OK =                    dT4xOK  * (1. - dT3_OK) &
+            * (1. - dT2_OK)
+      dT4nOK =              (1. - dT4xOK) * (1. - dT3_OK) &
+            * (1. - dT2_OK)
+
+  ! +-- Influence de la Temperature /Temperature Influence
+  ! +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      AngSno = &
+            T1__OK & ! 11
+            *(T2__OK*(vtang4+vtang5*(TfSnow       -TsisSV(ikl,isn)) & ! 12
+            /vtang6) & !
+            +T3__OK*(vtang7-vtang8*(TfSnow-vtang2-TsisSV(ikl,isn)) & ! 13
+            /vtang9) & !
+            +T3_nOK*(vtanga-vtangb*(TfSnow-vtang3-TsisSV(ikl,isn)) & ! 14
+            /vtangc)) & !
+
+  ! +-- Influence de la Masse Volumique /Density Influence
+  ! +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+            * ro1_OK &
+            *(   ro2_OK*(1. - (ro_dry(ikl,isn)-vrang2) & !
+            /(vrang1-vrang2)) & !
+            +1.-ro2_OK                                ) & !
+
+  ! +-- Influence du Gradient de Temperature /Temperature Gradient Influence
+  ! +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+            *(   dT1_OK*(dT2_OK*vgang5*(dTsndz-vgang6) & ! 15
+            /(vgang2-vgang6) & !
+            +dT3_OK*vgang7 & ! 16
+            +dT4_OK*vgang9 & ! 17
+            +dT4nOK*vgangb                ) & ! 18
+            +1.-dT1_OK                                ) & !
+            + ro1_OK &
+            *    dT1_OK*(dT3_OK*vgang8*(dTsndz-vgang2) &
+            /(vgang3-vgang2) &
+            +dT4_OK*vganga*(dTsndz-vgang3) &
+            /(vgang4-vgang3) &
+            +dT4nOK*vgangc*(dTsndz-vgang4) &
+            /(vgang1-vgang4))
+
+      G2_hds = G2snSV(ikl,isn) + 1.d2 *AngSno*vfi     *frac_j
+
+
+  ! +--New Properties
+  ! +  --------------
+
+      G1_bak          = G1snSV(ikl,isn)
+      G2_bak          = G2snSV(ikl,isn)
+
+      G1snSV(ikl,isn) = Wet_OK * (    OK__wd             *G1__wd & !  1
+            +(1.-OK__wd)*    OK__ws *G1__ws & !  2
+            +(1.-OK__wd)*(1.-OK__ws)*G1_bak) & !  3
+            +(1. - Wet_OK) & !
+            *(    OKlowT  *(    OK_ldd             *G1_ldd & !  4
+            +(1.-OK_ldd)            *G1_lds) & !  5
+            + OKmidT  *(    OK_mdd             *G1_mdd & !  6
+            +(1.-OK_mdd)            *G1_mds) & !  7
+            + OKhigT  *(    OK_hdd             *G1_hdd & !  8
+            +(1.-OK_hdd)*    OK_hds *G1_hds & !  9
+            +(1.-OK_hdd)*(1.-OK_hds)*G1_bak))  ! 10
+
+  !XF
+  if(G1snSV(ikl,isn)<0.1) &
+        G2_hds = G2snSV(ikl,isn) + 1.d1 *AngSno*vfi     *frac_j
+  !XF
+
+
+      G2snSV(ikl,isn) = Wet_OK * (    OK__wd             *G2__wd & !  1
+            +(1.-OK__wd)*    OK__ws *G2_bak & !  2
+            +(1.-OK__wd)*(1.-OK__ws)*G2__ws) & !  3
+            +(1. - Wet_OK) & !
+            *(    OKlowT  *(    OK_ldd             *G2_ldd & !  4
+            +(1.-OK_ldd)            *G2_bak) & !  5
+            + OKmidT  *(    OK_mdd             *G2_mdd & !  6
+            +(1.-OK_mdd)            *G2_bak) & !  7
+            + OKhigT  *(    OK_hdd             *G2_hdd & !  8
+            +(1.-OK_hdd)*    OK_hds *G2_bak & !  9
+            +(1.-OK_hdd)*(1.-OK_hds)*G2_hds))  ! 10
+
+  ! +--Snow Properties: IO Set Up
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ! #vp     G_curr( 1) =     Wet_OK             *    OK__wd
+  ! #vp     G_curr( 2) =     Wet_OK             *(1.-OK__wd)*    OK__ws
+  ! #vp     G_curr( 3) =     Wet_OK             *(1.-OK__wd)*(1.-OK__ws)
+  ! #vp     G_curr( 4) = (1.-Wet_OK)*    OKlowT *    OK_ldd
+  ! #vp     G_curr( 5) = (1.-Wet_OK)*    OKlowT *(1.-OK_ldd)
+  ! #vp     G_curr( 6) = (1.-Wet_OK)*    OKmidT *    OK_mdd
+  ! #vp     G_curr( 7) = (1.-Wet_OK)*    OKmidT *(1.-OK_mdd)
+  ! #vp     G_curr( 8) = (1.-Wet_OK)*    OKhigT *    OK_hdd
+  ! #vp     G_curr( 9) = (1.-Wet_OK)*    OKhigT *(1.-OK_hdd)*    OK_hds
+  ! #vp     G_curr(10) = (1.-Wet_OK)*    OKhigT *(1.-OK_hdd)*(1.-OK_hds)
+  ! #vp     G_curr(11) =     T1__OK                         * G_curr(10)
+  ! #vp     G_curr(12) =     T2__OK                         * G_curr(10)
+  ! #vp     G_curr(13) =     T3__OK                         * G_curr(10)
+  ! #vp     G_curr(14) =     T3_nOK                         * G_curr(10)
+  ! #vp     G_curr(15) =     ro1_OK*     dT1_OK *    dT2_OK * G_curr(10)
+  ! #vp     G_curr(16) =     ro1_OK*     dT1_OK *    dT3_OK * G_curr(10)
+  ! #vp     G_curr(17) =     ro1_OK*     dT1_OK *    dT4_OK * G_curr(10)
+  ! #vp     G_curr(18) =     ro1_OK*     dT1_OK *    dT4nOK * G_curr(10)
+
+  ! #vp     Gcases( 1) = max(Gcases( 1),G_curr( 1))
+  ! #vp     Gcases( 2) = max(Gcases( 2),G_curr( 2))
+  ! #vp     Gcases( 3) = max(Gcases( 3),G_curr( 3))
+  ! #vp     Gcases( 4) = max(Gcases( 4),G_curr( 4))
+  ! #vp     Gcases( 5) = max(Gcases( 5),G_curr( 5))
+  ! #vp     Gcases( 6) = max(Gcases( 6),G_curr( 6))
+  ! #vp     Gcases( 7) = max(Gcases( 7),G_curr( 7))
+  ! #vp     Gcases( 8) = max(Gcases( 8),G_curr( 8))
+  ! #vp     Gcases( 9) = max(Gcases( 9),G_curr( 9))
+  ! #vp     Gcases(10) = max(Gcases(10),G_curr(10))
+  ! #vp     Gcases(11) = max(Gcases(11),G_curr(11))
+  ! #vp     Gcases(12) = max(Gcases(12),G_curr(12))
+  ! #vp     Gcases(13) = max(Gcases(13),G_curr(13))
+  ! #vp     Gcases(14) = max(Gcases(14),G_curr(14))
+  ! #vp     Gcases(15) = max(Gcases(15),G_curr(15))
+  ! #vp     Gcases(16) = max(Gcases(16),G_curr(16))
+  ! #vp     Gcases(17) = max(Gcases(17),G_curr(17))
+  ! #vp     Gcases(18) = max(Gcases(18),G_curr(18))
+
+  ! +--Snow Properties: IO
+  ! +  ~~~~~~~~~~~~~~~~~~~
+  ! #vp     IF          (isn    .le.     isnoSV(ikl))
+  ! #vp.    write(47,471)isn            ,isnoSV(ikl)                    ,
+  ! #vp.                 TsisSV(ikl,isn),ro__SV(ikl,isn),eta_SV(ikl,isn),
+  ! #vp.                 G1_bak         ,G2_bak         ,istoSV(ikl,isn),
+  ! #vp.                 dTsndz,
+  ! #vp.                (       k ,k=1,18),
+  ! #vp.                (G_curr(k),k=1,18),
+  ! #vp.                (Gcases(k),k=1,18),
+  ! #vp.                 Wet_OK,OK__wd,G1__wd,G2__wd,
+  ! #vp.                     1.-OK__wd,OK__ws,G1__ws,1.-OK__ws,G2__ws,
+  ! #vp.              1.-Wet_OK,OKlowT,OK_ldd,G1_ldd,          G2_ldd,
+  ! #vp.                            1.-OK_ldd,G1_lds,
+  ! #vp.                        OKmidT,OK_mdd,G1_mdd,          G1_mdd,
+  ! #vp.                            1.-OK_mdd,G1_mds,
+  ! #vp.                        OKhigT,OK_hdd,G1_hdd,          G2_hdd,
+  ! #vp.                            1.-OK_hdd,OK_hds,          G1_hds,
+  ! #vp.                                             1.-OK_hds,G2_hds,
+  ! #vp.                 G1snSV(ikl,isn),
+  ! #vp.                 G2snSV(ikl,isn)
+
+    END DO
+  END DO
+  !!$OMP END PARALLEL DO
+
+  ! +-- 2. Mise a Jour Variables Historiques (Cas non dendritique)
+  ! +      Update of the historical Variables
+  ! +      =======================================================
+
+  IF (vector)                                                   THEN
+  !XF
+     DO  ikl=1,knonv
+      DO isn=1,isnoSV(ikl)
+      SphrOK = max(zero,sign(unun,       G1snSV(ikl,isn)))
+      H1a_OK = max(zero,sign(unun,vsphe4-G1snSV(ikl,isn)))
+      H1b_OK =     1   - min(1   ,       istoSV(ikl,isn))
+      H1__OK =                    H1a_OK*H1b_OK
+      H23aOK = max(zero,sign(unun,vsphe4-G1_dSV &
+            +G1snSV(ikl,isn)))
+      H23bOK = max(zero,sign(unun,etaSno(ikl,isn) &
+            /max(epsi,dzsnSV(ikl,isn)) &
+            -vtelv1         ))
+      H23_OK =                    H23aOK*H23bOK
+      H2__OK =     1   - min(1   ,       istoSV(ikl,isn))
+      H3__OK =     1   - min(1   ,   abs(istoSV(ikl,isn)-istdSV(1)))
+      H45_OK = max(zero,sign(unun,TfSnow-TsisSV(ikl,isn)+epsi))
+      H4__OK =     1   - min(1   ,   abs(istoSV(ikl,isn)-istdSV(2)))
+      H5__OK =     1   - min(1   ,   abs(istoSV(ikl,isn)-istdSV(3)))
+
+      HISupd          = &
+            SphrOK*(H1__OK                             *istdSV(1) &
+            +(1.-H1__OK)*    H23_OK         *(H2__OK*istdSV(2) &
+            +H3__OK*istdSV(3)) &
+            +(1.-H1__OK)*(1.-H23_OK) *H45_OK*(H4__OK*istdSV(4) &
+            +H5__OK*istdSV(5)))
+      istoSV(ikl,isn) =   HISupd  + &
+            (1.-min(unun,HISupd))               *istoSV(ikl,isn)
+    END DO
+    END DO
+  ELSE
+
+
+  ! +-- 2. Mise a Jour Variables Historiques (Cas non dendritique)
+  ! +      Update of the historical Variables
+  ! +      =======================================================
+
+    DO ikl=1,knonv
+    DO isn=iiceSV(ikl),isnoSV(ikl)
+      IF  (G1snSV(ikl,isn)>=0.)                               THEN
+        IF(G1snSV(ikl,isn)<vsphe4.and.istoSV(ikl,isn)==0)  THEN
+               istoSV(ikl,isn)=istdSV(1)
+        ELSEIF(G1_dSV-G1snSV(ikl,isn)         <vsphe4.and. &
+              etaSno(ikl,isn)/dzsnSV(ikl,isn)>vtelv1)       THEN
+          IF  (istoSV(ikl,isn)==0) &
+                istoSV(ikl,isn)=   istdSV(2)
+          IF  (istoSV(ikl,isn)==istdSV(1)) &
+                istoSV(ikl,isn)=   istdSV(3)
+        ELSEIF(TsisSV(ikl,isn)<TfSnow)                       THEN
+          IF  (istoSV(ikl,isn)==istdSV(2)) &
+                istoSV(ikl,isn)=   istdSV(4)
+          IF  (istoSV(ikl,isn)==istdSV(3)) &
+                istoSV(ikl,isn)=   istdSV(5)
+        END IF
+      END IF
+    END DO
+    END DO
+  END IF
+
+
+  ! +-- 3. Tassement mecanique /mechanical Settlement
+  ! +      ==========================================
+
+    DO ikl=1,knonv
+      SnMass(ikl) = 0.
+    END DO
+  !XF
+  DO ikl=1,knonv
+
+    smb_old = 0.
+     zn_old = 0
+    DO isn  = 1, isnoSV(ikl)
+    smb_old = smb_old + dzsnSV(ikl,isn) *ro__SV(ikl,isn)
+     zn_old = zn_old  + dzsnSV(ikl,isn)
+    ENDDO
+
+    DO   isn=isnoSV(ikl),1,-1
+      dSnMas     = 100.*dzsnSV(ikl,isn)*ro_dry(ikl,isn)
+      SnMass(ikl)=      SnMass(ikl)+0.5*dSnMas
+      ViscSn     =      vvisc1         *vvisc2 &
+            *exp(vvisc3           *ro_dry(ikl,isn) &
+            +vvisc4*abs(TfSnow-TsisSV(ikl,isn))) &
+            *ro_dry(ikl,isn)/rovisc
+
+  ! +-- Changement de Viscosite si Teneur en Eau liquide
+  ! +   Change of the Viscosity if liquid Water Content
+  ! +   ------------------------------------------------
+
+      OK_Liq     =    max(zero,sign(unun,etaSno(ikl,isn)-epsi))
+      OK_Ang     =    max(zero,sign(unun,vgran6-G1snSV(ikl,isn))) &
+            *(1-min(1   , abs(istoSV(ikl,isn)-istdSV(1))))
+  ! #wp     IF (G1snSV(ikl,isn).gt.0..AND.G1snSV(ikl,isn).lt.vsphe4
+  ! #wp.                             .AND.istoSV(ikl,isn).eq.     0)
+  ! #wp.    THEN
+  ! #wp       write(6,*) ikl,isn,' G1,G2,hist,OK_Ang  ',
+  ! #wp.          G1snSV(ikl,isn), G2snSV(ikl,isn),istoSV(ikl,isn),OK_Ang
+  ! #wp       stop "Grains anguleux mal d?finis"
+  ! #wp     END IF
+      OKxLiq     =    max(zero,sign(unun,vtelv1-etaSno(ikl,isn) &
+            /max(epsi,dzsnSV(ikl,isn)))) &
+            *    max(0   ,sign(1   ,istoSV(ikl,isn) &
+            -istdSV(1)      ))
+      ViscSn     = &
+            ViscSn*(    OK_Liq/(vvisc5+vvisc6*etaSno(ikl,isn) &
+            /max(epsi,dzsnSV(ikl,isn))) &
+            +(1.-OK_Liq)                               ) &
+            *(    OK_Ang*exp(min(ADSdSV,G2snSV(ikl,isn)-vdiam4)) &
+            +(1.-OK_Ang)                                       ) &
+            *(    OKxLiq*        vvisc7 &
+            +(1.-OKxLiq)              )
+
+
+  ! +-- Calcul nouvelle Epaisseur / new Thickness
+  ! +   -----------------------------------------
+
+      dzsnew         = &
+            dzsnSV(ikl,isn) &
+            *max(vdz3, &
+            (unun-dt__SV2*max(SnMass(ikl)*cos(slopSV(ikl)),unun) &
+            /max(ViscSn                      ,epsi)))
+      rosnew         = ro__SV(ikl,isn) *dzsnSV(ikl,isn) &
+            /max(1e-10,dzsnew)
+      rosmax         = 1.   /( (1. -eta_SV(ikl,isn)) /ro_Ice &
+            +      eta_SV(ikl,isn)  /ro_Wat)
+      rosnew         = min(rosnew ,rosmax)
+      dzsnew         = dzsnSV(ikl,isn) *ro__SV(ikl,isn) &
+            /max(1e-10,rosnew)
+      ro__SV(ikl,isn)= rosnew
+      dzsnSV(ikl,isn)= dzsnew
+      ro_dry(ikl,isn)= ro__SV(ikl,isn)*(1.-eta_SV(ikl,isn))*1.e-3
+  ! +...    ro_dry: Dry Density (g/cm3)
+  ! +
+      SnMass(ikl)    = SnMass(ikl)+dSnMas*0.5
+    END DO
+
+    smb_new = 0.
+    DO isn  = 1, isnoSV(ikl)
+    smb_new = smb_new + dzsnSV(ikl,isn) *ro__SV(ikl,isn)
+    ENDDO
+
+    isn=1
+    if (dzsnSV(ikl,isn)>0.and.ro__SV(ikl,isn)>0) then
+    dzsnSV(ikl,isn) = dzsnSV(ikl,isn) +0.9999*(smb_old-smb_new) &
+          / ro__SV(ikl,isn)
+    endif
+
+     zn_new = 0
+    DO isn  = 1, isnoSV(ikl)
+     zn_new = zn_new  + dzsnSV(ikl,isn)
+    ENDDO
+    zn4_SV(ikl) = zn4_SV(ikl) + (zn_new - zn_old)
+
+  END DO
+
+
+
+
+end subroutine sisvat_gsn
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qsn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qsn.F	(revision 5104)
+++ 	(revision )
@@ -1,717 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_qSn
-     .                     (
-! #e1.                      EqSn_0,EqSn_1,EqSn_d
-! #m1.                     ,SIsubl,SImelt,SIrnof
-     .                     )
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_qSn                           Fri 29-Jul-2011  MAR |
-C |   SubRoutine SISVAT_qSn updates  the Snow Water Content                |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
-C |   ^^^^^                                                                |
-C |                                                                        |
-C |   INPUT:   TaT_SV   : SBL Top    Temperature                       [K] |
-C |   ^^^^^    dt__SV   : Time Step                                    [s] |
-C |                                                                        |
-C |   INPUT /  drr_SV   : Rain Intensity                         [kg/m2/s] |
-C |   OUTPUT:  dzsnSV   : Snow Layer Thickness                         [m] |
-C |   ^^^^^^   eta_SV   : Snow Water Content                       [m3/m3] |
-C |            ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
-C |            TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
-C |                     & Snow     Temperatures (layers  1,2,...,nsno) [K] |
-C |                                                                        |
-C |   OUTPUT:  SWS_SV   : Surficial Water Status                           |
-C |   ^^^^^^                                                               |
-C |            EExcsv   : Snow Energy in Excess, initial Forcing    [J/m2] |
-C |            EqSn_d   : Snow Energy in Excess, remaining          [J/m2] |
-C |            EqSn_0   : Snow Energy, before Phase Change          [J/m2] |
-C |            EqSn_1   : Snow Energy, after  Phase Change          [J/m2] |
-C |            SIsubl   : Snow sublimed/deposed Mass             [mm w.e.] |
-C |            SImelt   : Snow Melted           Mass             [mm w.e.] |
-C |            SIrnof   : Surficial Water + Run OFF Change       [mm w.e.] |
-C |                                                                        |
-C |   Internal Variables:                                                  |
-C |   ^^^^^^^^^^^^^^^^^^                                                   |
-C |                                                                        |
-C | # OPTIONS: #E0: IO for Verification: Energy       Budget               |
-C | # ^^^^^^^                                                              |
-C | #          #su: IO for Verification: Slush        Diagnostic           |
-C |                                                                        |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
-
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VAR0SV
-      use VARxSV
-      use VARySV
-      use surface_data, only: is_ok_slush,opt_runoff_ac
-
-
-      IMPLICIT NONE
-
- 
-! Energy          Budget
-! ~~~~~~~~~~~~~~~~~~~~~~
-! #e1 real     EqSn_d(knonv)                 ! Energy in Excess, initial
-! #e1 real     EqSn_0(knonv)                 ! Snow Energy, befor Phase Change
-! #vm real     EqSn01(knonv)                 ! Snow Energy, after Phase Change
-! #vm real     EqSn02(knonv)                 ! Snow Energy, after Phase Change
-                                             !              .AND. Last Melting
-! #e1 real     EqSn_1(knonv)                 ! Snow Energy, after Phase Change
-                                             !              .AND. Mass Redistr.
-! Snow/Ice (Mass) Budget
-! ~~~~~~~~~~~~~~~~~~~~~~
-! #m1 real     SIsubl(knonv)                 ! Snow Deposed Mass
-! #m1 real     SImelt(knonv)                 ! Snow Melted  Mass
-! #m1 real     SIrnof(knonv)                 ! Local Surficial Water + Run OFF
- 
- 
-C +--Internal Variables
-C +  ==================
- 
-      integer  ikl   ,isn                    !
-      integer  nh                            ! Non erodible Snow: up.lay.Index
-      integer  LayrOK                        ! 1 (0)  if In(Above) Snow Pack
-      integer  k_face                        ! 1 (0)  if Crystal(no) faceted
-      integer  LastOK                        ! 1 ==>  1! Snow Layer
-      integer  NOLayr                        ! 1     Layer  Update
-      integer  noSnow(knonv)                 ! Nb of Layers Updater
-      integer  kSlush                        ! Slush Switch
-      real     dTSnow                        ! Temperature                  [C]
-      real     EExdum(knonv)                 ! Energy in Excess when no Snow
-      real     OKmelt                        ! 1 (0)  if        (no) Melting
-      real     EnMelt                        ! Energy in excess, for Melting
-      real     SnHLat                        ! Energy consumed   in  Melting
-      real     AdEnrg,B_Enrg                 ! Additional Energy from  Vapor
-      real     dzVap0,dzVap1                 ! Vaporized Thickness          [m]
-      real     dzMelt(knonv)                 ! Melted    Thickness          [m]
-      real     rosDry                        ! Snow volumic Mass if no Water in
-      real     PorVol                        ! Pore volume
-      real     PClose                        ! Pore Hole Close OFF Switch
-      real     SGDiam                        !      Snow Grain Diameter
-      real     SGDmax                        ! Max. Snow Grain Diameter
-      real     rWater                        ! Retained Water           [kg/m2]
-      real     drrNEW                        ! New available Water      [kg/m2]
-      real     rdzNEW                        ! Snow          Mass       [kg/m2]
-      real     rdzsno                        ! Snow          Mass       [kg/m2]
-      real     EnFrez                        ! Energy Release    in  Freezing
-      real     WaFrez                        ! Water  consumed   in  Melting
-      real     RapdOK                        ! 1. ==> Snow melts rapidly
-      real     ThinOK                        ! 1. ==> Snow Layer is thin
-      real     dzepsi                        ! Minim. Snow Layer Thickness (!)
-      real     dz_Min                        ! Minim. Snow Layer Thickness
-      real     z_Melt                        ! Last (thin) Layer Melting
-      real     rusnew                        ! Surficial Water Thickness   [mm]
-      real     zWater                        ! Max Slush Water Thickness   [mm]
-      real     zSlush                        !     Slush Water Thickness   [mm]
-      real     ro_new                        ! New Snow/ice  Density    [kg/m3]
-      real     zc,zt                         ! Non erod.Snow Thickness[mm w.e.]
-      real     rusnSV0(knonv)
-      real     Tsave
- 
-C +--OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT)
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-      integer             isnnew,isinew,isnUpD,isnitr
- 
-! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
-! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-! #wx integer             iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1
-! #wx common/SISVAT_EV/   iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1
- 
-C +--Energy and Mass Budget
-C +  ~~~~~~~~~~~~~~~~~~~~~~
-! #vm real     WqSn_0(knonv)                 ! Snow Water+Forcing  Initial
-! #vm real     WqSn_1(knonv)                 ! Snow Water+Forcing, Final
-! #vm logical         emopen                 ! IO   Switch
-! #vm common/Se_qSn_L/emopen                 !
-! #vm integer         no_err                 !
-! #vm common/Se_qSn_I/no_err                 !
-! #vm real     hourer,timeer                 !
-! #vm common/Se_qSn_R/timeer                 !
- 
-C +--Slush Diagnostic: IO
-C +  ~~~~~~~~~~~~~~~~~~~~
-! #vu logical         su_opn                 ! IO   Switch
-! #vu common/SI_qSn_L/su_opn                 !
- 
- 
-C +--DATA
-C +  ====
- 
-      data      dzepsi/0.0001/                ! Minim. Snow Layer Thickness (!)
-c #?? data      dz_Min/0.005/                 ! Minim. Snow Layer Thickness
-c ... Warning: Too high for Col de Porte: precludes 1st snow (layer) apparition
-      data      dz_Min/2.5e-3/                ! Minim. Snow Layer Thickness
-      data      SGDmax/0.003/                 ! Maxim. Snow Grain Diameter  [m]
-                                              ! (Rowe et al. 1995, JGR p.16268)
- 
-C +--Energy Budget (IN)
-C +  ==================
- 
-! #e1   DO ikl=1,knonv
-! #e1     EqSn_0(ikl) = 0.
-! #e1   END DO
-! #e1 DO   isn=nsno,1,-1
-! #e1   DO ikl=1,knonv
-! #e1     EqSn_0(ikl) = EqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
-! #e1.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
-! #e1.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
-! #e1   END DO
-! #e1 END DO
- 
- 
-C +--Water  Budget (IN)
-C +  ==================
- 
-! #vm   DO ikl=1,knonv
-! #vm     WqSn_0(ikl) = drr_SV(ikl) * dt__SV
-! #vm.                 +rusnSV(ikl)
-! #vm   END DO
-! #vm DO   isn=nsno,1,-1
-! #vm   DO ikl=1,knonv
-! #vm     WqSn_0(ikl) = WqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
-! #vm   END DO
-! #vm END DO
- 
- 
-C +--Snow Melt Budget
-C +  ================
- 
-! #m1   DO ikl=1,knonv
-! #m1     SImelt(ikl) = 0.
-! #m1     SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV
-! #m1   END DO
- 
- 
-C +--Initialization
-C +  ==============
- 
-      DO ikl=1,knonv
-        noSnow(ikl)   = 0                   ! Nb of Layers Updater
-        ispiSV(ikl)   = 0                   ! Pore Hole Close OFF Index
-                                            ! (assumed to be the Top of
-                                            !  the surimposed Ice Layer)
-        zn5_SV(ikl)   = 0.
-        rusnSV0(ikl)  = 0.
-
-      END DO
- 
- 
-C +--Melting/Freezing Energy
-C +  =======================
- 
-C +...REMARK: Snow liquid Water Temperature assumed = TfSnow
-C +   ^^^^^^
-        DO ikl=1,knonv
-          EExdum(ikl) = drr_SV(ikl)     * C__Wat *(TaT_SV(ikl)-TfSnow)
-     .                                  * dt__SV
-          EExcsv(ikl) = EExdum(ikl)     *    min(1,isnoSV(ikl)) ! Snow exists
-          EExdum(ikl) = EExdum(ikl)     -          EExcsv(ikl)  !
-! #e1     EqSn_d(ikl) = EExcsv(ikl)                             !
-        END DO
- 
- 
-C +--Surficial Water Status
-C +  ----------------------
- 
-        DO ikl=1,knonv
-          SWS_SV(ikl) = max(zero,sign(unun,TfSnow
-     .                                    -TsisSV(ikl,isnoSV(ikl))))
-        END DO
- 
-      DO ikl=1,knonv
-
-      DO isn=min(nsno,isnoSV(ikl)+1),1,-1
-! EV          DO isn=nsno,1,-1
-C +--Energy, store Previous Content
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          dTSnow      = TsisSV(ikl,isn) -          TfSnow
-          EExcsv(ikl) = EExcsv(ikl)
-     .                + ro__SV(ikl,isn) * Cn_dSV * dTSnow
-     .                                           * dzsnSV(ikl,isn)
-          TsisSV(ikl,isn) =                        TfSnow
- 
-C +--Water,  store Previous Content
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          drr_SV(ikl) = drr_SV(ikl)
-     .                + ro__SV(ikl,isn)          * eta_SV(ikl,isn)
-     .                                           * dzsnSV(ikl,isn)
-     .                / dt__SV
-          ro__SV(ikl,isn) =
-     .                  ro__SV(ikl,isn) *(1.     - eta_SV(ikl,isn))
-          eta_SV(ikl,isn) =  0.
- 
- 
-C +--Melting  if EExcsv > 0
-C +  ======================
- 
-          EnMelt      =    max(zero,          EExcsv(ikl) )
- 
-C +--Energy Consumption
-C +  ^^^^^^^^^^^^^^^^^^
-          SnHLat      = ro__SV(ikl,isn) * Lf_H2O
-          dzMelt(ikl) = EnMelt      / max(SnHLat,    epsi )
-          noSnow(ikl) = noSnow(ikl)
-     .      + max(zero  ,sign(unun,dzMelt(ikl)                !
-     .                            -dzsnSV(ikl ,isn)))         ! 1 if full Melt
-     .       *min(1     , max(0 ,1+isnoSV(ikl)-isn))          ! 1 in the  Pack
-          dzMelt(ikl) =
-     .              min(dzsnSV(ikl, isn),dzMelt(ikl))
-          dzsnSV(ikl,isn) =
-     .                  dzsnSV(ikl,isn) -dzMelt(ikl)
-          zn5_SV(ikl) = zn5_SV(ikl)     +dzMelt(ikl)
-          EExcsv(ikl) = EExcsv(ikl)     -dzMelt(ikl)*SnHLat
-          wem_SV(ikl) = wem_SV(ikl)     -dzMelt(ikl)*ro__SV(ikl,isn)
- 
-C +--Water  Production
-C +  ^^^^^^^^^^^^^^^^^
-          drr_SV(ikl) = drr_SV(ikl)
-     .                + ro__SV(ikl,isn) * dzMelt(ikl)/dt__SV
-! #m1     SImelt(ikl) = SImelt(ikl)
-! #m1.                + ro__SV(ikl,isn) * dzMelt(ikl)
-          OKmelt      =max(zero,sign(unun,drr_SV(ikl)-epsi))
- 
-C +--Snow History
-C +  ^^^^^^^^^^^^
-          k_face          =       min(    istoSV(ikl,isn),istdSV(1)) ! = 1  if
-     .                           *max(0,2-istoSV(ikl,isn)          ) ! faceted
-          istoSV(ikl,isn) =                                          !
-     .        (1.-OKmelt) *               istoSV(ikl,isn)            !
-     .      +     OKmelt  *((1-k_face) *  istdSV(2)                  !
-     .                     +   k_face  *  istdSV(3)      )           !
- 
- 
-C +--Freezing if EExcsv < 0
-C +  ======================
- 
-          rdzsno      =          ro__SV(ikl,isn) * dzsnSV(ikl ,isn)
-          LayrOK      = min(   1, max(0          , isnoSV(ikl)-isn+1))
-          EnFrez      = min(zero,                  EExcsv(ikl))
-          WaFrez      =   -(     EnFrez          * LayrOK / Lf_H2O)
-          drrNEW      = max(zero,drr_SV(ikl)     - WaFrez / dt__SV)
-          WaFrez      =    (     drr_SV(ikl)     - drrNEW)* dt__SV
-          drr_SV(ikl) =          drrNEW
-          EExcsv(ikl) =          EExcsv(ikl)     + WaFrez * Lf_H2O
-          EnFrez      = min(zero,EExcsv(ikl))    * LayrOK
-          rdzNEW      = WaFrez + rdzsno
-          ro__SV(ikl,isn) =      rdzNEW /max(epsi, dzsnSV(ikl,isn))
-          TsisSV(ikl,isn) =      TfSnow
-     .                + EnFrez /(Cn_dSV *max(epsi, rdzNEW)        )
-          EExcsv(ikl) =          EExcsv(ikl)     - EnFrez
-          wer_SV(ikl) = WaFrez
-     .                + wer_SV(ikl)
- 
- 
-
-C +--Snow Water Content
-C +  ==================
- 
-C +--Percolation Velocity
-C +  ^^^^^^^^^^^^^^^^^^^^
-c #PW     SGDiam    = 1.6d-4
-c #PW.              + 1.1d-13 *(ro__SV(ikl,isn)*ro__SV(ikl,isn)
-c #PW.                         *ro__SV(ikl,isn)*ro__SV(ikl,isn))
- 
-C +--Pore   Volume [-]
-C +  ^^^^^^^^^^^^^^^^^
-          rosDry      =(1.     - eta_SV(ikl,isn))* ro__SV(ikl,isn) !
-          PorVol      = 1.     - rosDry          / ro_Ice          !
-          PorVol      =      max(PorVol          , zero  )         !
- 
-C +--Water  Retention
-C +  ^^^^^^^^^^^^^^^^
-          rWater      = ws0dSV * PorVol * ro_Wat * dzsnSV(ikl,isn)
-          drrNEW      = max(zero,drr_SV(ikl)     - rWater /dt__SV)
-          rWater      =    (     drr_SV(ikl)     - drrNEW)*dt__SV
-          drr_SV(ikl)     =      drrNEW
-          rdzNEW          =      rWater
-     .                         + rosDry          * dzsnSV(ikl,isn)
-          eta_SV(ikl,isn) =      rWater / max(epsi,rdzNEW)
-          ro__SV(ikl,isn) =      rdzNEW / max(epsi,dzsnSV(ikl,isn))
- 
-C +--Pore Hole Close OFF
-C +  ^^^^^^^^^^^^^^^^^^^
-          PClose = max(zero,
-     .                 sign(unun,ro__SV(ikl,isn)
-     .                          -roCdSV         ))
-          ispiSV(ikl) =          ispiSV(ikl)      *(1.-PClose)
-     .                +      max(ispiSV(ikl),isn)    * Pclose
-          PClose = max(0   ,                         ! Water under SuPer.Ice
-     .                 min (1   ,ispiSV(ikl)         ! contributes to
-     .                          -isn            ))   ! Surficial   Water
- 
-cXF
-          if(ro__SV(ikl,isn) >= roCdSV.and.ro__SV(ikl,1)<900)
-     .    PClose = min(0.50,PClose *
-     .    (1.-(ro_ice-ro__SV(ikl,isn))/(ro_ice-roCdSV)))
- 
-          PClose = max(0.,min(1.,PClose))
- 
-          if(isn==1) then
-               PClose = 1
-           ispiSV(ikl)= max(ispiSV(ikl),1)
-          endif
- 
-          if(drr_SV(ikl)    >0  .and.TsisSV(ikl,isn)>273.14) then
-           if((ro__SV(ikl,isn)>900.and.ro__SV(ikl,isn)<920).or.
-     .         ro__SV(ikl,isn)>950) then
-             dzsnSV(ikl,isn) = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/ro_ice
-             ro__SV(ikl,isn) = ro_ice
-             PClose          = 1
-           endif
-          endif
- 
-c         if (isn>1.and.isn<nsno     .and.
-c    .      ro__SV(ikl,isn-1)>900    .and.
-c    .      ro__SV(ikl,isn)  >roCdSV .and.
-c    .      ro__SV(ikl,isn)  <900    .and.
-c    .      TsisSV(ikl,isn)  >273.14 .and.
-c    .      TsisSV(ikl,isn+1)<273.15 .and.
-c    .      drr_SV(ikl)      >0)     then
-c          TsisSV(ikl,isn)=273.14
-c          PClose = 1
-c         endif
- 
-cXF
-          rusnSV(ikl) =          rusnSV(ikl)
-     .                +          drr_SV(ikl) *dt__SV * PClose
-          rusnSV0(ikl)=         rusnSV0(ikl)
-     .                +          drr_SV(ikl) *dt__SV * PClose
-          drr_SV(ikl) =          drr_SV(ikl)      *(1.-PClose)
- 
-        END DO
-
-      END DO
- 
- 
-C +--Remove Zero-Thickness Layers
-C +  ============================
- 
- 1000 CONTINUE
-           isnitr =          0
-      DO   ikl=1,knonv
-           isnUpD =          0
-           isinew =          0
-cXF
-
-
-        DO isn=1,min(nsno-1,isnoSV(ikl))
-           isnnew =(unun-max(zero  ,sign(unun,dzsnSV(ikl,isn)-dzepsi)))
-     .             *     max(0     , min(1   ,isnoSV(ikl) +1 -isn ))
-           isnUpD =      max(isnUpD,          isnnew)
-           isnitr =      max(isnitr,          isnnew)
-           isinew =      isn*isnUpD *max(0, 1-isinew)      ! LowerMost  0-Layer
-     .                                       +isinew       ! Index
-           dzsnSV(ikl,isn) =                  dzsnSV(ikl,isn+isnnew)
-           ro__SV(ikl,isn) =                  ro__SV(ikl,isn+isnnew)
-           TsisSV(ikl,isn) =                  TsisSV(ikl,isn+isnnew)
-           eta_SV(ikl,isn) =                  eta_SV(ikl,isn+isnnew)
-           G1snSV(ikl,isn) =                  G1snSV(ikl,isn+isnnew)
-           G2snSV(ikl,isn) =                  G2snSV(ikl,isn+isnnew)
-           dzsnSV(ikl,isn+isnnew) =(1-isnnew)*dzsnSV(ikl,isn+isnnew)
-           ro__SV(ikl,isn+isnnew) =(1-isnnew)*ro__SV(ikl,isn+isnnew)
-           eta_SV(ikl,isn+isnnew) =(1-isnnew)*eta_SV(ikl,isn+isnnew)
-           G1snSV(ikl,isn+isnnew) =(1-isnnew)*G1snSV(ikl,isn+isnnew)
-           G2snSV(ikl,isn+isnnew) =(1-isnnew)*G2snSV(ikl,isn+isnnew)
-
-        END DO
-           isnoSV(ikl)   =   isnoSV(ikl)-isnUpD            ! Nb of Snow   Layer
-           ispiSV(ikl)   =   ispiSV(ikl)                   ! Nb of SuperI Layer
-     .    -isnUpD *max(0,min(ispiSV(ikl)-isinew,1))        ! Update  if I=0
- 
-      END DO
-
-      IF  (isnitr>0)                                       GO TO 1000
- 
- 
-C +--New upper Limit of the non erodible Snow (istoSV .GT. 1)
-C +  ========================================
- 
-      DO   ikl=1,knonv
-           nh =     0
-cXF
-        DO isn=  isnoSV(ikl),1,-1
-           nh =    nh + isn* min(istoSV(ikl,isn)-1,1)*max(0,1-nh)
-        ENDDO
-           zc =     0.
-           zt =     0.
-cXF
-        DO isn=1,isnoSV(ikl)
-           zc =    zc +          dzsnSV(ikl,isn) *ro__SV(ikl,isn)
-     .                     * max(0,min(1,nh+1-isn))
-           zt =    zt +          dzsnSV(ikl,isn) *ro__SV(ikl,isn)
-        END DO
-           zWE_SV(ikl) =                 zt
-           zWEcSV(ikl) = min(zWEcSV(ikl),zt)
-           zWEcSV(ikl) = max(zWEcSV(ikl),zc)
-      END DO
- 
- 
-C +--Energy Budget (OUT)
-C +  ===================
- 
-! #vm   DO ikl=1,knonv
-! #vm     EqSn01(ikl) =-EqSn_0(ikl)
-! #vm.                 -EExcsv(ikl)
-! #vm   END DO
-! #vm DO   isn=nsno,1,-1
-! #vm   DO ikl=1,knonv
-! #vm     EqSn01(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
-! #vm.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
-! #vm.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
-! #vm   END DO
-! #vm END DO
- 
- 
-C +--"Negative Heat" from supercooled rain
-C +   ------------------------------------
- 
-      DO ikl=1,knonv
-          EExcsv(ikl) = EExcsv(ikl) + EExdum(ikl)
- 
- 
-C +--Surficial Water Run OFF
-C +  -----------------------
- 
-          rusnew      = rusnSV(ikl) * SWf_SV(ikl)
- 
-          if(isnoSV(ikl)<=1 .OR. opt_runoff_ac) rusnew = 0.
-          !if(ivgtSV(ikl)>=1) rusnew = 0.
- 
-c #EU                        rusnew = 0.
-c #AC               rusnew = 0.
-
-          RnofSV(ikl) = RnofSV(ikl)
-     .                +(rusnSV(ikl) - rusnew     ) / dt__SV
-          RuofSV(ikl,1) = RuofSV(ikl,1)
-     .                +(rusnSV(ikl) - rusnew     ) / dt__SV
-          RuofSV(ikl,4) = RuofSV(ikl,4)
-     .                +(rusnSV0(ikl)             ) / dt__SV
-          rusnSV(ikl) = rusnew
-      END DO
- 
- 
-C +--Percolation down the Continental Ice Pack
-C +  -----------------------------------------
- 
-        DO ikl=1,knonv
-          drr_SV(ikl) = drr_SV(ikl) + rusnSV(ikl)
-     .                     * (1-min(1,ispiSV(ikl)))/ dt__SV
-          rusnSV(ikl) = rusnSV(ikl)
-     .                     *    min(1,ispiSV(ikl))
-        END DO
- 
-cXF removal of too thin snowlayers if TT> 275.15 + bug if TT>> 273.15
-        DO ikl=1,knonv
-         zt=0.
-         DO isn=1,isnoSV(ikl)
-          zt=zt+dzsnSV(ikl,isn)
-         ENDDO
-         
-         if(zt<0.005+(TaT_SV(ikl)-TfSnow)/1000..and.
-     .      isnoSV(ikl)             >0         .and.
-     .      TaT_SV(ikl)             >=TfSnow   .and.
-     .      istoSV(ikl,isnoSV(ikl)) >1       ) then
-          DO isn=1,isnoSV(ikl)
-           drr_SV(ikl)    = drr_SV(ikl)
-     .                    + dzsnSV(ikl,isn)*ro__SV(ikl,isn) /dt__SV
-           dzsnSV(ikl,isn)= 0.
-
-          ENDDO
-          isnoSV(ikl)     = 0
-         endif
-        ENDDO
- 
-C +--Slush Formation (Activated. CAUTION: ADD RunOff Possibility before Activation)
-C +  ---------------  ^^^^^^^  ^^^
- 
-      IF (is_ok_slush) THEN 
-
-      DO  ikl=1,knonv
-       DO isn=1,isnoSV(ikl)
-          kSlush = min(1,max(0,isn+1-ispiSV(ikl)))        ! Slush Switch
- 
-C +--Available Additional Pore   Volume [-]
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          PorVol = 1. - ro__SV(ikl,isn)                    ! [--]
-     .           *(1. - eta_SV(ikl,isn))/ ro_Ice           !
-     .           -      eta_SV(ikl,isn)                    !
-     .                 *ro__SV(ikl,isn) / ro_Wat           !
-          PorVol =  max(PorVol          , zero  )          !
-          zWater =      dzsnSV(ikl,isn) * PorVol * 1000.   ! [mm] OR [kg/m2]
-     .           * (1. -SWS_SV(ikl)                        ! 0 <=> freezing
-     .                *(1 -min(1,iabs(isn-isnoSV(ikl)))))  ! 1 <=> isn=isnoSV
-          zSlush =  min(rusnSV(ikl)     , zWater)          ! [mm] OR [kg/m2]
-          ro_new      =(dzsnSV(ikl,isn) * ro__SV(ikl,isn)  !
-     .                 +zSlush                           ) !
-     .            / max(dzsnSV(ikl,isn) , epsi           ) !
-          if(ro_new<ro_Ice+20) then ! MAX 940kg/m3         !
-           rusnSV(ikl)  = rusnSV(ikl)          - zSlush    ! [mm] OR [kg/m2]
-           RuofSV(ikl,4)= max(0.,RuofSV(ikl,4) - zSlush/dt__SV)
-           eta_SV(ikl,isn) =(ro_new - ro__SV(ikl,isn)      !
-     .                     *(1.     - eta_SV(ikl,isn)))    !
-     .                / max (ro_new , epsi            )    !
-           ro__SV(ikl,isn) =      ro_new                   !
-          endif
-        END DO
-      END DO
-      END IF
- 
-C +--Impact of the Sublimation/Deposition on the Surface Mass Balance
-C +  ================================================================
- 
-      DO ikl=1,knonv
-         isn                     = isnoSV(ikl)
-          dzVap0                  =                   dt__SV
-     .  * HLs_sv(ikl)         * min(isn             , 1   )
-     .  /(Lx_H2O(ikl)         * max(ro__SV(ikl,isn) , epsi))
-          NOLayr=min(zero,sign(unun,dzsnSV(ikl,isn) + dzVap0))
-          dzVap1=min(zero,          dzsnSV(ikl,isn) + dzVap0)
- 
- 
-C +--Additional Energy
-C +  -----------------
- 
-c #VH     AdEnrg = dzVap0 * ro__SV(ikl,isnoSV(ikl))           ! Water   Vapor
-c #VH.            *C__Wat *(TsisSV(ikl,isnoSV(ikl)) -TfSnow)  ! Sensible Heat
- 
-c #aH     B_Enrg =(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
-c #aH.            -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
-c #aH.           /(1.          + dzVap0 /max(epsi,dzsnSV(ikl,isn)))
-c #aH     eta_SV(ikl,isn) =
-c #aH.           max(zero,unun +(B_Enrg
-c #aH.                         -(TsisSV(ikl,isn) -TfSnow)*Cn_dSV)
-c #aH.                          /Lf_H2O                          )
-c #aH     TsisSV(ikl,isn) =    ( B_Enrg
-c #aH.                         +(1.              -eta_SV(ikl,isn))
-c #aH.                          *Lf_H2O                          )
-c #aH.                         / Cn_dSV
-c #aH.                         + TfSnow
- 
-! #e1     STOP "PLEASE add Energy (#aH) from deposition/sublimation"
- 
- 
-C +--Update of the upper Snow layer Thickness
-C +  ----------------------------------------
- 
-          dzsnSV(ikl,isn) =
-     .           max(zero,  dzsnSV(ikl,isnoSV(ikl)) + dzVap0)
-          isnoSV(ikl)     = isnoSV(ikl)             + NOLayr
-          isn             = isnoSV(ikl)
-          dzsnSV(ikl,isn) = dzsnSV(ikl,isn) + dzVap1
-          wes_SV(ikl)     = ro__SV(ikl,isn) * dzVap0
-
-      END DO
- 
- 
-C +--Energy Budget (OUT)
-C +  ===================
- 
-! #vm   DO ikl=1,knonv
-! #vm     EqSn02(ikl) =-EqSn_0(ikl)
-! #vm.                 -EExcsv(ikl)
-! #vm   END DO
-! #vm DO   isn=nsno,1,-1
-! #vm   DO ikl=1,knonv
-! #vm     EqSn02(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
-! #vm.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
-! #vm.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
-! #vm   END DO
-! #vm END DO
- 
- 
-C +--Snow/I Budget
-C +  -------------
- 
-! #m1   DO ikl=1,knonv
-! #m1     SIsubl(ikl) = dt__SV*HLs_sv(ikl)*min(isnoSV(ikl),1)
-! #m1.                        /Lx_H2O(ikl)
-! #m1     SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV
-! #m1.                - SIrnof(ikl)
-! #m1   END DO
- 
- 
-C +--Anticipated Disappearance of a rapidly Melting too thin Last Snow Layer
-C +  =======================================================================
- 
-      DO ikl=1,knonv
-        LastOK = min(1   , max(0   ,iiceSV(ikl)-isnoSV(ikl)+2)
-     .                    *min(1   ,isnoSV(ikl)-iiceSV(ikl))
-     .                    +min(1   ,isnoSV(ikl))              )
-        RapdOK = max(zero,sign(unun,dzMelt(ikl)-epsi         ))
-        ThinOK = max(zero,sign(unun,dz_Min     -dzsnSV(ikl,1)))
-        z_Melt = LastOK     *RapdOK*ThinOK
-        noSnow(ikl)   = noSnow(ikl)   + z_Melt
-        z_Melt        =                 z_Melt *dzsnSV(ikl,1)
-        dzsnSV(ikl,1) = dzsnSV(ikl,1) - z_Melt
-        EExcsv(ikl)   = EExcsv(ikl)   - z_Melt *ro__SV(ikl,1)
-     .                                *(1.     -eta_SV(ikl,1))*Lf_H2O
- 
-C +--Water  Production
-C +  ^^^^^^^^^^^^^^^^^
-        drr_SV(ikl)   = drr_SV(ikl)
-     .                + ro__SV(ikl,1) * z_Melt /dt__SV
-      END DO
- 
- 
-C +--Update Nb of Layers
-C +  ===================
- 
-      DO ikl=1,knonv
-        isnoSV(ikl)   = isnoSV(ikl)
-     .     * min(1,iabs(isnoSV(ikl)-noSnow(ikl)))
-      END DO
- 
- 
-! Energy Budget (OUT)
-! ===================
- 
-! #e1   DO ikl=1,knonv
-! #e1     EqSn_1(ikl) = 0.
-! #e1   END DO
-! #e1 DO   isn=nsno,1,-1
-! #e1   DO ikl=1,knonv
-! #e1     EqSn_1(ikl) = EqSn_1(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
-! #e1.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
-! #e1.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
-! #e1   END DO
-! #e1 END DO
- 
- 
-C +--Water  Budget (OUT)
-C +  ===================
- 
-! #vm   DO ikl=1,knonv
-! #vm     WqSn_0(ikl) = WqSn_0(ikl)
-! #vm.                + HLs_sv(ikl)    * dt__SV
-! #vm.             *min(isnoSV(ikl),1) / Lx_H2O(ikl)
-! #vm     WqSn_1(ikl) = drr_SV(ikl)    * dt__SV
-! #vm.                + rusnSV(ikl)
-! #vm.                + RnofSV(ikl)    * dt__SV
-! #vm   END DO
-! #vm DO   isn=nsno,1,-1
-! #vm   DO ikl=1,knonv
-! #vm     WqSn_1(ikl) = WqSn_1(ikl)
-! #vm.                + ro__SV(ikl,isn)* dzsnSV(ikl,isn)
-! #vm   END DO
-! #vm END DO
- 
- 
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qsn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qsn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qsn.f90	(revision 5105)
@@ -0,0 +1,717 @@
+
+
+SUBROUTINE SISVAT_qSn &
+        ( &
+  ! #e1.                      EqSn_0,EqSn_1,EqSn_d
+  ! #m1.                     ,SIsubl,SImelt,SIrnof
+        )
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_qSn                           Fri 29-Jul-2011  MAR |
+  ! |   SubRoutine SISVAT_qSn updates  the Snow Water Content                |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   ^^^^^                                                                |
+  ! |                                                                        |
+  ! |   INPUT:   TaT_SV   : SBL Top    Temperature                       [K] |
+  ! |   ^^^^^    dt__SV   : Time Step                                    [s] |
+  ! |                                                                        |
+  ! |   INPUT /  drr_SV   : Rain Intensity                         [kg/m2/s] |
+  ! |   OUTPUT:  dzsnSV   : Snow Layer Thickness                         [m] |
+  ! |   ^^^^^^   eta_SV   : Snow Water Content                       [m3/m3] |
+  ! |            ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
+  ! |            TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+  ! |                     & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  ! |                                                                        |
+  ! |   OUTPUT:  SWS_SV   : Surficial Water Status                           |
+  ! |   ^^^^^^                                                               |
+  ! |            EExcsv   : Snow Energy in Excess, initial Forcing    [J/m2] |
+  ! |            EqSn_d   : Snow Energy in Excess, remaining          [J/m2] |
+  ! |            EqSn_0   : Snow Energy, before Phase Change          [J/m2] |
+  ! |            EqSn_1   : Snow Energy, after  Phase Change          [J/m2] |
+  ! |            SIsubl   : Snow sublimed/deposed Mass             [mm w.e.] |
+  ! |            SImelt   : Snow Melted           Mass             [mm w.e.] |
+  ! |            SIrnof   : Surficial Water + Run OFF Change       [mm w.e.] |
+  ! |                                                                        |
+  ! |   Internal Variables:                                                  |
+  ! |   ^^^^^^^^^^^^^^^^^^                                                   |
+  ! |                                                                        |
+  ! | # OPTIONS: #E0: IO for Verification: Energy       Budget               |
+  ! | # ^^^^^^^                                                              |
+  ! | #          #su: IO for Verification: Slush        Diagnostic           |
+  ! |                                                                        |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VAR0SV
+  use VARxSV
+  use VARySV
+  use surface_data, only: is_ok_slush,opt_runoff_ac
+
+
+  IMPLICIT NONE
+
+
+  ! Energy          Budget
+  ! ~~~~~~~~~~~~~~~~~~~~~~
+  ! #e1 real     EqSn_d(knonv)                 ! Energy in Excess, initial
+  ! #e1 real     EqSn_0(knonv)                 ! Snow Energy, befor Phase Change
+  ! #vm real     EqSn01(knonv)                 ! Snow Energy, after Phase Change
+  ! #vm real     EqSn02(knonv)                 ! Snow Energy, after Phase Change
+                                         ! !              .AND. Last Melting
+  ! #e1 real     EqSn_1(knonv)                 ! Snow Energy, after Phase Change
+                                         ! !              .AND. Mass Redistr.
+  ! Snow/Ice (Mass) Budget
+  ! ~~~~~~~~~~~~~~~~~~~~~~
+  ! #m1 real     SIsubl(knonv)                 ! Snow Deposed Mass
+  ! #m1 real     SImelt(knonv)                 ! Snow Melted  Mass
+  ! #m1 real     SIrnof(knonv)                 ! Local Surficial Water + Run OFF
+
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  integer :: ikl   ,isn                    !
+  integer :: nh                            ! Non erodible Snow: up.lay.Index
+  integer :: LayrOK                        ! 1 (0)  if In(Above) Snow Pack
+  integer :: k_face                        ! 1 (0)  if Crystal(no) faceted
+  integer :: LastOK                        ! 1 ==>  1! Snow Layer
+  integer :: NOLayr                        ! 1     Layer  Update
+  integer :: noSnow(knonv)                 ! Nb of Layers Updater
+  integer :: kSlush                        ! Slush Switch
+  real :: dTSnow                        ! Temperature                  [C]
+  real :: EExdum(knonv)                 ! Energy in Excess when no Snow
+  real :: OKmelt                        ! 1 (0)  if        (no) Melting
+  real :: EnMelt                        ! Energy in excess, for Melting
+  real :: SnHLat                        ! Energy consumed   in  Melting
+  real :: AdEnrg,B_Enrg                 ! Additional Energy from  Vapor
+  real :: dzVap0,dzVap1                 ! Vaporized Thickness          [m]
+  real :: dzMelt(knonv)                 ! Melted    Thickness          [m]
+  real :: rosDry                        ! Snow volumic Mass if no Water in
+  real :: PorVol                        ! Pore volume
+  real :: PClose                        ! Pore Hole Close OFF Switch
+  real :: SGDiam                        !      Snow Grain Diameter
+  real :: SGDmax                        ! Max. Snow Grain Diameter
+  real :: rWater                        ! Retained Water           [kg/m2]
+  real :: drrNEW                        ! New available Water      [kg/m2]
+  real :: rdzNEW                        ! Snow          Mass       [kg/m2]
+  real :: rdzsno                        ! Snow          Mass       [kg/m2]
+  real :: EnFrez                        ! Energy Release    in  Freezing
+  real :: WaFrez                        ! Water  consumed   in  Melting
+  real :: RapdOK                        ! 1. ==> Snow melts rapidly
+  real :: ThinOK                        ! 1. ==> Snow Layer is thin
+  real :: dzepsi                        ! Minim. Snow Layer Thickness (!)
+  real :: dz_Min                        ! Minim. Snow Layer Thickness
+  real :: z_Melt                        ! Last (thin) Layer Melting
+  real :: rusnew                        ! Surficial Water Thickness   [mm]
+  real :: zWater                        ! Max Slush Water Thickness   [mm]
+  real :: zSlush                        !     Slush Water Thickness   [mm]
+  real :: ro_new                        ! New Snow/ice  Density    [kg/m3]
+  real :: zc,zt                         ! Non erod.Snow Thickness[mm w.e.]
+  real :: rusnSV0(knonv)
+  real :: Tsave
+
+  ! +--OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT)
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  integer :: isnnew,isinew,isnUpD,isnitr
+
+  ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+  ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ! #wx integer             iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1
+  ! #wx common/SISVAT_EV/   iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1
+
+  ! +--Energy and Mass Budget
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~
+  ! #vm real     WqSn_0(knonv)                 ! Snow Water+Forcing  Initial
+  ! #vm real     WqSn_1(knonv)                 ! Snow Water+Forcing, Final
+  ! #vm logical         emopen                 ! IO   Switch
+  ! #vm common/Se_qSn_L/emopen                 !
+  ! #vm integer         no_err                 !
+  ! #vm common/Se_qSn_I/no_err                 !
+  ! #vm real     hourer,timeer                 !
+  ! #vm common/Se_qSn_R/timeer                 !
+
+  ! +--Slush Diagnostic: IO
+  ! +  ~~~~~~~~~~~~~~~~~~~~
+  ! #vu logical         su_opn                 ! IO   Switch
+  ! #vu common/SI_qSn_L/su_opn                 !
+
+
+  ! +--DATA
+  ! +  ====
+
+  data      dzepsi/0.0001/                ! Minim. Snow Layer Thickness (!)
+  ! #?? data      dz_Min/0.005/                 ! Minim. Snow Layer Thickness
+  ! ... Warning: Too high for Col de Porte: precludes 1st snow (layer) apparition
+  data      dz_Min/2.5e-3/                ! Minim. Snow Layer Thickness
+  data      SGDmax/0.003/                 ! Maxim. Snow Grain Diameter  [m]
+                                          ! ! (Rowe et al. 1995, JGR p.16268)
+
+  ! +--Energy Budget (IN)
+  ! +  ==================
+
+  ! #e1   DO ikl=1,knonv
+  ! #e1     EqSn_0(ikl) = 0.
+  ! #e1   END DO
+  ! #e1 DO   isn=nsno,1,-1
+  ! #e1   DO ikl=1,knonv
+  ! #e1     EqSn_0(ikl) = EqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
+  ! #e1.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
+  ! #e1.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
+  ! #e1   END DO
+  ! #e1 END DO
+
+
+  ! +--Water  Budget (IN)
+  ! +  ==================
+
+  ! #vm   DO ikl=1,knonv
+  ! #vm     WqSn_0(ikl) = drr_SV(ikl) * dt__SV
+  ! #vm.                 +rusnSV(ikl)
+  ! #vm   END DO
+  ! #vm DO   isn=nsno,1,-1
+  ! #vm   DO ikl=1,knonv
+  ! #vm     WqSn_0(ikl) = WqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
+  ! #vm   END DO
+  ! #vm END DO
+
+
+  ! +--Snow Melt Budget
+  ! +  ================
+
+  ! #m1   DO ikl=1,knonv
+  ! #m1     SImelt(ikl) = 0.
+  ! #m1     SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV
+  ! #m1   END DO
+
+
+  ! +--Initialization
+  ! +  ==============
+
+  DO ikl=1,knonv
+    noSnow(ikl)   = 0                   ! Nb of Layers Updater
+    ispiSV(ikl)   = 0                   ! Pore Hole Close OFF Index
+                                        ! ! (assumed to be the Top of
+                                        ! !  the surimposed Ice Layer)
+    zn5_SV(ikl)   = 0.
+    rusnSV0(ikl)  = 0.
+
+  END DO
+
+
+  ! +--Melting/Freezing Energy
+  ! +  =======================
+
+  ! +...REMARK: Snow liquid Water Temperature assumed = TfSnow
+  ! +   ^^^^^^
+    DO ikl=1,knonv
+      EExdum(ikl) = drr_SV(ikl)     * C__Wat *(TaT_SV(ikl)-TfSnow) &
+            * dt__SV
+      EExcsv(ikl) = EExdum(ikl)     *    min(1,isnoSV(ikl)) ! Snow exists
+      EExdum(ikl) = EExdum(ikl)     -          EExcsv(ikl)  !
+  ! #e1     EqSn_d(ikl) = EExcsv(ikl)                             !
+    END DO
+
+
+  ! +--Surficial Water Status
+  ! +  ----------------------
+
+    DO ikl=1,knonv
+      SWS_SV(ikl) = max(zero,sign(unun,TfSnow &
+            -TsisSV(ikl,isnoSV(ikl))))
+    END DO
+
+  DO ikl=1,knonv
+
+  DO isn=min(nsno,isnoSV(ikl)+1),1,-1
+  ! EV          DO isn=nsno,1,-1
+  ! +--Energy, store Previous Content
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      dTSnow      = TsisSV(ikl,isn) -          TfSnow
+      EExcsv(ikl) = EExcsv(ikl) &
+            + ro__SV(ikl,isn) * Cn_dSV * dTSnow &
+            * dzsnSV(ikl,isn)
+      TsisSV(ikl,isn) =                        TfSnow
+
+  ! +--Water,  store Previous Content
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      drr_SV(ikl) = drr_SV(ikl) &
+            + ro__SV(ikl,isn)          * eta_SV(ikl,isn) &
+            * dzsnSV(ikl,isn) &
+            / dt__SV
+      ro__SV(ikl,isn) = &
+            ro__SV(ikl,isn) *(1.     - eta_SV(ikl,isn))
+      eta_SV(ikl,isn) =  0.
+
+
+  ! +--Melting  if EExcsv > 0
+  ! +  ======================
+
+      EnMelt      =    max(zero,          EExcsv(ikl) )
+
+  ! +--Energy Consumption
+  ! +  ^^^^^^^^^^^^^^^^^^
+      SnHLat      = ro__SV(ikl,isn) * Lf_H2O
+      dzMelt(ikl) = EnMelt      / max(SnHLat,    epsi )
+      noSnow(ikl) = noSnow(ikl) &
+            + max(zero  ,sign(unun,dzMelt(ikl) & !
+            -dzsnSV(ikl ,isn))) & ! 1 if full Melt
+            *min(1     , max(0 ,1+isnoSV(ikl)-isn))          ! 1 in the  Pack
+      dzMelt(ikl) = &
+            min(dzsnSV(ikl, isn),dzMelt(ikl))
+      dzsnSV(ikl,isn) = &
+            dzsnSV(ikl,isn) -dzMelt(ikl)
+      zn5_SV(ikl) = zn5_SV(ikl)     +dzMelt(ikl)
+      EExcsv(ikl) = EExcsv(ikl)     -dzMelt(ikl)*SnHLat
+      wem_SV(ikl) = wem_SV(ikl)     -dzMelt(ikl)*ro__SV(ikl,isn)
+
+  ! +--Water  Production
+  ! +  ^^^^^^^^^^^^^^^^^
+      drr_SV(ikl) = drr_SV(ikl) &
+            + ro__SV(ikl,isn) * dzMelt(ikl)/dt__SV
+  ! #m1     SImelt(ikl) = SImelt(ikl)
+  ! #m1.                + ro__SV(ikl,isn) * dzMelt(ikl)
+      OKmelt      =max(zero,sign(unun,drr_SV(ikl)-epsi))
+
+  ! +--Snow History
+  ! +  ^^^^^^^^^^^^
+      k_face          =       min(    istoSV(ikl,isn),istdSV(1)) & ! = 1  if
+            *max(0,2-istoSV(ikl,isn)          ) ! faceted
+      istoSV(ikl,isn) = & !
+            (1.-OKmelt) *               istoSV(ikl,isn) & !
+            +     OKmelt  *((1-k_face) *  istdSV(2) & !
+            +   k_face  *  istdSV(3)      )           !
+
+
+  ! +--Freezing if EExcsv < 0
+  ! +  ======================
+
+      rdzsno      =          ro__SV(ikl,isn) * dzsnSV(ikl ,isn)
+      LayrOK      = min(   1, max(0          , isnoSV(ikl)-isn+1))
+      EnFrez      = min(zero,                  EExcsv(ikl))
+      WaFrez      =   -(     EnFrez          * LayrOK / Lf_H2O)
+      drrNEW      = max(zero,drr_SV(ikl)     - WaFrez / dt__SV)
+      WaFrez      =    (     drr_SV(ikl)     - drrNEW)* dt__SV
+      drr_SV(ikl) =          drrNEW
+      EExcsv(ikl) =          EExcsv(ikl)     + WaFrez * Lf_H2O
+      EnFrez      = min(zero,EExcsv(ikl))    * LayrOK
+      rdzNEW      = WaFrez + rdzsno
+      ro__SV(ikl,isn) =      rdzNEW /max(epsi, dzsnSV(ikl,isn))
+      TsisSV(ikl,isn) =      TfSnow &
+            + EnFrez /(Cn_dSV *max(epsi, rdzNEW)        )
+      EExcsv(ikl) =          EExcsv(ikl)     - EnFrez
+      wer_SV(ikl) = WaFrez &
+            + wer_SV(ikl)
+
+
+
+  ! +--Snow Water Content
+  ! +  ==================
+
+  ! +--Percolation Velocity
+  ! +  ^^^^^^^^^^^^^^^^^^^^
+  ! #PW     SGDiam    = 1.6d-4
+  ! #PW.              + 1.1d-13 *(ro__SV(ikl,isn)*ro__SV(ikl,isn)
+  ! #PW.                         *ro__SV(ikl,isn)*ro__SV(ikl,isn))
+
+  ! +--Pore   Volume [-]
+  ! +  ^^^^^^^^^^^^^^^^^
+      rosDry      =(1.     - eta_SV(ikl,isn))* ro__SV(ikl,isn) !
+      PorVol      = 1.     - rosDry          / ro_Ice          !
+      PorVol      =      max(PorVol          , zero  )         !
+
+  ! +--Water  Retention
+  ! +  ^^^^^^^^^^^^^^^^
+      rWater      = ws0dSV * PorVol * ro_Wat * dzsnSV(ikl,isn)
+      drrNEW      = max(zero,drr_SV(ikl)     - rWater /dt__SV)
+      rWater      =    (     drr_SV(ikl)     - drrNEW)*dt__SV
+      drr_SV(ikl)     =      drrNEW
+      rdzNEW          =      rWater &
+            + rosDry          * dzsnSV(ikl,isn)
+      eta_SV(ikl,isn) =      rWater / max(epsi,rdzNEW)
+      ro__SV(ikl,isn) =      rdzNEW / max(epsi,dzsnSV(ikl,isn))
+
+  ! +--Pore Hole Close OFF
+  ! +  ^^^^^^^^^^^^^^^^^^^
+      PClose = max(zero, &
+            sign(unun,ro__SV(ikl,isn) &
+            -roCdSV         ))
+      ispiSV(ikl) =          ispiSV(ikl)      *(1.-PClose) &
+            +      max(ispiSV(ikl),isn)    * Pclose
+      PClose = max(0   , & ! Water under SuPer.Ice
+            min (1   ,ispiSV(ikl) & ! contributes to
+            -isn            ))   ! Surficial   Water
+
+  !XF
+      if(ro__SV(ikl,isn) >= roCdSV.and.ro__SV(ikl,1)<900) &
+            PClose = min(0.50,PClose * &
+            (1.-(ro_ice-ro__SV(ikl,isn))/(ro_ice-roCdSV)))
+
+      PClose = max(0.,min(1.,PClose))
+
+      if(isn==1) then
+           PClose = 1
+       ispiSV(ikl)= max(ispiSV(ikl),1)
+      endif
+
+      if(drr_SV(ikl)    >0  .and.TsisSV(ikl,isn)>273.14) then
+       if((ro__SV(ikl,isn)>900.and.ro__SV(ikl,isn)<920).or. &
+             ro__SV(ikl,isn)>950) then
+         dzsnSV(ikl,isn) = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/ro_ice
+         ro__SV(ikl,isn) = ro_ice
+         PClose          = 1
+       endif
+      endif
+
+      ! if (isn>1.and.isn<nsno     .and.
+  !    .      ro__SV(ikl,isn-1)>900    .and.
+  !    .      ro__SV(ikl,isn)  >roCdSV .and.
+  !    .      ro__SV(ikl,isn)  <900    .and.
+  !    .      TsisSV(ikl,isn)  >273.14 .and.
+  !    .      TsisSV(ikl,isn+1)<273.15 .and.
+  !    .      drr_SV(ikl)      >0)     then
+      !  TsisSV(ikl,isn)=273.14
+      !  PClose = 1
+      ! endif
+
+  !XF
+      rusnSV(ikl) =          rusnSV(ikl) &
+            +          drr_SV(ikl) *dt__SV * PClose
+      rusnSV0(ikl)=         rusnSV0(ikl) &
+            +          drr_SV(ikl) *dt__SV * PClose
+      drr_SV(ikl) =          drr_SV(ikl)      *(1.-PClose)
+
+    END DO
+
+  END DO
+
+
+  ! +--Remove Zero-Thickness Layers
+  ! +  ============================
+
+ 1000   CONTINUE
+       isnitr =          0
+  DO   ikl=1,knonv
+       isnUpD =          0
+       isinew =          0
+  !XF
+
+
+    DO isn=1,min(nsno-1,isnoSV(ikl))
+       isnnew =(unun-max(zero  ,sign(unun,dzsnSV(ikl,isn)-dzepsi))) &
+             *     max(0     , min(1   ,isnoSV(ikl) +1 -isn ))
+       isnUpD =      max(isnUpD,          isnnew)
+       isnitr =      max(isnitr,          isnnew)
+       isinew =      isn*isnUpD *max(0, 1-isinew) & ! LowerMost  0-Layer
+             +isinew       ! Index
+       dzsnSV(ikl,isn) =                  dzsnSV(ikl,isn+isnnew)
+       ro__SV(ikl,isn) =                  ro__SV(ikl,isn+isnnew)
+       TsisSV(ikl,isn) =                  TsisSV(ikl,isn+isnnew)
+       eta_SV(ikl,isn) =                  eta_SV(ikl,isn+isnnew)
+       G1snSV(ikl,isn) =                  G1snSV(ikl,isn+isnnew)
+       G2snSV(ikl,isn) =                  G2snSV(ikl,isn+isnnew)
+       dzsnSV(ikl,isn+isnnew) =(1-isnnew)*dzsnSV(ikl,isn+isnnew)
+       ro__SV(ikl,isn+isnnew) =(1-isnnew)*ro__SV(ikl,isn+isnnew)
+       eta_SV(ikl,isn+isnnew) =(1-isnnew)*eta_SV(ikl,isn+isnnew)
+       G1snSV(ikl,isn+isnnew) =(1-isnnew)*G1snSV(ikl,isn+isnnew)
+       G2snSV(ikl,isn+isnnew) =(1-isnnew)*G2snSV(ikl,isn+isnnew)
+
+    END DO
+       isnoSV(ikl)   =   isnoSV(ikl)-isnUpD            ! Nb of Snow   Layer
+       ispiSV(ikl)   =   ispiSV(ikl) & ! Nb of SuperI Layer
+             -isnUpD *max(0,min(ispiSV(ikl)-isinew,1))        ! Update  if I=0
+
+  END DO
+
+  IF  (isnitr>0)                                       GO TO 1000
+
+
+  ! +--New upper Limit of the non erodible Snow (istoSV .GT. 1)
+  ! +  ========================================
+
+  DO   ikl=1,knonv
+       nh =     0
+  !XF
+    DO isn=  isnoSV(ikl),1,-1
+       nh =    nh + isn* min(istoSV(ikl,isn)-1,1)*max(0,1-nh)
+    ENDDO
+       zc =     0.
+       zt =     0.
+  !XF
+    DO isn=1,isnoSV(ikl)
+       zc =    zc +          dzsnSV(ikl,isn) *ro__SV(ikl,isn) &
+             * max(0,min(1,nh+1-isn))
+       zt =    zt +          dzsnSV(ikl,isn) *ro__SV(ikl,isn)
+    END DO
+       zWE_SV(ikl) =                 zt
+       zWEcSV(ikl) = min(zWEcSV(ikl),zt)
+       zWEcSV(ikl) = max(zWEcSV(ikl),zc)
+  END DO
+
+
+  ! +--Energy Budget (OUT)
+  ! +  ===================
+
+  ! #vm   DO ikl=1,knonv
+  ! #vm     EqSn01(ikl) =-EqSn_0(ikl)
+  ! #vm.                 -EExcsv(ikl)
+  ! #vm   END DO
+  ! #vm DO   isn=nsno,1,-1
+  ! #vm   DO ikl=1,knonv
+  ! #vm     EqSn01(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
+  ! #vm.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
+  ! #vm.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
+  ! #vm   END DO
+  ! #vm END DO
+
+
+  ! +--"Negative Heat" from supercooled rain
+  ! +   ------------------------------------
+
+  DO ikl=1,knonv
+      EExcsv(ikl) = EExcsv(ikl) + EExdum(ikl)
+
+
+  ! +--Surficial Water Run OFF
+  ! +  -----------------------
+
+      rusnew      = rusnSV(ikl) * SWf_SV(ikl)
+
+      if(isnoSV(ikl)<=1 .OR. opt_runoff_ac) rusnew = 0.
+      ! !if(ivgtSV(ikl)>=1) rusnew = 0.
+
+  ! #EU                        rusnew = 0.
+  ! #AC               rusnew = 0.
+
+      RnofSV(ikl) = RnofSV(ikl) &
+            +(rusnSV(ikl) - rusnew     ) / dt__SV
+      RuofSV(ikl,1) = RuofSV(ikl,1) &
+            +(rusnSV(ikl) - rusnew     ) / dt__SV
+      RuofSV(ikl,4) = RuofSV(ikl,4) &
+            +(rusnSV0(ikl)             ) / dt__SV
+      rusnSV(ikl) = rusnew
+  END DO
+
+
+  ! +--Percolation down the Continental Ice Pack
+  ! +  -----------------------------------------
+
+    DO ikl=1,knonv
+      drr_SV(ikl) = drr_SV(ikl) + rusnSV(ikl) &
+            * (1-min(1,ispiSV(ikl)))/ dt__SV
+      rusnSV(ikl) = rusnSV(ikl) &
+            *    min(1,ispiSV(ikl))
+    END DO
+
+  !XF removal of too thin snowlayers if TT> 275.15 + bug if TT>> 273.15
+    DO ikl=1,knonv
+     zt=0.
+     DO isn=1,isnoSV(ikl)
+      zt=zt+dzsnSV(ikl,isn)
+     ENDDO
+
+     if(zt<0.005+(TaT_SV(ikl)-TfSnow)/1000..and. &
+           isnoSV(ikl)             >0         .and. &
+           TaT_SV(ikl)             >=TfSnow   .and. &
+           istoSV(ikl,isnoSV(ikl)) >1       ) then
+      DO isn=1,isnoSV(ikl)
+       drr_SV(ikl)    = drr_SV(ikl) &
+             + dzsnSV(ikl,isn)*ro__SV(ikl,isn) /dt__SV
+       dzsnSV(ikl,isn)= 0.
+
+      ENDDO
+      isnoSV(ikl)     = 0
+     endif
+    ENDDO
+
+  ! +--Slush Formation (Activated. CAUTION: ADD RunOff Possibility before Activation)
+  ! +  ---------------  ^^^^^^^  ^^^
+
+  IF (is_ok_slush) THEN
+
+  DO  ikl=1,knonv
+   DO isn=1,isnoSV(ikl)
+      kSlush = min(1,max(0,isn+1-ispiSV(ikl)))        ! Slush Switch
+
+  ! +--Available Additional Pore   Volume [-]
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      PorVol = 1. - ro__SV(ikl,isn) & ! [--]
+            *(1. - eta_SV(ikl,isn))/ ro_Ice & !
+            -      eta_SV(ikl,isn) & !
+            *ro__SV(ikl,isn) / ro_Wat           !
+      PorVol =  max(PorVol          , zero  )          !
+      zWater =      dzsnSV(ikl,isn) * PorVol * 1000. & ! [mm] OR [kg/m2]
+            * (1. -SWS_SV(ikl) & ! 0 <=> freezing
+            *(1 -min(1,iabs(isn-isnoSV(ikl)))))  ! 1 <=> isn=isnoSV
+      zSlush =  min(rusnSV(ikl)     , zWater)          ! [mm] OR [kg/m2]
+      ro_new      =(dzsnSV(ikl,isn) * ro__SV(ikl,isn) & !
+            +zSlush                           ) & !
+            / max(dzsnSV(ikl,isn) , epsi           ) !
+      if(ro_new<ro_Ice+20) then ! MAX 940kg/m3         !
+       rusnSV(ikl)  = rusnSV(ikl)          - zSlush    ! [mm] OR [kg/m2]
+       RuofSV(ikl,4)= max(0.,RuofSV(ikl,4) - zSlush/dt__SV)
+       eta_SV(ikl,isn) =(ro_new - ro__SV(ikl,isn) & !
+             *(1.     - eta_SV(ikl,isn))) & !
+             / max (ro_new , epsi            )    !
+       ro__SV(ikl,isn) =      ro_new                   !
+      endif
+    END DO
+  END DO
+  END IF
+
+  ! +--Impact of the Sublimation/Deposition on the Surface Mass Balance
+  ! +  ================================================================
+
+  DO ikl=1,knonv
+     isn                     = isnoSV(ikl)
+      dzVap0                  =                   dt__SV &
+            * HLs_sv(ikl)         * min(isn             , 1   ) &
+            /(Lx_H2O(ikl)         * max(ro__SV(ikl,isn) , epsi))
+      NOLayr=min(zero,sign(unun,dzsnSV(ikl,isn) + dzVap0))
+      dzVap1=min(zero,          dzsnSV(ikl,isn) + dzVap0)
+
+
+  ! +--Additional Energy
+  ! +  -----------------
+
+  ! #VH     AdEnrg = dzVap0 * ro__SV(ikl,isnoSV(ikl))           ! Water   Vapor
+  ! #VH.            *C__Wat *(TsisSV(ikl,isnoSV(ikl)) -TfSnow)  ! Sensible Heat
+
+  ! #aH     B_Enrg =(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
+  ! #aH.            -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
+  ! #aH.           /(1.          + dzVap0 /max(epsi,dzsnSV(ikl,isn)))
+  ! #aH     eta_SV(ikl,isn) =
+  ! #aH.           max(zero,unun +(B_Enrg
+  ! #aH.                         -(TsisSV(ikl,isn) -TfSnow)*Cn_dSV)
+  ! #aH.                          /Lf_H2O                          )
+  ! #aH     TsisSV(ikl,isn) =    ( B_Enrg
+  ! #aH.                         +(1.              -eta_SV(ikl,isn))
+  ! #aH.                          *Lf_H2O                          )
+  ! #aH.                         / Cn_dSV
+  ! #aH.                         + TfSnow
+
+  ! #e1     STOP "PLEASE add Energy (#aH) from deposition/sublimation"
+
+
+  ! +--Update of the upper Snow layer Thickness
+  ! +  ----------------------------------------
+
+      dzsnSV(ikl,isn) = &
+            max(zero,  dzsnSV(ikl,isnoSV(ikl)) + dzVap0)
+      isnoSV(ikl)     = isnoSV(ikl)             + NOLayr
+      isn             = isnoSV(ikl)
+      dzsnSV(ikl,isn) = dzsnSV(ikl,isn) + dzVap1
+      wes_SV(ikl)     = ro__SV(ikl,isn) * dzVap0
+
+  END DO
+
+
+  ! +--Energy Budget (OUT)
+  ! +  ===================
+
+  ! #vm   DO ikl=1,knonv
+  ! #vm     EqSn02(ikl) =-EqSn_0(ikl)
+  ! #vm.                 -EExcsv(ikl)
+  ! #vm   END DO
+  ! #vm DO   isn=nsno,1,-1
+  ! #vm   DO ikl=1,knonv
+  ! #vm     EqSn02(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
+  ! #vm.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
+  ! #vm.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
+  ! #vm   END DO
+  ! #vm END DO
+
+
+  ! +--Snow/I Budget
+  ! +  -------------
+
+  ! #m1   DO ikl=1,knonv
+  ! #m1     SIsubl(ikl) = dt__SV*HLs_sv(ikl)*min(isnoSV(ikl),1)
+  ! #m1.                        /Lx_H2O(ikl)
+  ! #m1     SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV
+  ! #m1.                - SIrnof(ikl)
+  ! #m1   END DO
+
+
+  ! +--Anticipated Disappearance of a rapidly Melting too thin Last Snow Layer
+  ! +  =======================================================================
+
+  DO ikl=1,knonv
+    LastOK = min(1   , max(0   ,iiceSV(ikl)-isnoSV(ikl)+2) &
+          *min(1   ,isnoSV(ikl)-iiceSV(ikl)) &
+          +min(1   ,isnoSV(ikl))              )
+    RapdOK = max(zero,sign(unun,dzMelt(ikl)-epsi         ))
+    ThinOK = max(zero,sign(unun,dz_Min     -dzsnSV(ikl,1)))
+    z_Melt = LastOK     *RapdOK*ThinOK
+    noSnow(ikl)   = noSnow(ikl)   + z_Melt
+    z_Melt        =                 z_Melt *dzsnSV(ikl,1)
+    dzsnSV(ikl,1) = dzsnSV(ikl,1) - z_Melt
+    EExcsv(ikl)   = EExcsv(ikl)   - z_Melt *ro__SV(ikl,1) &
+          *(1.     -eta_SV(ikl,1))*Lf_H2O
+
+  ! +--Water  Production
+  ! +  ^^^^^^^^^^^^^^^^^
+    drr_SV(ikl)   = drr_SV(ikl) &
+          + ro__SV(ikl,1) * z_Melt /dt__SV
+  END DO
+
+
+  ! +--Update Nb of Layers
+  ! +  ===================
+
+  DO ikl=1,knonv
+    isnoSV(ikl)   = isnoSV(ikl) &
+          * min(1,iabs(isnoSV(ikl)-noSnow(ikl)))
+  END DO
+
+
+  ! Energy Budget (OUT)
+  ! ===================
+
+  ! #e1   DO ikl=1,knonv
+  ! #e1     EqSn_1(ikl) = 0.
+  ! #e1   END DO
+  ! #e1 DO   isn=nsno,1,-1
+  ! #e1   DO ikl=1,knonv
+  ! #e1     EqSn_1(ikl) = EqSn_1(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)
+  ! #e1.                *(Cn_dSV      *(TsisSV(ikl,isn) -TfSnow         )
+  ! #e1.                 -Lf_H2O      *(1.              -eta_SV(ikl,isn)))
+  ! #e1   END DO
+  ! #e1 END DO
+
+
+  ! +--Water  Budget (OUT)
+  ! +  ===================
+
+  ! #vm   DO ikl=1,knonv
+  ! #vm     WqSn_0(ikl) = WqSn_0(ikl)
+  ! #vm.                + HLs_sv(ikl)    * dt__SV
+  ! #vm.             *min(isnoSV(ikl),1) / Lx_H2O(ikl)
+  ! #vm     WqSn_1(ikl) = drr_SV(ikl)    * dt__SV
+  ! #vm.                + rusnSV(ikl)
+  ! #vm.                + RnofSV(ikl)    * dt__SV
+  ! #vm   END DO
+  ! #vm DO   isn=nsno,1,-1
+  ! #vm   DO ikl=1,knonv
+  ! #vm     WqSn_1(ikl) = WqSn_1(ikl)
+  ! #vm.                + ro__SV(ikl,isn)* dzsnSV(ikl,isn)
+  ! #vm   END DO
+  ! #vm END DO
+
+
+
+end subroutine sisvat_qsn
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qso.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qso.F	(revision 5104)
+++ 	(revision )
@@ -1,710 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_qSo
-! #m0.                     (Wats_0,Wats_1,Wats_d)
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_qSo                                 6-04-2001  MAR |
-C |   SubRoutine SISVAT_qSo computes the Soil      Water  Balance          |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
-C |   ^^^^^    isotSV   = 0,...,11:   Soil       Type                      |
-C |                       0:          Water, Solid or Liquid               |
-C |                                                                        |
-C |   INPUT:   rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
-C |   ^^^^^    drr_SV   : Rain   Intensity                       [kg/m2/s] |
-C |            LSdzsv   : Vertical   Discretization Factor             [-] |
-C |                     =    1. Soil                                       |
-C |                     = 1000. Ocean                                      |
-C |            dt__SV   : Time   Step                                  [s] |
-C |                                                                        |
-C |            Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
-C |            HLs_sv   : Latent Heat  Flux                         [W/m2] |
-C |                                                                        |
-C |   INPUT /  eta_SV   : Water      Content                       [m3/m3] |
-C |   OUTPUT:  Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
-C |   ^^^^^^                                                               |
-C |                                                                        |
-C |   OUTPUT:  RnofSV   : RunOFF Intensity                       [kg/m2/s] |
-C |   ^^^^^^   Wats_0   : Soil Water,  before Forcing                 [mm] |
-C |            Wats_1   : Soil Water,  after  Forcing                 [mm] |
-C |            Wats_d   : Soil Water          Forcing                 [mm] |
-C |                                                                        |
-C |   Internal Variables:                                                  |
-C |   ^^^^^^^^^^^^^^^^^^                                                   |
-C |            z_Bump   : (Partly)Bumpy Layers Height                  [m] |
-C |            z0Bump   :         Bumpy Layers Height                  [m] |
-C |            dzBump   :  Lowest Bumpy Layer:                         [m] |
-C |            etBump   :         Bumps Layer Averaged Humidity    [m3/m3] |
-C |            etaMid   : Layer Interface's Humidity               [m3/m3] |
-C |            eta__f   : Layer             Humidity  (Water Front)[m3/m3] |
-C |            Dhyd_f   : Soil  Hydraulic Diffusivity (Water Front) [m2/s] |
-C |            Dhydif   : Soil  Hydraulic Diffusivity               [m2/s] |
-C |            WgFlow   : Water         gravitational     Flux   [kg/m2/s] |
-C |            Wg_MAX   : Water MAXIMUM gravitational     Flux   [kg/m2/s] |
-C |            SatRat   : Water         Saturation        Flux   [kg/m2/s] |
-C |            WExces   : Water         Saturation Excess Flux   [kg/m2/s] |
-C |            Dhydtz   : Dhydif * dt / dz                             [m] |
-C |            FreeDr   : Free Drainage Fraction                       [-] |
-C |            Elem_A   : A Diagonal Coefficient                           |
-C |            Elem_C   : C Diagonal Coefficient                           |
-C |            Diag_A   : A Diagonal                                       |
-C |            Diag_B   : B Diagonal                                       |
-C |            Diag_C   : C Diagonal                                       |
-C |            Term_D   :   Independant Term                               |
-C |            Aux__P   : P Auxiliary Variable                             |
-C |            Aux__Q   : Q Auxiliary Variable                             |
-C |                                                                        |
-C |   TUNING PARAMETER:                                                    |
-C |   ^^^^^^^^^^^^^^^^                                                     |
-C |            z0soil   : Soil Surface averaged Bumps Height           [m] |
-C |                                                                        |
-C |   METHOD: NO   Skin Surface Humidity                                   |
-C |   ^^^^^^  Semi-Implicit Crank Nicholson Scheme                         |
-C |           (Partial) free Drainage, Water Bodies excepted (Lakes, Sea)  |
-C |                                                                        |
-
-C |                                                                        |
-C | # OPTIONS: #GF: Saturation Front                                       |
-C | # ^^^^^^^  #GH: Saturation Front allows Horton Runoff                  |
-C | #          #GA: Soil Humidity Geometric Average                        |
-C | #          #BP: Parameterization of Terrain Bumps                      |
-C |                                                                        |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
- 
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VAR0SV
-      use VARxSV
-      use VARySV
-
-     
-      IMPLICIT NONE
-
- 
-C +--OUTPUT
-C +  ------
- 
-! Water (Mass) Budget
-! ~~~~~~~~~~~~~~~~~~~
-! #m0 real      Wats_0(knonv)                 ! Soil Water,  before forcing
-! #m0 real      Wats_1(knonv)                 ! Soil Water,  after  forcing
-! #m0 real      Wats_d(knonv)                 ! Soil Water          forcing
- 
- 
-C +--Internal Variables
-C +  ==================
- 
-      integer   isl   ,jsl   ,ist   ,ikl      !
-      integer   ikm   ,ikp   ,ik0   ,ik1      !
-      integer   ist__s,ist__w                 ! Soil/Water Body Identifier
-c #BP real      z0soil                        ! Soil Surface Bumps Height  [m]
-c #BP real      z_Bump                        !(Partly)Bumpy Layers Height [m]
-c #BP real      z0Bump                        !        Bumpy Layers Height [m]
-c #BP real      dzBump                        ! Lowest Bumpy Layer:
- 
-c #BP real      etBump(knonv)                 ! Bumps Layer Averaged Humidity
-      real      etaMid                        ! Layer Interface's Humidity
-      real      Dhydif                        ! Hydraulic Diffusivity   [m2/s]
-      real      eta__f                        ! Water Front Soil Water Content
-      real      Khyd_f                        ! Water Front Hydraulic Conduct.
-      real      Khydav                        ! Hydraulic Conductivity   [m/s]
-      real      WgFlow                        ! Water gravitat. Flux [kg/m2/s]
-      real      Wg_MAX                        ! Water MAX.grav. Flux [kg/m2/s]
-      real      SatRat                        ! Saturation      Flux [kg/m2/s]
-      real      WExces                        ! Saturat. Excess Flux [kg/m2/s]
-      real      SoRnOF(knonv)                 ! Soil     Run    OFF
-      real      Dhydtz(knonv,-nsol:0)         ! Dhydif * dt / dz           [m]
-      real      Elem_A,Elem_B,Elem_C          !   Diagonal Coefficients
-      real      Diag_A(knonv,-nsol:0)         ! A Diagonal
-      real      Diag_B(knonv,-nsol:0)         ! B Diagonal
-      real      Diag_C(knonv,-nsol:0)         ! C Diagonal
-      real      Term_D(knonv,-nsol:0)         !   Independant Term
-      real      Aux__P(knonv,-nsol:0)         ! P Auxiliary Variable
-      real      Aux__Q(knonv,-nsol:0)         ! Q Auxiliary Variable
-      real      etaaux(knonv,-nsol:-nsol+1)   ! Soil Water Content     [m3/m3]
-      real      FreeDr                        ! Free Drainage Fraction (actual)
-      real      FreeD0                        ! Free Drainage Fraction (1=Full)
-      real      aKdtSV3( 0:nsot, 0:nkhy)      ! Khyd=a*eta+b: a * dt
-      real      bKdtSV3( 0:nsot, 0:nkhy)      ! Khyd=a*eta+b: b * dt
- 
-! Water (Mass) Budget
-! ~~~~~~~~~~~~~~~~~~~
-c #mw logical         mwopen                  ! IO   Switch
-c #mw common/Sm_qSo_L/mwopen                  !
-c #mw real     hourwr,timewr                  !
-c #mw common/Sm_qSo_R/timewr                  !
-c #mw real            Evapor(knonv)           !
- 
- 
-C +--Internal DATA
-C +  =============
- 
-c #BP data      z0soil/0.020/                 ! Soil Surface Bumps Height  [m]
-      data      FreeD0/1.000/                 ! Free Drainage Fraction (1=Full)
- 
-      aKdtSV3=aKdtSV2*dt__SV
-      bKdtSV3=bKdtSV2*dt__SV
- 
-! Water  Budget (IN)
-! ==================
- 
-! #m0   DO ikl=1,knonv
-! #m0     Wats_0(ikl) = 0.                    ! OLD RunOFF Contrib.
-! #m0     Wats_d(ikl) = drr_SV(ikl)           ! Water Surface Forc.
-! #m0   END DO
- 
-! #m0      isl= -nsol
-! #m0   DO ikl=1,knonv
-! #m0     Wats_0(ikl) = Wats_0(ikl)
-! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
-! #m0.                + eta_SV(ikl,isl+1) *dz_8SV(isl) ) * LSdzsv(ikl)
-! #m0   END DO
- 
-! #m0 DO   isl= -nsol+1,-1
-! #m0   DO ikl=1,knonv
-! #m0     Wats_0(ikl) = Wats_0(ikl)
-! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz34SV(isl)
-! #m0.                +(eta_SV(ikl,isl-1)
-! #m0.                 +eta_SV(ikl,isl+1))*dz_8SV(isl) ) * LSdzsv(ikl)
-! #m0   END DO
-! #m0 END DO
- 
-! #m0      isl=  0
-! #m0   DO ikl=1,knonv
-! #m0     Wats_0(ikl) = Wats_0(ikl)
-! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
-! #m0.                + eta_SV(ikl,isl-1) *dz_8SV(isl) ) * LSdzsv(ikl)
-! #m0   END DO
- 
- 
-C +--Gravitational Flow
-C +  ==================
- 
-C +...    METHOD: Surface Water Flux saturates successively the soil layers
-C +       ^^^^^^  from up to below, but is limited by infiltration capacity.
-C +               Hydraulic Conductivity again contributes after this step,
-C +               not redundantly because of a constant (saturated) profile.
- 
-C +--Flux  Limitor
-C +  ^^^^^^^^^^^^^
-           isl=0
-        DO ikl=1,knonv
-          ist    = isotSV(ikl)                     ! Soil Type
-          ist__s = min(ist, 1)                     ! 1 => Soil
-          ist__w = 1 - ist__s                      ! 1 => Water Body
-          Dhydif = s1__SV(ist)
-     .               *max(epsi,eta_SV(ikl,isl))    ! Hydraulic Diffusivity
-     .                      **(bCHdSV(ist)+2.)     ! DR97, Eqn.(3.36)
-          Dhydif = ist__s    * Dhydif              !
-     .           + ist__w    * vK_dSV              ! Water Bodies
-C +
-          Khydav = ist__s    * Ks_dSV(ist)         ! DR97  Assumption
-     .           + ist__w    * vK_dSV              ! Water Bodies
-C +
-          Wg_MAX = ro_Wat     *Dhydif              ! MAXimum  Infiltration
-     .           *(etadSV(ist)-eta_SV(ikl,isl))    !          Rate
-     .           /(dzAvSV(isl)*LSdzsv(ikl)    )    !
-     .          +  ro_Wat     *Khydav              !
- 
-C +--Surface Horton RunOFF
-C +  ^^^^^^^^^^^^^^^^^^^^^
-          SoRnOF(ikl) =
-     .                max(zero,drr_SV(ikl)-Wg_MAX)
-        RuofSV(ikl,1) = RuofSV(ikl,1) +    SoRnOF(ikl)
-          drr_SV(ikl) =        drr_SV(ikl)-SoRnOF(ikl)
-        RuofSV(ikl,2) = RuofSV(ikl,2) +max(0.,drr_SV(ikl))
-        END DO
- 
-c #GF DO   isl=0,-nsol,-1
-c #GF   DO ikl=1,knonv
-c #GF     ist    = isotSV(ikl)                     ! Soil Type
-c #GF     ist__s = min(ist, 1)                     ! 1 => Soil
-c #GF     ist__w = 1 - ist__s                      ! 1 => Water Body
- 
-C +--Water Diffusion
-C +  ^^^^^^^^^^^^^^^
-c #GF     Dhydif = s1__SV(ist)
-c #GF.               *max(epsi,eta_SV(ikl,isl))    ! Hydraulic Diffusivity
-c #GF.                      **(bCHdSV(ist)+2.)     ! DR97, Eqn.(3.36)
-c #GF     Dhydif = ist__s    * Dhydif              !
-c #GF.           + ist__w    * vK_dSV              ! Water Bodies
- 
-C +--Water Conduction (without Horton Runoff)
-C +  ^^^^^^^^^^^^^^^^
-c #GF     Khyd_f =             Ks_dSV(ist)
-C +...    Uses saturated K ==> Horton Runoff ~0    !
- 
-C +--Water Conduction (with    Horton Runoff)
-C +  ^^^^^^^^^^^^^^^^
-c #GH     ik0    = nkhy       *eta_SV(ikl,isl)
-c #GH.                        /etadSV(ist)
-c #GH     eta__f         =            1.
-c #GH.   -aKdtSV3(ist,ik0)/(2. *dzAvSV(isl)
-c #GH.                        *LSdzsv(ikl))
-c #GH     eta__f         = max(eps_21,eta__f)
-c #GH     eta__f         = min(etadSV(ist),
-c #GH.                         eta_SV(ikl,isl) +
-c #GH.   (aKdtSV3(ist,ik0)     *eta_SV(ikl,isl)
-c #GH.   +bKdtSV3(ist,ik0))   /(dzAvSV(isl)
-c #GH.                        *LSdzsv(ikl))
-c #GH.                       / eta__f          )
-c #GH     eta__f         = .5*(eta_SV(ikl,isl)
-c #GH.                        +eta__f)
- 
-c #gh     eta__f         =     eta_SV(ikl,isl)
- 
-c #GH     ik0    = nkhy       *eta__f
-c #GH.                        /etadSV(ist)
-c #GH     Khyd_f =
-c #GH.   (aKdtSV3(ist,ik0)     *eta__f
-c #GH.   +bKdtSV3(ist,ik0))    /dt__SV
- 
-c #GF     Khydav = ist__s    * Khyd_f              ! DR97  Assumption
-c #GF.           + ist__w    * vK_dSV              ! Water Bodies
- 
-C +--Gravitational Flow
-C +  ^^^^^^^^^^^^^^^^^^
-c #GF     Wg_MAX =                                 ! MAXimum  Infiltration
-c #GF.             ro_Wat     *Dhydif              !          Rate
-c #GF.           *(etadSV(ist)-eta_SV(ikl,isl))    !
-c #GF.           /(dzAvSV(isl)*LSdzsv(ikl)    )    !
-c #GF.          +  ro_Wat     *Khydav              !
-c #GF   END DO
-c #GF END DO
-c #GF   DO ikl=1,knonv
-c #GF     SoRnOF(ikl)     =    SoRnOF(ikl)         ! RunOFF Intensity
-c #GF.                    +    drr_SV(ikl)         ! [kg/m2/s]
-C +!!!    Inclure la possibilite de creer une mare sur un bedrock impermeable
-c #GF     drr_SV(ikl) = 0.
-c #GF   END DO
- 
- 
-C +--Temperature Correction due to a changed Soil Energy Content
-C +  ===========================================================
- 
-C +!!!    Mettre en oeuvre le couplage humidit?-?nergie
- 
- 
-C +--Full Resolution of the Richard's Equation
-C +  =========================================
- 
-C +...    METHOD: Water content evolution results from water fluxes
-C +       ^^^^^^  at the layer boundaries
-C +               Conductivity is approximated by a piecewise linear profile.
-C +               Semi-Implicit Crank-Nicholson scheme is used.
-C +              (Bruen, 1997, Sensitivity of hydrological processes
-C +                            at the land-atmosphere interface.
-C +                            Proc. Royal Irish Academy,  IGBP symposium
-C +                            on global change and the Irish Environment.
-C +                            Publ.: Maynooth)
- 
-C +                      - - - - - - - -   isl+1/2   - -  ^
-C +                                                       |
-C +   eta_SV(isl)        ---------------   isl     -----  +--dz_dSV(isl)  ^
-C +                                                       |               |
-C +   Dhydtz(isl) etaMid - - - - - - - -   isl-1/2   - -  v  dzmiSV(isl)--+
-C +                                                                       |
-C +   eta_SV(isl-1)      ---------------   isl-1   -----                  v
- 
-C +--Transfert       Coefficients
-C +  ----------------------------
- 
-      DO   isl=-nsol+1,0
-        DO ikl=1,knonv
-          ist    =      isotSV(ikl)                       ! Soil Type
-          ist__s =      min(ist, 1)                       ! 1 => Soil
-          ist__w =      1 - ist__s                        ! 1 => Water Body
-          etaMid =     (dz_dSV(isl)  *eta_SV(ikl,isl-1)   ! eta at layers
-     .                 +dz_dSV(isl-1)*eta_SV(ikl,isl)  )  !     interface
-     .           /(2.0* dzmiSV(isl))                      ! LSdzsv implicit !
-c #GA     etaMid = sqrt(dz_dSV(isl)  *eta_SV(ikl,isl-1)   ! Idem, geometric
-c #GA.                 *dz_dSV(isl-1)*eta_SV(ikl,isl)  )  !       average
-c #GA.           /(2.0* dzmiSV(isl))                      ! (Vauclin&al.1979)
-          Dhydif          =    s1__SV(ist)                ! Hydraul.Diffusi.
-     .  *(etaMid         **(   bCHdSV(ist)+2.))           ! DR97, Eqn.(3.36)
-          Dhydtz(ikl,isl) =    Dhydif*dt__SV              !
-     .                              /(dzmiSV(isl)         !
-     .                               *LSdzsv(ikl))        !
-          Dhydtz(ikl,isl) =    Dhydtz(ikl,isl) * ist__s   ! Soil
-     .        +0.5*dzmiSV(isl)*LSdzsv(ikl)     * ist__w   ! Water bodies
- 
-        END DO
-      END DO
-           isl=-nsol
-        DO ikl=1,knonv
-          Dhydtz(ikl,isl) =    0.0                        !
-        END DO
- 
- 
-C +--Tridiagonal Elimination: Set Up
-C +  -------------------------------
- 
-C +--Soil/Snow Interior
-C +  ^^^^^^^^^^^^^^^^^^
- 
-      DO   isl=0,-nsol,-1
-        DO ikl=1,knonv
-         ist             = isotSV(ikl)
-         eta_SV(ikl,isl) = max(epsi,           eta_SV(ikl,isl))
-        END DO
-      END DO
- 
-      DO   isl=-nsol,-nsol+1
-        DO ikl=1,knonv
-          etaaux(ikl,isl) =  eta_SV(ikl,isl)
-        END DO
-      END DO
- 
-      DO   isl=-nsol+1,-1
-        DO ikl=1,knonv
-          ist      =         isotSV(ikl)
-          ikm      = nkhy *  eta_SV(ikl,isl-1) / etadSV(ist)
-          ik0      = nkhy *  eta_SV(ikl,isl)   / etadSV(ist)
-          ikp      = nkhy *  eta_SV(ikl,isl+1) / etadSV(ist)
- 
-          if(ikm<0.or.ik0<0.or.ikp<0)then
-           print *,"CRASH1 in sisvat_qso.f on pixel (i,j,n)",
-     .     ii__SV(ikl),jj__SV(ikl),nn__SV(ikl)
-           print *,"decrease your time step or increase ntphys "//
-     .             "and ntdiff in time_steps.f"
-           stop
-          endif
- 
- 
-          Elem_A   =         Dhydtz(ikl,isl)
-     .                    -  aKdtSV3(ist,ikm)* dziiSV(isl)  *LSdzsv(ikl)
-          Elem_B   =      - (Dhydtz(ikl,isl)
-     .                      +Dhydtz(ikl,isl+1)
-     .                      -aKdtSV3(ist,ik0)*(dziiSV(isl+1)
-     .                                       -dzi_SV(isl) )*LSdzsv(ikl))
-          Elem_C   =         Dhydtz(ikl,isl+1)
-     .                    +  aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)
-          Diag_A(ikl,isl) =  dz_8SV(isl)        *LSdzsv(ikl)
-     .                      -Implic            * Elem_A
-          Diag_B(ikl,isl) =  dz34SV(isl)        *LSdzsv(ikl)
-     .                      -Implic            * Elem_B
-          Diag_C(ikl,isl) =  dz_8SV(isl)        *LSdzsv(ikl)
-     .                      -Implic            * Elem_C
- 
-          Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_A     )*eta_SV(ikl,isl-1)
-     .                    + (dz34SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_B     )*eta_SV(ikl,isl)
-     .                    + (dz_8SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_C     )*eta_SV(ikl,isl+1)
-     .                    + (bKdtSV3(ist,ikp)* dzi_SV(isl+1)
-     .                      +bKdtSV3(ist,ik0)*(dziiSV(isl+1)
-     .                                       -dzi_SV(isl)  )
-     .                      -bKdtSV3(ist,ikm)* dziiSV(isl)   )
-     .                                      * LSdzsv(ikl)
-        END DO
-      END DO
- 
-           isl=-nsol
-        DO ikl=1,knonv
-          ist      =         isotSV(ikl)
-c #       FreeDr   =         FreeD0            *  min(ist,1)
-          FreeDr   =         iWaFSV(ikl)       *  min(ist,1)
-          ik0      = nkhy *  eta_SV(ikl,isl  ) / etadSV(ist)
-          ikp      = nkhy *  eta_SV(ikl,isl+1) / etadSV(ist)
- 
-          if(ik0<0.or.ikp<0)then
-           print *,"CRASH2 in sisvat_qso.f on pixel (i,j,n)",
-     .     ii__SV(ikl),jj__SV(ikl),nn__SV(ikl)
-           print *,"decrease your time step or increase ntphys "//
-     .             "and ntdiff in time_steps.f"
-           stop
-          endif
- 
-          Elem_A   =         0.
-          Elem_B   =      - (Dhydtz(ikl,isl+1)
-     .                      -aKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl)
-     .                                       -FreeDr                  ))
-          Elem_C   =         Dhydtz(ikl,isl+1)
-     .                    +  aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)
-          Diag_A(ikl,isl) =  0.
-          Diag_B(ikl,isl) =  dz78SV(isl) *LSdzsv(ikl)
-     .                      -Implic      *Elem_B
-          Diag_C(ikl,isl) =  dz_8SV(isl) *LSdzsv(ikl)
-     .                      -Implic      *Elem_C
- 
-          Term_D(ikl,isl) = (dz78SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_B     )*eta_SV(ikl,isl)
-     .                    + (dz_8SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_C     )*eta_SV(ikl,isl+1)
-     .                    + (bKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)
-     .                      +bKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl)
-     .                                       -FreeDr                  ))
-        END DO
- 
-           isl=0
-        DO ikl=1,knonv
-          ist      =         isotSV(ikl)
-          ikm      = nkhy *  eta_SV(ikl,isl-1) / etadSV(ist)
-          ik0      = nkhy *  eta_SV(ikl,isl)   / etadSV(ist)
-          Elem_A   =         Dhydtz(ikl,isl)
-     .                    -  aKdtSV3(ist,ikm)* dziiSV(isl)*LSdzsv(ikl)
-          Elem_B   =      - (Dhydtz(ikl,isl)
-     .                      +aKdtSV3(ist,ik0)* dzi_SV(isl)*LSdzsv(ikl))
-          Elem_C   =         0.
-          Diag_A(ikl,isl) =  dz_8SV(isl) *LSdzsv(ikl)
-     .                    -  Implic      *Elem_A
-          Diag_B(ikl,isl) =  dz78SV(isl) *LSdzsv(ikl)
-     .                    -  Implic      *Elem_B
-          Diag_C(ikl,isl) =  0.
-C +
-          Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_A     )*eta_SV(ikl,isl-1)
-     .                    + (dz78SV(isl) *LSdzsv(ikl)
-     .                      +Explic      *Elem_B     )*eta_SV(ikl,isl)
-     .                    - (bKdtSV3(ist,ik0)* dzi_SV(isl)
-     .                      +bKdtSV3(ist,ikm)* dziiSV(isl))*LSdzsv(ikl)
-     .            + dt__SV *(HLs_sv(ikl)    *     (1-min(1,isnoSV(ikl)))
-     .                     / (ro_Wat *dz_dSV(0) * Lx_H2O(ikl))
-cXF bug 17/05/2017
-     .                      +drr_SV(ikl))/ro_Wat
-        END DO
- 
-        DO ikl=1,knonv
-         drr_SV(ikl)=0. ! drr is included in the 1st soil layer
-        ENDDO
- 
-C +
-C +
-C +--Tridiagonal Elimination
-C +  =======================
-C +
-C +--Forward  Sweep
-C +  ^^^^^^^^^^^^^^
-        DO ikl=  1,knonv
-          Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol)
-          Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol)
-        END DO
-C +
-      DO   isl=-nsol+1,0
-        DO ikl=      1,knonv
-          Aux__P(ikl,isl)   = Diag_A(ikl,isl)  *Aux__Q(ikl,isl-1)
-     .                       +Diag_B(ikl,isl)
-          Aux__Q(ikl,isl)   =-Diag_C(ikl,isl)  /Aux__P(ikl,isl)
-        END DO
-      END DO
-C +
-        DO ikl=      1,knonv
-          eta_SV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol)
-        END DO
-C +
-      DO   isl=-nsol+1,0
-        DO ikl=      1,knonv
-          eta_SV(ikl,isl)   =(Term_D(ikl,isl)
-     .                       -Diag_A(ikl,isl)  *eta_SV(ikl,isl-1))
-     .                                         /Aux__P(ikl,isl)
-        END DO
-      END DO
- 
-C +--Backward Sweep
-C +  ^^^^^^^^^^^^^^
-      DO   isl=-1,-nsol,-1
-        DO ikl= 1,knonv
-          eta_SV(ikl,isl)   = Aux__Q(ikl,isl)  *eta_SV(ikl,isl+1)
-     .                                         +eta_SV(ikl,isl)
-        END DO
-      END DO
- 
- 
-C +--Horton RunOFF Intensity
-C +  =======================
- 
-      DO   isl=0,-nsol,-1
-        DO ikl=1,knonv
-          ist    =   isotSV(ikl)                   ! Soil Type
-          SatRat =  (eta_SV(ikl,isl)-etadSV(ist))  ! OverSaturation Rate
-     .              *ro_Wat         *dzAvSV(isl)   !
-     .                              *LSdzsv(ikl)   !
-     .                              /dt__SV        !
-          SoRnOF(ikl)     =          SoRnOF(ikl)   !
-     .                    + max(zero,SatRat)       !
-          RuofSV(ikl,3)   = RuofSV(ikl,3) +
-     .                    + max(zero,SatRat)
-          eta_SV(ikl,isl) = max(epsi               !
-c #ED.                         +etamSV(isotSV(ikl))!
-     .                         ,eta_SV(ikl,isl))   !
-          eta_SV(ikl,isl) = min(eta_SV(ikl,isl)    !
-     .                         ,etadSV(ist)    )   !
-        END DO
-      END DO
- 
-C +--IO, for Verification
-C +  ~~~~~~~~~~~~~~~~~~~~
-c #WR     write(6,6010)
- 6010     format(/,1x)
-      DO   isl= 0,-nsol,-1
-        DO ikl= 1,knonv
-          ist      =          isotSV(ikl)
-          ikp      = nkhy  *  eta_SV(ikl,isl)  /etadSV(ist)
-          Khydsv(ikl,isl)   =(aKdtSV3(ist,ikp)  *eta_SV(ikl,isl)
-     .                       +bKdtSV3(ist,ikp)) *2.0/dt__SV
-c #WR     write(6,6011) ikl,isl,eta_SV(ikl,isl)*1.e3,
-c #WR.                  ikp,    aKdtSV3(ist,ikp),bKdtSV3(ist,ikp),
-c #WR.                          Khydsv(ikl,isl)
- 6011     format(2i3,f8.1,i3,3e12.3)
-        END DO
-      END DO
- 
- 
-C +--Additional RunOFF Intensity
-C +  ===========================
- 
-        DO ikl=1,knonv
-          ist      =          isotSV(ikl)
-          ik0      = nkhy  *  etaaux(ikl,-nsol  ) /etadSV(ist)
-c #       FreeDr   =          FreeD0            *  min(ist,1)
-          FreeDr   =          iWaFSV(ikl)       *  min(ist,1)
-          SoRnOF(ikl) =  SoRnOF(ikl)
-     .                + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic
-     .                                   +eta_SV(ikl,-nsol)*Implic)
-     .                 + bKdtSV3(ist,ik0)                           )
-     .                 * FreeDr          *ro_Wat           /dt__SV
-        RuofSV(ikl,3) = RuofSV(ikl,3)
-     .                + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic
-     .                                   +eta_SV(ikl,-nsol)*Implic)
-     .                 + bKdtSV3(ist,ik0)                           )
-     .                 * FreeDr          *ro_Wat           /dt__SV
- 
-C +--Full Run OFF: Update
-C +  ~~~~~~~~~~~~~~~~~~~~
-          RnofSV(ikl)   = RnofSV(ikl)   + SoRnOF(ikl)
-          RuofSV(ikl,4) = RuofSV(ikl,4) + SoRnOF(ikl)
-        END DO
- 
- 
-C +--Temperature Correction due to a changed Soil Energy Content
-C +  ===========================================================
- 
-C +!!!    Mettre en oeuvre le couplage humidit?-?nergie
- 
- 
-C +--Bumps/Asperites Treatment
-C +  =========================
- 
-C +--Average over Bump Depth (z0soil)
-C +  --------------------------------
- 
-c #BP       z_Bump      = 0.
-c #BP     DO ikl=1,knonv
-c #BP       etBump(ikl) = 0.
-c #BP     END DO
-C +
-c #BP DO     isl=0,-nsol,-1
-c #BP       z0Bump      = z_Bump
-c #BP       z_Bump      = z_Bump      +  dzAvSV(isl)
-c #BP   IF (z_Bump.lt.z0soil)                                       THEN
-c #BP     DO ikl=1,knonv
-c #BP       etBump(ikl) = etBump(ikl) +  dzAvSV(isl)   *eta_SV(ikl,isl)
-c #BP     END DO
-c #BP   END IF
-c #BP   IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil)                  THEN
-c #BP     DO ikl=1,knonv
-c #BP       etBump(ikl) = etBump(ikl) + (z0soil-z0Bump)*eta_SV(ikl,isl)
-c #BP       etBump(ikl) = etBump(ikl) /  z0soil
-c #BP     END DO
-c #BP   END IF
-c #BP END DO
- 
- 
-C +--Correction
-C +  ----------
- 
-c #BP       z_Bump      = 0.
-c #BP DO     isl=0,-nsol,-1
-c #BP       z0Bump =  z_Bump
-c #BP       z_Bump =  z_Bump +dzAvSV(isl)
-c #BP   IF (z_Bump.lt.z0soil)                                       THEN
-c #BP     DO ikl=1,knonv
-c #BP       eta_SV(ikl,isl) = etBump(ikl)
-c #BP     END DO
-c #BP   END IF
-c #BP   IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil)                  THEN
-c #BP       dzBump          =    z_Bump -  z0soil
-c #BP     DO ikl=1,knonv
-c #BP       eta_SV(ikl,isl) =(etBump(ikl)    *(dzAvSV(isl)-dzBump)
-c #BP.                      + eta_SV(ikl,isl)*             dzBump)
-c #BP.                      /                  dzAvSV(isl)
-c #BP     END DO
-c #BP   END IF
-c #BP END DO
- 
- 
-C +--Positive Definite
-C +  =================
- 
-c #BP DO   isl= 0,-nsol,-1
-c #BP   DO ikl= 1,knonv
-c #BP     eta_SV(ikl,isl)   =          max(epsi,eta_SV(ikl,isl))
-c #BP   END DO
-c #BP END DO
- 
- 
-C +--Water  Budget (OUT)
-C +  ===================
- 
-! #m0   DO ikl=1,knonv
-! #m0     Wats_d(ikl) = Wats_d(ikl)                    !
-! #m0.                + drr_SV(ikl)     *zero          ! Precipitation is
-C +                                      \______________ already included
-! #m0.                + HLs_sv(ikl)
-! #m0.          *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl)   ! Evaporation
-! #m0.                - SoRnOF(ikl)                    ! Soil RunOFF Contrib.
-! #m0     Wats_1(ikl) = 0.                             !
-c #mw     Evapor(ikl) = HLs_sv(ikl)     *dt__SV        !
-c #mw.          *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl)   !
-! #m0   END DO
- 
-! #m0 DO   isl= -nsol,0
-! #m0   DO ikl=1,knonv
-! #m0     Wats_d(ikl) = Wats_d(ikl)                    !
-! #m0   END DO
-! #m0 END DO
-! #m0   DO ikl=1,knonv
-! #m0     Wats_d(ikl) = Wats_d(ikl)     *dt__SV        !
-! #m0   END DO
- 
-! #m0      isl= -nsol
-! #m0   DO ikl=1,knonv
-! #m0     Wats_1(ikl) = Wats_1(ikl)
-! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
-! #m0.                + eta_SV(ikl,isl+1) *dz_8SV(isl) ) *LSdzsv(ikl)
-! #m0   END DO
- 
-! #m0 DO   isl= -nsol+1,-1
-! #m0   DO ikl=1,knonv
-! #m0     Wats_1(ikl) = Wats_1(ikl)
-! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz34SV(isl)
-! #m0.                +(eta_SV(ikl,isl-1)
-! #m0.                 +eta_SV(ikl,isl+1))*dz_8SV(isl) ) *LSdzsv(ikl)
-! #m0   END DO
-! #m0 END DO
- 
-! #m0      isl=  0
-! #m0   DO ikl=1,knonv
-! #m0     Wats_1(ikl) = Wats_1(ikl)
-! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
-! #m0.                + eta_SV(ikl,isl-1) *dz_8SV(isl) ) *LSdzsv(ikl)
-! #m0   END DO
- 
- 
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qso.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qso.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_qso.f90	(revision 5105)
@@ -0,0 +1,708 @@
+
+
+SUBROUTINE SISVAT_qSo
+  ! #m0.                     (Wats_0,Wats_1,Wats_d)
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_qSo                                 6-04-2001  MAR |
+  ! |   SubRoutine SISVAT_qSo computes the Soil      Water  Balance          |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   ^^^^^    isotSV   = 0,...,11:   Soil       Type                      |
+  ! |                       0:          Water, Solid or Liquid               |
+  ! |                                                                        |
+  ! |   INPUT:   rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
+  ! |   ^^^^^    drr_SV   : Rain   Intensity                       [kg/m2/s] |
+  ! |            LSdzsv   : Vertical   Discretization Factor             [-] |
+  ! |                     =    1. Soil                                       |
+  ! |                     = 1000. Ocean                                      |
+  ! |            dt__SV   : Time   Step                                  [s] |
+  ! |                                                                        |
+  ! |            Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
+  ! |            HLs_sv   : Latent Heat  Flux                         [W/m2] |
+  ! |                                                                        |
+  ! |   INPUT /  eta_SV   : Water      Content                       [m3/m3] |
+  ! |   OUTPUT:  Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
+  ! |   ^^^^^^                                                               |
+  ! |                                                                        |
+  ! |   OUTPUT:  RnofSV   : RunOFF Intensity                       [kg/m2/s] |
+  ! |   ^^^^^^   Wats_0   : Soil Water,  before Forcing                 [mm] |
+  ! |            Wats_1   : Soil Water,  after  Forcing                 [mm] |
+  ! |            Wats_d   : Soil Water          Forcing                 [mm] |
+  ! |                                                                        |
+  ! |   Internal Variables:                                                  |
+  ! |   ^^^^^^^^^^^^^^^^^^                                                   |
+  ! |            z_Bump   : (Partly)Bumpy Layers Height                  [m] |
+  ! |            z0Bump   :         Bumpy Layers Height                  [m] |
+  ! |            dzBump   :  Lowest Bumpy Layer:                         [m] |
+  ! |            etBump   :         Bumps Layer Averaged Humidity    [m3/m3] |
+  ! |            etaMid   : Layer Interface's Humidity               [m3/m3] |
+  ! |            eta__f   : Layer             Humidity  (Water Front)[m3/m3] |
+  ! |            Dhyd_f   : Soil  Hydraulic Diffusivity (Water Front) [m2/s] |
+  ! |            Dhydif   : Soil  Hydraulic Diffusivity               [m2/s] |
+  ! |            WgFlow   : Water         gravitational     Flux   [kg/m2/s] |
+  ! |            Wg_MAX   : Water MAXIMUM gravitational     Flux   [kg/m2/s] |
+  ! |            SatRat   : Water         Saturation        Flux   [kg/m2/s] |
+  ! |            WExces   : Water         Saturation Excess Flux   [kg/m2/s] |
+  ! |            Dhydtz   : Dhydif * dt / dz                             [m] |
+  ! |            FreeDr   : Free Drainage Fraction                       [-] |
+  ! |            Elem_A   : A Diagonal Coefficient                           |
+  ! |            Elem_C   : C Diagonal Coefficient                           |
+  ! |            Diag_A   : A Diagonal                                       |
+  ! |            Diag_B   : B Diagonal                                       |
+  ! |            Diag_C   : C Diagonal                                       |
+  ! |            Term_D   :   Independant Term                               |
+  ! |            Aux__P   : P Auxiliary Variable                             |
+  ! |            Aux__Q   : Q Auxiliary Variable                             |
+  ! |                                                                        |
+  ! |   TUNING PARAMETER:                                                    |
+  ! |   ^^^^^^^^^^^^^^^^                                                     |
+  ! |            z0soil   : Soil Surface averaged Bumps Height           [m] |
+  ! |                                                                        |
+  ! |   METHOD: NO   Skin Surface Humidity                                   |
+  ! |   ^^^^^^  Semi-Implicit Crank Nicholson Scheme                         |
+  ! |           (Partial) free Drainage, Water Bodies excepted (Lakes, Sea)  |
+  ! |                                                                        |
+
+  ! |                                                                        |
+  ! | # OPTIONS: #GF: Saturation Front                                       |
+  ! | # ^^^^^^^  #GH: Saturation Front allows Horton Runoff                  |
+  ! | #          #GA: Soil Humidity Geometric Average                        |
+  ! | #          #BP: Parameterization of Terrain Bumps                      |
+  ! |                                                                        |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VAR0SV
+  use VARxSV
+  use VARySV
+
+
+  IMPLICIT NONE
+
+
+  ! +--OUTPUT
+  ! +  ------
+
+  ! Water (Mass) Budget
+  ! ~~~~~~~~~~~~~~~~~~~
+  ! #m0 real      Wats_0(knonv)                 ! Soil Water,  before forcing
+  ! #m0 real      Wats_1(knonv)                 ! Soil Water,  after  forcing
+  ! #m0 real      Wats_d(knonv)                 ! Soil Water          forcing
+
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  integer :: isl   ,jsl   ,ist   ,ikl      !
+  integer :: ikm   ,ikp   ,ik0   ,ik1      !
+  integer :: ist__s,ist__w                 ! Soil/Water Body Identifier
+  ! #BP real      z0soil                        ! Soil Surface Bumps Height  [m]
+  ! #BP real      z_Bump                        !(Partly)Bumpy Layers Height [m]
+  ! #BP real      z0Bump                        !        Bumpy Layers Height [m]
+  ! #BP real      dzBump                        ! Lowest Bumpy Layer:
+
+  ! #BP real      etBump(knonv)                 ! Bumps Layer Averaged Humidity
+  real :: etaMid                        ! Layer Interface's Humidity
+  real :: Dhydif                        ! Hydraulic Diffusivity   [m2/s]
+  real :: eta__f                        ! Water Front Soil Water Content
+  real :: Khyd_f                        ! Water Front Hydraulic Conduct.
+  real :: Khydav                        ! Hydraulic Conductivity   [m/s]
+  real :: WgFlow                        ! Water gravitat. Flux [kg/m2/s]
+  real :: Wg_MAX                        ! Water MAX.grav. Flux [kg/m2/s]
+  real :: SatRat                        ! Saturation      Flux [kg/m2/s]
+  real :: WExces                        ! Saturat. Excess Flux [kg/m2/s]
+  real :: SoRnOF(knonv)                 ! Soil     Run    OFF
+  real :: Dhydtz(knonv,-nsol:0)         ! Dhydif * dt / dz           [m]
+  real :: Elem_A,Elem_B,Elem_C          !   Diagonal Coefficients
+  real :: Diag_A(knonv,-nsol:0)         ! A Diagonal
+  real :: Diag_B(knonv,-nsol:0)         ! B Diagonal
+  real :: Diag_C(knonv,-nsol:0)         ! C Diagonal
+  real :: Term_D(knonv,-nsol:0)         !   Independant Term
+  real :: Aux__P(knonv,-nsol:0)         ! P Auxiliary Variable
+  real :: Aux__Q(knonv,-nsol:0)         ! Q Auxiliary Variable
+  real :: etaaux(knonv,-nsol:-nsol+1)   ! Soil Water Content     [m3/m3]
+  real :: FreeDr                        ! Free Drainage Fraction (actual)
+  real :: FreeD0                        ! Free Drainage Fraction (1=Full)
+  real :: aKdtSV3( 0:nsot, 0:nkhy)      ! Khyd=a*eta+b: a * dt
+  real :: bKdtSV3( 0:nsot, 0:nkhy)      ! Khyd=a*eta+b: b * dt
+
+  ! Water (Mass) Budget
+  ! ~~~~~~~~~~~~~~~~~~~
+  ! #mw logical         mwopen                  ! IO   Switch
+  ! #mw common/Sm_qSo_L/mwopen                  !
+  ! #mw real     hourwr,timewr                  !
+  ! #mw common/Sm_qSo_R/timewr                  !
+  ! #mw real            Evapor(knonv)           !
+
+
+  ! +--Internal DATA
+  ! +  =============
+
+  ! #BP data      z0soil/0.020/                 ! Soil Surface Bumps Height  [m]
+  data      FreeD0/1.000/                 ! Free Drainage Fraction (1=Full)
+
+  aKdtSV3=aKdtSV2*dt__SV
+  bKdtSV3=bKdtSV2*dt__SV
+
+  ! Water  Budget (IN)
+  ! ==================
+
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_0(ikl) = 0.                    ! OLD RunOFF Contrib.
+  ! #m0     Wats_d(ikl) = drr_SV(ikl)           ! Water Surface Forc.
+  ! #m0   END DO
+
+  ! #m0      isl= -nsol
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_0(ikl) = Wats_0(ikl)
+  ! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
+  ! #m0.                + eta_SV(ikl,isl+1) *dz_8SV(isl) ) * LSdzsv(ikl)
+  ! #m0   END DO
+
+  ! #m0 DO   isl= -nsol+1,-1
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_0(ikl) = Wats_0(ikl)
+  ! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz34SV(isl)
+  ! #m0.                +(eta_SV(ikl,isl-1)
+  ! #m0.                 +eta_SV(ikl,isl+1))*dz_8SV(isl) ) * LSdzsv(ikl)
+  ! #m0   END DO
+  ! #m0 END DO
+
+  ! #m0      isl=  0
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_0(ikl) = Wats_0(ikl)
+  ! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
+  ! #m0.                + eta_SV(ikl,isl-1) *dz_8SV(isl) ) * LSdzsv(ikl)
+  ! #m0   END DO
+
+
+  ! +--Gravitational Flow
+  ! +  ==================
+
+  ! +...    METHOD: Surface Water Flux saturates successively the soil layers
+  ! +       ^^^^^^  from up to below, but is limited by infiltration capacity.
+  ! +               Hydraulic Conductivity again contributes after this step,
+  ! +               not redundantly because of a constant (saturated) profile.
+
+  ! +--Flux  Limitor
+  ! +  ^^^^^^^^^^^^^
+       isl=0
+    DO ikl=1,knonv
+      ist    = isotSV(ikl)                     ! Soil Type
+      ist__s = min(ist, 1)                     ! 1 => Soil
+      ist__w = 1 - ist__s                      ! 1 => Water Body
+      Dhydif = s1__SV(ist) &
+            *max(epsi,eta_SV(ikl,isl)) & ! Hydraulic Diffusivity
+            **(bCHdSV(ist)+2.)     ! DR97, Eqn.(3.36)
+      Dhydif = ist__s    * Dhydif & !
+            + ist__w    * vK_dSV              ! Water Bodies
+  ! +
+      Khydav = ist__s    * Ks_dSV(ist) & ! DR97  Assumption
+            + ist__w    * vK_dSV              ! Water Bodies
+  ! +
+      Wg_MAX = ro_Wat     *Dhydif & ! MAXimum  Infiltration
+            *(etadSV(ist)-eta_SV(ikl,isl)) & !          Rate
+            /(dzAvSV(isl)*LSdzsv(ikl)    ) & !
+            +  ro_Wat     *Khydav              !
+
+  ! +--Surface Horton RunOFF
+  ! +  ^^^^^^^^^^^^^^^^^^^^^
+      SoRnOF(ikl) = &
+            max(zero,drr_SV(ikl)-Wg_MAX)
+    RuofSV(ikl,1) = RuofSV(ikl,1) +    SoRnOF(ikl)
+      drr_SV(ikl) =        drr_SV(ikl)-SoRnOF(ikl)
+    RuofSV(ikl,2) = RuofSV(ikl,2) +max(0.,drr_SV(ikl))
+    END DO
+
+  ! #GF DO   isl=0,-nsol,-1
+  ! #GF   DO ikl=1,knonv
+  ! #GF     ist    = isotSV(ikl)                     ! Soil Type
+  ! #GF     ist__s = min(ist, 1)                     ! 1 => Soil
+  ! #GF     ist__w = 1 - ist__s                      ! 1 => Water Body
+
+  ! +--Water Diffusion
+  ! +  ^^^^^^^^^^^^^^^
+  ! #GF     Dhydif = s1__SV(ist)
+  ! #GF.               *max(epsi,eta_SV(ikl,isl))    ! Hydraulic Diffusivity
+  ! #GF.                      **(bCHdSV(ist)+2.)     ! DR97, Eqn.(3.36)
+  ! #GF     Dhydif = ist__s    * Dhydif              !
+  ! #GF.           + ist__w    * vK_dSV              ! Water Bodies
+
+  ! +--Water Conduction (without Horton Runoff)
+  ! +  ^^^^^^^^^^^^^^^^
+  ! #GF     Khyd_f =             Ks_dSV(ist)
+  ! +...    Uses saturated K ==> Horton Runoff ~0    !
+
+  ! +--Water Conduction (with    Horton Runoff)
+  ! +  ^^^^^^^^^^^^^^^^
+  ! #GH     ik0    = nkhy       *eta_SV(ikl,isl)
+  ! #GH.                        /etadSV(ist)
+  ! #GH     eta__f         =            1.
+  ! #GH.   -aKdtSV3(ist,ik0)/(2. *dzAvSV(isl)
+  ! #GH.                        *LSdzsv(ikl))
+  ! #GH     eta__f         = max(eps_21,eta__f)
+  ! #GH     eta__f         = min(etadSV(ist),
+  ! #GH.                         eta_SV(ikl,isl) +
+  ! #GH.   (aKdtSV3(ist,ik0)     *eta_SV(ikl,isl)
+  ! #GH.   +bKdtSV3(ist,ik0))   /(dzAvSV(isl)
+  ! #GH.                        *LSdzsv(ikl))
+  ! #GH.                       / eta__f          )
+  ! #GH     eta__f         = .5*(eta_SV(ikl,isl)
+  ! #GH.                        +eta__f)
+
+  ! #gh     eta__f         =     eta_SV(ikl,isl)
+
+  ! #GH     ik0    = nkhy       *eta__f
+  ! #GH.                        /etadSV(ist)
+  ! #GH     Khyd_f =
+  ! #GH.   (aKdtSV3(ist,ik0)     *eta__f
+  ! #GH.   +bKdtSV3(ist,ik0))    /dt__SV
+
+  ! #GF     Khydav = ist__s    * Khyd_f              ! DR97  Assumption
+  ! #GF.           + ist__w    * vK_dSV              ! Water Bodies
+
+  ! +--Gravitational Flow
+  ! +  ^^^^^^^^^^^^^^^^^^
+  ! #GF     Wg_MAX =                                 ! MAXimum  Infiltration
+  ! #GF.             ro_Wat     *Dhydif              !          Rate
+  ! #GF.           *(etadSV(ist)-eta_SV(ikl,isl))    !
+  ! #GF.           /(dzAvSV(isl)*LSdzsv(ikl)    )    !
+  ! #GF.          +  ro_Wat     *Khydav              !
+  ! #GF   END DO
+  ! #GF END DO
+  ! #GF   DO ikl=1,knonv
+  ! #GF     SoRnOF(ikl)     =    SoRnOF(ikl)         ! RunOFF Intensity
+  ! #GF.                    +    drr_SV(ikl)         ! [kg/m2/s]
+  ! +!!!    Inclure la possibilite de creer une mare sur un bedrock impermeable
+  ! #GF     drr_SV(ikl) = 0.
+  ! #GF   END DO
+
+
+  ! +--Temperature Correction due to a changed Soil Energy Content
+  ! +  ===========================================================
+
+  ! +!!!    Mettre en oeuvre le couplage humidit?-?nergie
+
+
+  ! +--Full Resolution of the Richard's Equation
+  ! +  =========================================
+
+  ! +...    METHOD: Water content evolution results from water fluxes
+  ! +       ^^^^^^  at the layer boundaries
+  ! +               Conductivity is approximated by a piecewise linear profile.
+  ! +               Semi-Implicit Crank-Nicholson scheme is used.
+  ! +              (Bruen, 1997, Sensitivity of hydrological processes
+  ! +                            at the land-atmosphere interface.
+  ! +                            Proc. Royal Irish Academy,  IGBP symposium
+  ! +                            on global change and the Irish Environment.
+  ! +                            Publ.: Maynooth)
+
+  ! +                      - - - - - - - -   isl+1/2   - -  ^
+  ! +                                                       |
+  ! +   eta_SV(isl)        ---------------   isl     -----  +--dz_dSV(isl)  ^
+  ! +                                                       |               |
+  ! +   Dhydtz(isl) etaMid - - - - - - - -   isl-1/2   - -  v  dzmiSV(isl)--+
+  ! +                                                                       |
+  ! +   eta_SV(isl-1)      ---------------   isl-1   -----                  v
+
+  ! +--Transfert       Coefficients
+  ! +  ----------------------------
+
+  DO   isl=-nsol+1,0
+    DO ikl=1,knonv
+      ist    =      isotSV(ikl)                       ! Soil Type
+      ist__s =      min(ist, 1)                       ! 1 => Soil
+      ist__w =      1 - ist__s                        ! 1 => Water Body
+      etaMid =     (dz_dSV(isl)  *eta_SV(ikl,isl-1) & ! eta at layers
+            +dz_dSV(isl-1)*eta_SV(ikl,isl)  ) & !     interface
+            /(2.0* dzmiSV(isl))                      ! LSdzsv implicit !
+  ! #GA     etaMid = sqrt(dz_dSV(isl)  *eta_SV(ikl,isl-1)   ! Idem, geometric
+  ! #GA.                 *dz_dSV(isl-1)*eta_SV(ikl,isl)  )  !       average
+  ! #GA.           /(2.0* dzmiSV(isl))                      ! (Vauclin&al.1979)
+      Dhydif          =    s1__SV(ist) & ! Hydraul.Diffusi.
+            *(etaMid         **(   bCHdSV(ist)+2.))           ! DR97, Eqn.(3.36)
+      Dhydtz(ikl,isl) =    Dhydif*dt__SV & !
+            /(dzmiSV(isl) & !
+            *LSdzsv(ikl))        !
+      Dhydtz(ikl,isl) =    Dhydtz(ikl,isl) * ist__s & ! Soil
+            +0.5*dzmiSV(isl)*LSdzsv(ikl)     * ist__w   ! Water bodies
+
+    END DO
+  END DO
+       isl=-nsol
+    DO ikl=1,knonv
+      Dhydtz(ikl,isl) =    0.0                        !
+    END DO
+
+
+  ! +--Tridiagonal Elimination: Set Up
+  ! +  -------------------------------
+
+  ! +--Soil/Snow Interior
+  ! +  ^^^^^^^^^^^^^^^^^^
+
+  DO   isl=0,-nsol,-1
+    DO ikl=1,knonv
+     ist             = isotSV(ikl)
+     eta_SV(ikl,isl) = max(epsi,           eta_SV(ikl,isl))
+    END DO
+  END DO
+
+  DO   isl=-nsol,-nsol+1
+    DO ikl=1,knonv
+      etaaux(ikl,isl) =  eta_SV(ikl,isl)
+    END DO
+  END DO
+
+  DO   isl=-nsol+1,-1
+    DO ikl=1,knonv
+      ist      =         isotSV(ikl)
+      ikm      = nkhy *  eta_SV(ikl,isl-1) / etadSV(ist)
+      ik0      = nkhy *  eta_SV(ikl,isl)   / etadSV(ist)
+      ikp      = nkhy *  eta_SV(ikl,isl+1) / etadSV(ist)
+
+      if(ikm<0.or.ik0<0.or.ikp<0)then
+       print *,"CRASH1 in sisvat_qso.f on pixel (i,j,n)", &
+             ii__SV(ikl),jj__SV(ikl),nn__SV(ikl)
+       print *,"decrease your time step or increase ntphys "// &
+             "and ntdiff in time_steps.f"
+       stop
+      endif
+
+
+      Elem_A   =         Dhydtz(ikl,isl) &
+            -  aKdtSV3(ist,ikm)* dziiSV(isl)  *LSdzsv(ikl)
+      Elem_B   =      - (Dhydtz(ikl,isl) &
+            +Dhydtz(ikl,isl+1) &
+            -aKdtSV3(ist,ik0)*(dziiSV(isl+1) &
+            -dzi_SV(isl) )*LSdzsv(ikl))
+      Elem_C   =         Dhydtz(ikl,isl+1) &
+            +  aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)
+      Diag_A(ikl,isl) =  dz_8SV(isl)        *LSdzsv(ikl) &
+            -Implic            * Elem_A
+      Diag_B(ikl,isl) =  dz34SV(isl)        *LSdzsv(ikl) &
+            -Implic            * Elem_B
+      Diag_C(ikl,isl) =  dz_8SV(isl)        *LSdzsv(ikl) &
+            -Implic            * Elem_C
+
+      Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_A     )*eta_SV(ikl,isl-1) &
+            + (dz34SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_B     )*eta_SV(ikl,isl) &
+            + (dz_8SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_C     )*eta_SV(ikl,isl+1) &
+            + (bKdtSV3(ist,ikp)* dzi_SV(isl+1) &
+            +bKdtSV3(ist,ik0)*(dziiSV(isl+1) &
+            -dzi_SV(isl)  ) &
+            -bKdtSV3(ist,ikm)* dziiSV(isl)   ) &
+            * LSdzsv(ikl)
+    END DO
+  END DO
+
+       isl=-nsol
+    DO ikl=1,knonv
+      ist      =         isotSV(ikl)
+  ! #       FreeDr   =         FreeD0            *  min(ist,1)
+      FreeDr   =         iWaFSV(ikl)       *  min(ist,1)
+      ik0      = nkhy *  eta_SV(ikl,isl  ) / etadSV(ist)
+      ikp      = nkhy *  eta_SV(ikl,isl+1) / etadSV(ist)
+
+      if(ik0<0.or.ikp<0)then
+       print *,"CRASH2 in sisvat_qso.f on pixel (i,j,n)", &
+             ii__SV(ikl),jj__SV(ikl),nn__SV(ikl)
+       print *,"decrease your time step or increase ntphys "// &
+             "and ntdiff in time_steps.f"
+       stop
+      endif
+
+      Elem_A   =         0.
+      Elem_B   =      - (Dhydtz(ikl,isl+1) &
+            -aKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl) &
+            -FreeDr                  ))
+      Elem_C   =         Dhydtz(ikl,isl+1) &
+            +  aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)
+      Diag_A(ikl,isl) =  0.
+      Diag_B(ikl,isl) =  dz78SV(isl) *LSdzsv(ikl) &
+            -Implic      *Elem_B
+      Diag_C(ikl,isl) =  dz_8SV(isl) *LSdzsv(ikl) &
+            -Implic      *Elem_C
+
+      Term_D(ikl,isl) = (dz78SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_B     )*eta_SV(ikl,isl) &
+            + (dz_8SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_C     )*eta_SV(ikl,isl+1) &
+            + (bKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl) &
+            +bKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl) &
+            -FreeDr                  ))
+    END DO
+
+       isl=0
+    DO ikl=1,knonv
+      ist      =         isotSV(ikl)
+      ikm      = nkhy *  eta_SV(ikl,isl-1) / etadSV(ist)
+      ik0      = nkhy *  eta_SV(ikl,isl)   / etadSV(ist)
+      Elem_A   =         Dhydtz(ikl,isl) &
+            -  aKdtSV3(ist,ikm)* dziiSV(isl)*LSdzsv(ikl)
+      Elem_B   =      - (Dhydtz(ikl,isl) &
+            +aKdtSV3(ist,ik0)* dzi_SV(isl)*LSdzsv(ikl))
+      Elem_C   =         0.
+      Diag_A(ikl,isl) =  dz_8SV(isl) *LSdzsv(ikl) &
+            -  Implic      *Elem_A
+      Diag_B(ikl,isl) =  dz78SV(isl) *LSdzsv(ikl) &
+            -  Implic      *Elem_B
+      Diag_C(ikl,isl) =  0.
+  ! +
+      Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_A     )*eta_SV(ikl,isl-1) &
+            + (dz78SV(isl) *LSdzsv(ikl) &
+            +Explic      *Elem_B     )*eta_SV(ikl,isl) &
+            - (bKdtSV3(ist,ik0)* dzi_SV(isl) &
+            +bKdtSV3(ist,ikm)* dziiSV(isl))*LSdzsv(ikl) &
+            + dt__SV *(HLs_sv(ikl)    *     (1-min(1,isnoSV(ikl))) &
+            / (ro_Wat *dz_dSV(0) * Lx_H2O(ikl)) &
+  !XF bug 17/05/2017
+            +drr_SV(ikl))/ro_Wat
+    END DO
+
+    DO ikl=1,knonv
+     drr_SV(ikl)=0. ! drr is included in the 1st soil layer
+    ENDDO
+
+  ! +
+  ! +
+  ! +--Tridiagonal Elimination
+  ! +  =======================
+  ! +
+  ! +--Forward  Sweep
+  ! +  ^^^^^^^^^^^^^^
+    DO ikl=  1,knonv
+      Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol)
+      Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol)
+    END DO
+  ! +
+  DO   isl=-nsol+1,0
+    DO ikl=      1,knonv
+      Aux__P(ikl,isl)   = Diag_A(ikl,isl)  *Aux__Q(ikl,isl-1) &
+            +Diag_B(ikl,isl)
+      Aux__Q(ikl,isl)   =-Diag_C(ikl,isl)  /Aux__P(ikl,isl)
+    END DO
+  END DO
+  ! +
+    DO ikl=      1,knonv
+      eta_SV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol)
+    END DO
+  ! +
+  DO   isl=-nsol+1,0
+    DO ikl=      1,knonv
+      eta_SV(ikl,isl)   =(Term_D(ikl,isl) &
+            -Diag_A(ikl,isl)  *eta_SV(ikl,isl-1)) &
+            /Aux__P(ikl,isl)
+    END DO
+  END DO
+
+  ! +--Backward Sweep
+  ! +  ^^^^^^^^^^^^^^
+  DO   isl=-1,-nsol,-1
+    DO ikl= 1,knonv
+      eta_SV(ikl,isl)   = Aux__Q(ikl,isl)  *eta_SV(ikl,isl+1) &
+            +eta_SV(ikl,isl)
+    END DO
+  END DO
+
+
+  ! +--Horton RunOFF Intensity
+  ! +  =======================
+
+  DO   isl=0,-nsol,-1
+    DO ikl=1,knonv
+      ist    =   isotSV(ikl)                   ! Soil Type
+      SatRat =  (eta_SV(ikl,isl)-etadSV(ist)) & ! OverSaturation Rate
+            *ro_Wat         *dzAvSV(isl) & !
+            *LSdzsv(ikl) & !
+            /dt__SV        !
+      SoRnOF(ikl)     =          SoRnOF(ikl) & !
+            + max(zero,SatRat)       !
+      RuofSV(ikl,3)   = RuofSV(ikl,3) + &
+            + max(zero,SatRat)
+      eta_SV(ikl,isl) = max(epsi & !
+  ! #ED.                         +etamSV(isotSV(ikl))!
+            ,eta_SV(ikl,isl))   !
+      eta_SV(ikl,isl) = min(eta_SV(ikl,isl) & !
+            ,etadSV(ist)    )   !
+    END DO
+  END DO
+
+  ! +--IO, for Verification
+  ! +  ~~~~~~~~~~~~~~~~~~~~
+  ! #WR     write(6,6010)
+  DO   isl= 0,-nsol,-1
+    DO ikl= 1,knonv
+      ist      =          isotSV(ikl)
+      ikp      = nkhy  *  eta_SV(ikl,isl)  /etadSV(ist)
+      Khydsv(ikl,isl)   =(aKdtSV3(ist,ikp)  *eta_SV(ikl,isl) &
+            +bKdtSV3(ist,ikp)) *2.0/dt__SV
+  ! #WR     write(6,6011) ikl,isl,eta_SV(ikl,isl)*1.e3,
+  ! #WR.                  ikp,    aKdtSV3(ist,ikp),bKdtSV3(ist,ikp),
+  ! #WR.                          Khydsv(ikl,isl)
+    END DO
+  END DO
+
+
+  ! +--Additional RunOFF Intensity
+  ! +  ===========================
+
+    DO ikl=1,knonv
+      ist      =          isotSV(ikl)
+      ik0      = nkhy  *  etaaux(ikl,-nsol  ) /etadSV(ist)
+  ! #       FreeDr   =          FreeD0            *  min(ist,1)
+      FreeDr   =          iWaFSV(ikl)       *  min(ist,1)
+      SoRnOF(ikl) =  SoRnOF(ikl) &
+            + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic &
+            +eta_SV(ikl,-nsol)*Implic) &
+            + bKdtSV3(ist,ik0)                           ) &
+            * FreeDr          *ro_Wat           /dt__SV
+    RuofSV(ikl,3) = RuofSV(ikl,3) &
+          + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic &
+          +eta_SV(ikl,-nsol)*Implic) &
+          + bKdtSV3(ist,ik0)                           ) &
+          * FreeDr          *ro_Wat           /dt__SV
+
+  ! +--Full Run OFF: Update
+  ! +  ~~~~~~~~~~~~~~~~~~~~
+      RnofSV(ikl)   = RnofSV(ikl)   + SoRnOF(ikl)
+      RuofSV(ikl,4) = RuofSV(ikl,4) + SoRnOF(ikl)
+    END DO
+
+
+  ! +--Temperature Correction due to a changed Soil Energy Content
+  ! +  ===========================================================
+
+  ! +!!!    Mettre en oeuvre le couplage humidit?-?nergie
+
+
+  ! +--Bumps/Asperites Treatment
+  ! +  =========================
+
+  ! +--Average over Bump Depth (z0soil)
+  ! +  --------------------------------
+
+  ! #BP       z_Bump      = 0.
+  ! #BP     DO ikl=1,knonv
+  ! #BP       etBump(ikl) = 0.
+  ! #BP     END DO
+  ! +
+  ! #BP DO     isl=0,-nsol,-1
+  ! #BP       z0Bump      = z_Bump
+  ! #BP       z_Bump      = z_Bump      +  dzAvSV(isl)
+  ! #BP   IF (z_Bump.lt.z0soil)                                       THEN
+  ! #BP     DO ikl=1,knonv
+  ! #BP       etBump(ikl) = etBump(ikl) +  dzAvSV(isl)   *eta_SV(ikl,isl)
+  ! #BP     END DO
+  ! #BP   END IF
+  ! #BP   IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil)                  THEN
+  ! #BP     DO ikl=1,knonv
+  ! #BP       etBump(ikl) = etBump(ikl) + (z0soil-z0Bump)*eta_SV(ikl,isl)
+  ! #BP       etBump(ikl) = etBump(ikl) /  z0soil
+  ! #BP     END DO
+  ! #BP   END IF
+  ! #BP END DO
+
+
+  ! +--Correction
+  ! +  ----------
+
+  ! #BP       z_Bump      = 0.
+  ! #BP DO     isl=0,-nsol,-1
+  ! #BP       z0Bump =  z_Bump
+  ! #BP       z_Bump =  z_Bump +dzAvSV(isl)
+  ! #BP   IF (z_Bump.lt.z0soil)                                       THEN
+  ! #BP     DO ikl=1,knonv
+  ! #BP       eta_SV(ikl,isl) = etBump(ikl)
+  ! #BP     END DO
+  ! #BP   END IF
+  ! #BP   IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil)                  THEN
+  ! #BP       dzBump          =    z_Bump -  z0soil
+  ! #BP     DO ikl=1,knonv
+  ! #BP       eta_SV(ikl,isl) =(etBump(ikl)    *(dzAvSV(isl)-dzBump)
+  ! #BP.                      + eta_SV(ikl,isl)*             dzBump)
+  ! #BP.                      /                  dzAvSV(isl)
+  ! #BP     END DO
+  ! #BP   END IF
+  ! #BP END DO
+
+
+  ! +--Positive Definite
+  ! +  =================
+
+  ! #BP DO   isl= 0,-nsol,-1
+  ! #BP   DO ikl= 1,knonv
+  ! #BP     eta_SV(ikl,isl)   =          max(epsi,eta_SV(ikl,isl))
+  ! #BP   END DO
+  ! #BP END DO
+
+
+  ! +--Water  Budget (OUT)
+  ! +  ===================
+
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_d(ikl) = Wats_d(ikl)                    !
+  ! #m0.                + drr_SV(ikl)     *zero          ! Precipitation is
+  ! +                                      \______________ already included
+  ! #m0.                + HLs_sv(ikl)
+  ! #m0.          *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl)   ! Evaporation
+  ! #m0.                - SoRnOF(ikl)                    ! Soil RunOFF Contrib.
+  ! #m0     Wats_1(ikl) = 0.                             !
+  ! #mw     Evapor(ikl) = HLs_sv(ikl)     *dt__SV        !
+  ! #mw.          *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl)   !
+  ! #m0   END DO
+
+  ! #m0 DO   isl= -nsol,0
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_d(ikl) = Wats_d(ikl)                    !
+  ! #m0   END DO
+  ! #m0 END DO
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_d(ikl) = Wats_d(ikl)     *dt__SV        !
+  ! #m0   END DO
+
+  ! #m0      isl= -nsol
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_1(ikl) = Wats_1(ikl)
+  ! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
+  ! #m0.                + eta_SV(ikl,isl+1) *dz_8SV(isl) ) *LSdzsv(ikl)
+  ! #m0   END DO
+
+  ! #m0 DO   isl= -nsol+1,-1
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_1(ikl) = Wats_1(ikl)
+  ! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz34SV(isl)
+  ! #m0.                +(eta_SV(ikl,isl-1)
+  ! #m0.                 +eta_SV(ikl,isl+1))*dz_8SV(isl) ) *LSdzsv(ikl)
+  ! #m0   END DO
+  ! #m0 END DO
+
+  ! #m0      isl=  0
+  ! #m0   DO ikl=1,knonv
+  ! #m0     Wats_1(ikl) = Wats_1(ikl)
+  ! #m0.      + ro_Wat *( eta_SV(ikl,isl)   *dz78SV(isl)
+  ! #m0.                + eta_SV(ikl,isl-1) *dz_8SV(isl) ) *LSdzsv(ikl)
+  ! #m0   END DO
+
+
+
+end subroutine sisvat_qso
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_sno_albedo.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_sno_albedo.F	(revision 5104)
+++ 	(revision )
@@ -1,765 +1,0 @@
-      SUBROUTINE SnOptP(jjtime)
- 
-C +------------------------------------------------------------------------+
-C | MAR/SISVAT   SnOptP                                    12-08-2019  MAR |
-C |   SubRoutine SnOptP computes the Snow Pack optical Properties          |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     Grid Boxes       |
-C |                     X       Number of Mosaic Cell per Grid Box         |
-C |                                                                        |
-C |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
-C |   ^^^^^    ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
-C |                                                                        |
-C |                                                                        |
-C |   INPUT:   G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
-C |   ^^^^^    G2snSV   : Sphericity (>0) or Size            of Snow Layer |
-C |            agsnSV   : Snow       Age                             [day] |
-C |            ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
-C |            eta_SV   : Water      Content                       [m3/m3] |
-C |            rusnSV   : Surficial  Water   Thickness   [kg/m2] .OR. [mm] |
-C |            SWS_SV   : Surficial  Water   Status                        |
-C |            dzsnSV   : Snow       Layer   Thickness                 [m] |
-C |                                                                        |
-C |            albssv   : Soil       Albedo                            [-] |
-C |            zzsnsv   : Snow       Pack    Thickness                 [m] |
-C |                                                                        |
-C |   OUTPUT:  albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
-C |   ^^^^^^   sEX_sv   : Verticaly Integrated Extinction Coefficient      |
-C |            DOPsnSV   : Snow Optical diameter [m]                       |
-C |                                                                        |
-C |   Internal Variables:                                                  |
-C |   ^^^^^^^^^^^^^^^^^^                                                   |
-C |            SnOpSV   : Snow Grain optical Size                      [m] |
-C |            EX1_sv   : Integrated Snow Extinction (0.3--0.8micr.m)      |
-C |            EX2_sv   : Integrated Snow Extinction (0.8--1.5micr.m)      |
-C |            EX3_sv   : Integrated Snow Extinction (1.5--2.8micr.m)      |
-C |                                                                        |
-C |   METHODE:    Calcul de la taille optique des grains ? partir de       |
-C |   ^^^^^^^    -leur type decrit par les deux variables descriptives     |
-C |                    continues sur la plage -99/+99 passees en appel.    |
-C |              -la taille optique (1/10mm) des etoiles,                  |
-C |                                          des grains fins et            |
-C |                                          des jeunes faces planes       |
-C |                                                                        |
-C |   METHOD:     Computation of the optical diameter of the grains        |
-C |   ^^^^^^      described with the CROCUS formalism G1snSV / G2snSV      |
-C |                                                                        |
-C |   REFERENCE: Brun et al.      1989, J. Glaciol 35 pp. 333--342         |
-C |   ^^^^^^^^^  Brun et al.      1992, J. Glaciol 38 pp.  13-- 22         |
-C |              Eric Martin Sept.1996                                     |
-C |                                                                        |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
- 
-
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VARxSV
-      use VARySV
-      use VARtSV
-      USE surface_data, only: iflag_albcalc,correc_alb
-
-      IMPLICIT NONE
-
- 
-C + -- INPUT
-      integer jjtime
-
-C +--Internal Variables
-C +  ==================
- 
-      real      coalb1(knonv)                      ! weighted Coalbedo, Vis.
-      real      coalb2(knonv)                      ! weighted Coalbedo, nIR 1
-      real      coalb3(knonv)                      ! weighted Coalbedo, nIR 2
-      real      coalbm                             ! weighted Coalbedo, mean
-      real      sExt_1(knonv)                      ! Extinction Coeff., Vis.
-      real      sExt_2(knonv)                      ! Extinction Coeff., nIR 1
-      real      sExt_3(knonv)                      ! Extinction Coeff., nIR 2
-      real      SnOpSV(knonv,      nsno)           ! Snow Grain optical Size
-c #AG real      agesno
- 
-      integer   isn   ,ikl   ,isn1, i  
-      real      sbeta1,sbeta2,sbeta3,sbeta4,sbeta5
-      real      AgeMax,AlbMin,HSnoSV,HIceSV,doptmx,SignG1,Sph_OK
-      real      dalbed,dalbeS,dalbeW
-      real      bsegal,czemax,csegal,csza
-      real      RoFrez,DiffRo,SignRo,SnowOK,OpSqrt
-      real      albSn1,albIc1,a_SnI1,a_SII1
-      real      albSn2,albIc2,a_SnI2,a_SII2
-      real      albSn3,albIc3,a_SnI3,a_SII3
-      real      albSno,albIce,albSnI,albSII,albWIc,albmax
-      real      doptic,Snow_H,SIce_H,SnownH,SIcenH
-      real      exarg1,exarg2,exarg3,sign_0,sExt_0
-      real      albedo_old,albCor
-      real      ro_ave,dz_ave,minalb
-      real      l1min,l1max,l2min,l2max,l3min,l3max
-      real      l6min(6), l6max(6), albSn6(6), a_SII6(6)
-      real      lmintmp,lmaxtmp,albtmp
- 
-C +--Local   DATA
-C +  ============
- 
-C +--For the computation of the solar irradiance extinction in snow
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-      data      sbeta1/0.0192/,sbeta2/0.4000/,sbeta3/0.1098/
-      data      sbeta4/1.0000/
-      data      sbeta5/2.00e1/
- 
-C +--Snow Age Maximum (Taiga, e.g. Col de Porte)
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-      data      AgeMax  /60.0/
-C +...          AgeMax:  Snow Age Maximum                              [day]
- 
-      data      AlbMin  /0.94/
-C +...          AlbMin:  Albedo   Minimum / visible (0.3--0.8 micrometers)
- 
-      data      HSnoSV  /0.01/
-C +...          HSnoSV:  Snow     Thickness through witch
-C +                      Albedo is interpolated to Ice  Albedo
-      data      HIceSV  /0.10/
-C +...          HIceSV:  Snow/Ice Thickness through witch
-C +                      Albedo is interpolated to Soil Albedo
-      data      doptmx  /2.3e-3/
-C +...          doptmx:  Maximum  optical Diameter    (pi * R**2)        [m]
-C +
-      data      czeMAX  /0.173648178/  ! 80.deg (Segal et al., 1991 JAS)
-
-      data      bsegal  /4.00       /  !
-      data      albmax  /0.99       /  ! Albedo max
-
-C +-- wavelength limits [m] for each broad band
-
-      data      l1min/400.0e-9/,l1max/800.0e-9/
-      data      l2min/800.0e-9/,l2max/1500.0e-9/
-      data      l3min/1500.0e-9/,l3max/2800.0e-9/
-
-      data      l6min/185.0e-9,250.0e-9,400.0e-9,
-     .               690.0e-9,1190.0e-9,2380.0e-9/
-      data      l6max/250.0e-9,400.0e-9,
-     .          690.0e-9,1190.0e-9,2380.0e-9,4000.0e-9/
- 
- 
-C +--Snow Grain optical Size
-C +  =======================
- 
-        DO ikl=1,knonv
-         DO   isn=1,max(1,isnoSV(ikl))
- 
-          G2snSV(ikl,isn) =  max(epsi,G2snSV(ikl,isn))
-C +...    Avoid non physical Values
- 
-          SignG1          = sign(unun,G1snSV(ikl,isn))
-          Sph_OK          =  max(zero,SignG1)
- 
-          SnOpSV(ikl,isn) =   1.e-4 *
-C +...    SI:           (from 1/10 mm to m)
- 
- 
-C +--Contribution of Non Dendritic Snow
-C +  ----------------------------------
- 
-     .    (    Sph_OK *(      G2snSV(ikl,isn)*G1snSV(ikl,isn)/G1_dSV
-     .              +max(demi*G2snSV(ikl,isn),DFcdSV)
-     .                 *(unun-G1snSV(ikl,isn)                /G1_dSV))
- 
- 
-C +--Contribution of     Dendritic Snow
-C +  ----------------------------------
- 
-     .    +(1.-Sph_OK)*(     -G1snSV(ikl,isn)*DDcdSV         /G1_dSV
-     .                 +(unun+G1snSV(ikl,isn)                /G1_dSV)
-     .                  *    (G2snSV(ikl,isn)*DScdSV         /G1_dSV
-     .                 +(unun-G2snSV(ikl,isn)                /G1_dSV)
-     .                                       *DFcdSV                 )))
-          SnOpSV(ikl,isn) =  max(zero,SnOpSV(ikl,isn))
-
-C + --For outputs (Etienne)
-C + ------------------------
-          DOPsnSV(ikl,isn)=SnOpSV(ikl,isn)
-        END DO
-      END DO
- 
-
-
- 
-C +--Snow/Ice Albedo
-C +  ===============
-
- 
- 
-C +--Uppermost effective Snow Layer
-C +  ------------------------------
- 
-        DO ikl=1,knonv
- 
-          isn   =  max(iun,isnoSV(ikl))
- 
-          SignRo = sign(unun, rocdSV - ro__SV(ikl,isn))
-          SnowOK =  max(zero,SignRo) ! Ice Density Threshold
- 
-          OpSqrt = sqrt(SnOpSV(ikl,isn))
- 
-cCA    +--Correction of snow albedo for Antarctica/Greenland
-cCA       --------------------------------------------------
-
-          
-          albCor = correc_alb 
-c #GL     albCor = 1.01
-c #AC    albCor = 1.01
-
-
-          IF (iflag_albcalc >= 1) THEN  ! Albedo calculation according to Kokhanovsky and Zege 2004
-
-          dalbed = 0.0
-          doptic=SnOpSV(ikl,isn)
-          csza=coszSV(ikl)
-
-          CALL albedo_kokhanovsky(l1min,l1max,csza,doptic,albSn1)
-          CALL albedo_kokhanovsky(l2min,l2max,csza,doptic,albSn2)
-          CALL albedo_kokhanovsky(l3min,l3max,csza,doptic,albSn3)
-
-          DO i=1,6
-             lmintmp=l6min(i)
-             lmaxtmp=l6max(i)
-             CALL albedo_kokhanovsky(lmintmp,lmaxtmp,csza,doptic,albtmp)
-             albSn6(i)=albtmp
-          ENDDO
-
-
-          ELSE ! Default calculation in SISVAT
-
-!    Zenith Angle Correction (Segal et al.,         1991, JAS 48, p.1025)
-!--------------------------- (Wiscombe & Warren, dec1980, JAS   , p.2723)
-!                            (Warren,               1982,  RG   , p.  81)
-!                            -------------------------------------------------
-          
-          dalbed = 0.0
-
-          csegal = max(czemax                   ,coszSV(ikl))
-c #cz     dalbeS =   ((bsegal+unun)/(unun+2.0*bsegal*csegal)
-c #cz.                -       unun                          )*0.32
-c #cz.              /  bsegal
-c #cz     dalbeS = max(dalbeS,zero)
-c #cz     dalbed =     dalbeS      *       min(1,isnoSV(ikl))
- 
-          dalbeW =(0.64 - csegal  )*0.0625  ! Warren 1982, RevGeo, fig.12b
-                                            ! 0.0625 = 5% * 1/0.8,   p.81
-                                            ! 0.64   = cos(50)
-          dalbed =     dalbeW      *       min(1,isnoSV(ikl))
-!-------------------------------------------------------------------------
-
-          albSn1 =  0.96-1.580*OpSqrt
-          albSn1 =  max(albSn1,AlbMin)
- 
-          albSn1 =  max(albSn1,zero)
-          albSn1 =  min(albSn1*albCor,unun)
- 
-          albSn2 =  0.95-15.40*OpSqrt
-          albSn2 =  max(albSn2,zero)
-          albSn2 =  min(albSn2*albCor,unun)
- 
-          doptic =  min(SnOpSV(ikl,isn),doptmx)
-          albSn3 =  346.3*doptic -32.31*OpSqrt +0.88
-          albSn3 =  max(albSn3,zero)
-          albSn3 =  min(albSn3*albCor,unun)
- 
-          albSn6(1:3)=albSn1
-          albSn6(4:6)=albSn2
-
-          !snow albedo corection if wetsnow
-c #GL     albSn1 =  albSn1*max(0.9,(1.-1.5*eta_SV(ikl,isn)))
-c #GL     albSn2 =  albSn2*max(0.9,(1.-1.5*eta_SV(ikl,isn)))
-c #GL     albSn3 =  albSn3*max(0.9,(1.-1.5*eta_SV(ikl,isn)))
-
-          ENDIF
-
- 
-          albSno =  So1dSV*albSn1
-     .           +  So2dSV*albSn2
-     .           +  So3dSV*albSn3
- 
-cXF
-          minalb =  (aI2dSV + (aI3dSV -aI2dSV)
-     .           *  (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice))
-          minalb =  min(aI3dSV,max(aI2dSV,minalb)) ! pure/firn albedo
- 
-          SnowOK =  SnowOK*max(zero,sign(unun,     albSno-minalb))
-          albSn1 =  SnowOK*albSn1+(1.0-SnowOK)*max(albSno,minalb)
-          albSn2 =  SnowOK*albSn2+(1.0-SnowOK)*max(albSno,minalb)
-          albSn3 =  SnowOK*albSn3+(1.0-SnowOK)*max(albSno,minalb)
-          albSn6(:) =  SnowOK*albSn6(:)+(1.0-SnowOK)*max(albSno,minalb)
-
- 
-c +           ro < roSdSV |          min al > aI3dSV
-c +  roSdSV < ro < rocdSV | aI2dSV < min al < aI3dSV (fct of density)
- 
- 
-C +--Snow/Ice Pack Thickness
-C +  -----------------------
- 
-          isn    =    max(min(isnoSV(ikl) ,ispiSV(ikl)),0)
-          Snow_H =  zzsnsv(ikl,isnoSV(ikl))-zzsnsv(ikl,isn)
-          SIce_H =  zzsnsv(ikl,isnoSV(ikl))
-          SnownH =  Snow_H  /  HSnoSV
-          SnownH =  min(unun,  SnownH)
-          SIcenH =  SIce_H  / (HIceSV)
-          SIcenH =  min(unun,  SIcenH)
- 
-C +       The value of SnownH is set to 1 in case of ice lenses above
-C +       1m of dry snow (ro<600kg/m3) for using CROCUS albedo
- 
-c         ro_ave =  0.
-c         dz_ave =  0.
-c         SnowOK =  1.
-c      do isn    =  isnoSV(ikl),1,-1
-c         ro_ave =  ro_ave + ro__SV(ikl,isn) * dzsnSV(ikl,isn) * SnowOK
-c         dz_ave =  dz_ave +                   dzsnSV(ikl,isn) * SnowOK
-c         SnowOK =  max(zero,sign(unun,1.-dz_ave))
-c      enddo
- 
-c         ro_ave =  ro_ave / max(dz_ave,epsi)
-c         SnowOK =  max(zero,sign(unun,600.-ro_ave))
-c         SnownH =  SnowOK + SnownH * (1. - SnowOK)
- 
-C +--Integrated Snow/Ice Albedo: Case of Water on Bare Ice
-C +  -----------------------------------------------------
- 
-          isn    =  max(min(isnoSV(ikl) ,ispiSV(ikl)),0)
- 
-          albWIc =  aI1dSV-(aI1dSV-aI2dSV)
-     .           *  exp(-(rusnSV(ikl)                      !
-     .           *  (1. -SWS_SV(ikl)                       ! 0 <=> freezing
-     .           *  (1  -min(1,iabs(isn-isnoSV(ikl)))))    ! 1 <=> isn=isnoSV
-     .           /   ru_dSV)**0.50)                        !
-c         albWIc = max(aI1dSV,min(aI2dSV,albWIc+slopSV(ikl)*
-c    .             min(5.,max(1.,dx/10000.))))
- 
-          SignRo = sign(unun,ro_Ice-5.-ro__SV(ikl,isn))    ! RoSN<920kg/m3
-          SnowOK =  max(zero,SignRo)
- 
-          albWIc = (1. - SnowOK) * albWIc + SnowOK
-     .           * (aI2dSV + (aI3dSV -aI2dSV)
-     .           * (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice))
- 
-c +  rocdSV < ro < ro_ice | aI2dSV< al <aI3dSV (fct of density)
-c +           ro > ro_ice | aI1dSV< al <aI2dSV (fct of superficial water content
- 
- 
-C +--Integrated Snow/Ice      Albedo
-C +  -------------------------------
- 
-          a_SII1      =     albWIc      +(albSn1-albWIc)     *SnownH
-          a_SII1      = min(a_SII1       ,albSn1)
- 
-          a_SII2      =     albWIc      +(albSn2-albWIc)     *SnownH
-          a_SII2      = min(a_SII2       ,albSn2)
- 
-          a_SII3      =     albWIc      +(albSn3-albWIc)     *SnownH
-          a_SII3      = min(a_SII3       ,albSn3)
-
-          DO i=1,6
-          a_SII6(i)   = albWIc      +(albSn6(i)-albWIc)     *SnownH
-          a_SII6(i)   = min(a_SII6(i)       ,albSn6(i))
-          ENDDO
-
-cc #AG     agesno =      min(agsnSV(ikl,isn)          ,AgeMax)
-cc #AG     a_SII1      =     a_SII1      -0.175*agesno/AgeMax
-C +...                                   Impurities: Col de Porte Parameter.
- 
-
- 
-C +--Elsewhere    Integrated Snow/Ice Albedo
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c #cp     ELSE
-            albSII =     So1dSV*a_SII1
-     .                 + So2dSV*a_SII2
-     .                 + So3dSV*a_SII3
-c #cp     END IF
- 
- 
-C +--Integrated Snow/Ice/Soil Albedo
-C +  -------------------------------
- 
-            alb1sv(ikl) =     albssv(ikl) +(a_SII1-albssv(ikl))*SIcenH
-            alb1sv(ikl) = min(alb1sv(ikl)  ,a_SII1)
- 
-            alb2sv(ikl) =     albssv(ikl) +(a_SII2-albssv(ikl))*SIcenH
-            alb2sv(ikl) = min(alb2sv(ikl)  ,a_SII2)
- 
-            alb3sv(ikl) =     albssv(ikl) +(a_SII3-albssv(ikl))*SIcenH
-            alb3sv(ikl) = min(alb3sv(ikl)  ,a_SII3)
-
-            albisv(ikl) =     albssv(ikl) +(albSII-albssv(ikl))*SIcenH
-            albisv(ikl) = min(albisv(ikl)  ,albSII)
-
-            DO i=1,6
-            alb6sv(ikl,i) = albssv(ikl) +(a_SII6(i)-albssv(ikl))*SIcenH
-            alb6sv(ikl,i) = min(alb6sv(ikl,i)  ,a_SII6(i))
-            ENDDO
-
- 
-C +--Integrated Snow/Ice/Soil Albedo: Clouds Correction! Greuell & all., 1994
-C +  --------------------------------------------------! Glob.&t Planet.Change
-                                                       ! (9):91-114
-            alb1sv(ikl) = alb1sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH
-     .                  + dalbed      *    (1.-cld_SV(ikl))
-            alb2sv(ikl) = alb2sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH
-     .                  + dalbed      *    (1.-cld_SV(ikl))
-            alb3sv(ikl) = alb3sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH
-     .                  + dalbed      *    (1.-cld_SV(ikl))
-            alb6sv(ikl,:) =alb6sv(ikl,:)+0.05 *(cld_SV(ikl)-0.5)*SIcenH
-     .                  + dalbed      *    (1.-cld_SV(ikl))
-            albisv(ikl) = albisv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH
-     .                  + dalbed      *    (1.-cld_SV(ikl))
- 
-C +--Integrated Snow/Ice/Soil Albedo: Minimum snow albedo = aI1dSV
-C +  -------------------------------------------------------------
- 
-            albedo_old  = albisv(ikl)
-            albisv(ikl) = max(albisv(ikl),aI1dSV   * SIcenH
-     .                  + albssv(ikl) *(1.0        - SIcenH))
-            alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0             ! 33 %
-     .                  * (albedo_old-albisv(ikl)) / So1dSV
-            alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0             ! 33 %
-     .                  * (albedo_old-albisv(ikl)) / So2dSV
-            alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0             ! 33 %
-     .                  * (albedo_old-albisv(ikl)) / So3dSV
-            alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0     ! 16 %
-     .                  * (albedo_old-albisv(ikl)) / (So1dSV/3)
-            alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0     ! 16 %
-     .                  * (albedo_old-albisv(ikl)) / (So2dSV/3)
-
-
-C +--Integrated Snow/Ice/Soil Albedo: Maximum albedo = 95% 
-C +  -----------------------------------------------------
- 
-            albedo_old  = albisv(ikl)
-            albisv(ikl) = min(albisv(ikl),0.95)
-            alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0             ! 33 %
-     .                  * (albedo_old-albisv(ikl)) / So1dSV
-            alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0             ! 33 %
-     .                  * (albedo_old-albisv(ikl)) / So2dSV
-            alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0             ! 33 %
-     .                  * (albedo_old-albisv(ikl)) / So3dSV
-            alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0     ! 16 %
-     .                  * (albedo_old-albisv(ikl)) / (So1dSV/3)
-            alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0     ! 16 %
-     .                  * (albedo_old-albisv(ikl)) / (So2dSV/3)
-
-
-	!Sea Ice/snow permanent-interractive prescription from Nemo 
-	!AO_CK 20/02/2020
-
-        ! No check if coupling update since MAR and NEMO albedo are too different
-	! and since MAR albedo is computed on properties that are not in NEMO
-        ! prescription for each time step with NEMO values 
-	
-c #AO      if (LSmask(ikl) .eq. 0 .and. coupling_ao .eq. .TRUE.) then
-c #AO       if (AOmask(ikl) .eq. 0) then  
-c #AO       albisv(ikl) =  (1.-AOmask(ikl))* albAOsisv(ikl)
-c #AO.                    +(AOmask(ikl)*albisv(ikl))
-c #AO       alb1sv(ikl) =   (1.-AOmask(ikl))* albAOsisv(ikl)
-c #AO.                    +(AOmask(ikl)*alb1sv(ikl))
-c #AO       alb2sv(ikl) =   (1.-AOmask(ikl))* albAOsisv(ikl)
-c #AO.                    +(AOmask(ikl)*alb2sv(ikl))
-c #AO       alb3sv(ikl) =   (1.-AOmask(ikl))* albAOsisv(ikl)
-c #AO.                    +(AOmask(ikl)*alb3sv(ikl))
-c #AO       endif
-c #AO      endif
-
- 
-            alb1sv(ikl) = min(max(zero,alb1sv(ikl)),albmax)
-            alb2sv(ikl) = min(max(zero,alb2sv(ikl)),albmax)
-            alb3sv(ikl) = min(max(zero,alb3sv(ikl)),albmax)
-            
-            DO i=1,6
-                alb6sv(ikl,i) = min(max(zero,alb6sv(ikl,i)),albmax)
-            ENDDO 
-        END DO
- 
- 
-C +--Extinction Coefficient: Exponential Factor
-C +  ==========================================
- 
-        DO ikl=1,knonv
-          sExt_1(ikl)        = 1.
-          sExt_2(ikl)        = 1.
-          sExt_3(ikl)        = 1.
-          sEX_sv(ikl,nsno+1) = 1.
- 
-          coalb1(ikl) = (1.          -alb1sv(ikl))*So1dSV
-          coalb2(ikl) = (1.          -alb2sv(ikl))*So2dSV
-          coalb3(ikl) = (1.          -alb3sv(ikl))*So3dSV
-          coalbm      =  coalb1(ikl) +coalb2(ikl) +coalb3(ikl)
-          coalb1(ikl) =  coalb1(ikl)              /coalbm
-          coalb2(ikl) =  coalb2(ikl)              /coalbm
-          coalb3(ikl) =  coalb3(ikl)              /coalbm
-        END DO
- 
-cXF
- 
-        DO   isn=nsno,1,-1
-          DO ikl=1,knonv
-            sEX_sv(ikl,isn) = 1.0
-           !sEX_sv(ikl,isn) = 0.95 ! if MAR is too warm in summer
-          END DO
-        END DO
- 
-        DO ikl=1,knonv
-         DO isn=max(1,isnoSV(ikl)),1,-1
- 
-          SignRo = sign(unun, rocdSV - ro__SV(ikl,isn))
-          SnowOK =  max(zero,SignRo) ! Ice Density Threshold
- 
-          RoFrez =  1.e-3      * ro__SV(ikl,isn) * (1.0-eta_SV(ikl,isn))
- 
-          OpSqrt = sqrt(max(epsi,SnOpSV(ikl,isn)))
-          exarg1 =      SnowOK  *1.e2 *max(sbeta1*RoFrez/OpSqrt,sbeta2)
-     .            +(1.0-SnowOK)           *sbeta5
-          exarg2 =      SnowOK  *1.e2 *max(sbeta3*RoFrez/OpSqrt,sbeta4)
-     .            +(1.0-SnowOK)           *sbeta5
-          exarg3 =      SnowOK  *1.e2     *sbeta5
-     .            +(1.0-SnowOK)           *sbeta5
- 
- 
-C +--Integrated Extinction of Solar Irradiance (Normalized Value)
-C +  ============================================================
- 
-          sExt_1(ikl) = sExt_1(ikl)
-     .                          * exp(min(0.0,-exarg1 *dzsnSV(ikl,isn)))
-          sign_0      =              sign(unun,eps9   -sExt_1(ikl))
-          sExt_0      =               max(zero,sign_0)*sExt_1(ikl)
-          sExt_1(ikl) = sExt_1(ikl)                   -sExt_0
- 
-          sExt_2(ikl) = sExt_2(ikl)
-     .                          * exp(min(0.0,-exarg2 *dzsnSV(ikl,isn)))
-          sign_0      =              sign(unun,eps9   -sExt_2(ikl))
-          sExt_0      =               max(zero,sign_0)*sExt_2(ikl)
-          sExt_2(ikl) = sExt_2(ikl)                   -sExt_0
- 
-          sExt_3(ikl) = sExt_3(ikl)
-     .                          * exp(min(0.0,-exarg3 *dzsnSV(ikl,isn)))
-          sign_0      =              sign(unun,eps9   -sExt_3(ikl))
-          sExt_0      =               max(zero,sign_0)*sExt_3(ikl)
-          sExt_3(ikl) = sExt_3(ikl)                   -sExt_0
- 
-          sEX_sv(ikl,isn) = coalb1(ikl) * sExt_1(ikl)
-     .                    + coalb2(ikl) * sExt_2(ikl)
-     .                    + coalb3(ikl) * sExt_3(ikl)
-        END DO
-      END DO
- 
-      DO   isn=0,-nsol,-1
-        DO ikl=1,knonv
-          sEX_sv(ikl,isn) = 0.0
-        END DO
-      END DO
- 
- 
-      return
-
-
-      end
-
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-      SUBROUTINE albedo_kokhanovsky(lambdamin,lambdamax,
-     .                              cossza,dopt,albint)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-! Authors: Hajar El Habchi El Fenniri, Etienne Vignon, Cecile Agosta
-!          Ghislain Picard
-! Routine that calculates the  integrated snow spectral albedo between 
-! lambdamin and lambdamax following Kokhanisky and Zege 2004,
-! Scattering optics of snow, Applied Optics, Vol 43, No7 
-! Code inspired from the snowoptics package of Ghislain Picard:
-! https://github.com/ghislainp/snowoptics
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-       
-      USE VARphy
-
-      IMPLICIT NONE
-
-! Inputs
-!--------
-      REAL lambdamin   ! minimum wavelength for integration [m]
-      REAL lambdamax   ! maximum wavelength for integration [m] 
-      REAL cossza     ! solar zenith angle cosinus
-      REAL dopt        ! optical diameter [m]
-
-!Outputs
-!-------
-      REAL albint
-
-! Local Variables
-!-----------------
-
-      REAL ropt,cosalb,norm,Pas
-      REAL SSA,alpha,gamm,R,cos30,alb30
-      INTEGER i
-
-
-      REAL B_amp                       ! amplification factor
-      PARAMETER (B_amp=1.6)  
-
-      REAL g_asy                       ! asymetry factor 
-      PARAMETER (g_asy=0.845)
-
-      INTEGER nlambda                  ! length of wavelength vector 
-      PARAMETER(nlambda=200)
-
-      REAL lmin
-      PARAMETER(lmin=185.0E-9)
-
-      REAL lmax
-      PARAMETER(lmax=4000.0E-9)
-
-      REAL albmax
-      PARAMETER(albmax=0.99)
-
-      REAL wavelengths(nlambda)
-      REAL ni(nlambda)
-
-      DATA wavelengths / 1.85000000e-07, 2.04170854e-07,
-     . 2.23341709e-07, 2.42512563e-07,
-     . 2.61683417e-07, 2.80854271e-07, 3.00025126e-07, 3.19195980e-07,
-     . 3.38366834e-07, 3.57537688e-07, 3.76708543e-07, 3.95879397e-07,
-     . 4.15050251e-07, 4.34221106e-07, 4.53391960e-07, 4.72562814e-07,
-     . 4.91733668e-07, 5.10904523e-07, 5.30075377e-07, 5.49246231e-07,
-     . 5.68417085e-07, 5.87587940e-07, 6.06758794e-07, 6.25929648e-07,
-     . 6.45100503e-07, 6.64271357e-07, 6.83442211e-07, 7.02613065e-07,
-     . 7.21783920e-07, 7.40954774e-07, 7.60125628e-07, 7.79296482e-07,
-     . 7.98467337e-07, 8.17638191e-07, 8.36809045e-07, 8.55979899e-07,
-     . 8.75150754e-07, 8.94321608e-07, 9.13492462e-07, 9.32663317e-07,
-     . 9.51834171e-07, 9.71005025e-07, 9.90175879e-07, 1.00934673e-06,
-     . 1.02851759e-06, 1.04768844e-06, 1.06685930e-06, 1.08603015e-06,
-     . 1.10520101e-06, 1.12437186e-06, 1.14354271e-06, 1.16271357e-06,
-     . 1.18188442e-06, 1.20105528e-06, 1.22022613e-06, 1.23939698e-06,
-     . 1.25856784e-06, 1.27773869e-06, 1.29690955e-06, 1.31608040e-06,
-     . 1.33525126e-06, 1.35442211e-06, 1.37359296e-06, 1.39276382e-06,
-     . 1.41193467e-06, 1.43110553e-06, 1.45027638e-06, 1.46944724e-06,
-     . 1.48861809e-06, 1.50778894e-06, 1.52695980e-06, 1.54613065e-06,
-     . 1.56530151e-06, 1.58447236e-06, 1.60364322e-06, 1.62281407e-06,
-     . 1.64198492e-06, 1.66115578e-06, 1.68032663e-06, 1.69949749e-06,
-     . 1.71866834e-06, 1.73783920e-06, 1.75701005e-06, 1.77618090e-06,
-     . 1.79535176e-06, 1.81452261e-06, 1.83369347e-06, 1.85286432e-06,
-     . 1.87203518e-06, 1.89120603e-06, 1.91037688e-06, 1.92954774e-06,
-     . 1.94871859e-06, 1.96788945e-06, 1.98706030e-06, 2.00623116e-06,
-     . 2.02540201e-06, 2.04457286e-06, 2.06374372e-06, 2.08291457e-06,
-     . 2.10208543e-06, 2.12125628e-06, 2.14042714e-06, 2.15959799e-06,
-     . 2.17876884e-06, 2.19793970e-06, 2.21711055e-06, 2.23628141e-06,
-     . 2.25545226e-06, 2.27462312e-06, 2.29379397e-06, 2.31296482e-06,
-     . 2.33213568e-06, 2.35130653e-06, 2.37047739e-06, 2.38964824e-06,
-     . 2.40881910e-06, 2.42798995e-06, 2.44716080e-06, 2.46633166e-06,
-     . 2.48550251e-06, 2.50467337e-06, 2.52384422e-06, 2.54301508e-06,
-     . 2.56218593e-06, 2.58135678e-06, 2.60052764e-06, 2.61969849e-06,
-     . 2.63886935e-06, 2.65804020e-06, 2.67721106e-06, 2.69638191e-06,
-     . 2.71555276e-06, 2.73472362e-06, 2.75389447e-06, 2.77306533e-06,
-     . 2.79223618e-06, 2.81140704e-06, 2.83057789e-06, 2.84974874e-06,
-     . 2.86891960e-06, 2.88809045e-06, 2.90726131e-06, 2.92643216e-06,
-     . 2.94560302e-06, 2.96477387e-06, 2.98394472e-06, 3.00311558e-06,
-     . 3.02228643e-06, 3.04145729e-06, 3.06062814e-06, 3.07979899e-06,
-     . 3.09896985e-06, 3.11814070e-06, 3.13731156e-06, 3.15648241e-06,
-     . 3.17565327e-06, 3.19482412e-06, 3.21399497e-06, 3.23316583e-06,
-     . 3.25233668e-06, 3.27150754e-06, 3.29067839e-06, 3.30984925e-06,
-     . 3.32902010e-06, 3.34819095e-06, 3.36736181e-06, 3.38653266e-06,
-     . 3.40570352e-06, 3.42487437e-06, 3.44404523e-06, 3.46321608e-06,
-     . 3.48238693e-06, 3.50155779e-06, 3.52072864e-06, 3.53989950e-06,
-     . 3.55907035e-06, 3.57824121e-06, 3.59741206e-06, 3.61658291e-06,
-     . 3.63575377e-06, 3.65492462e-06, 3.67409548e-06, 3.69326633e-06,
-     . 3.71243719e-06, 3.73160804e-06, 3.75077889e-06, 3.76994975e-06,
-     . 3.78912060e-06, 3.80829146e-06, 3.82746231e-06, 3.84663317e-06,
-     . 3.86580402e-06, 3.88497487e-06, 3.90414573e-06, 3.92331658e-06,
-     . 3.94248744e-06, 3.96165829e-06, 3.98082915e-06, 4.00000000e-06/
-
-
-      DATA ni /7.74508407e-10, 7.74508407e-10, 
-     .  7.74508407e-10, 7.74508407e-10,
-     .  7.74508407e-10, 7.74508407e-10, 7.74508407e-10, 7.74508407e-10,
-     .  6.98381122e-10, 6.23170274e-10, 5.97655992e-10, 5.84106004e-10,
-     .  5.44327597e-10, 5.71923510e-10, 6.59723827e-10, 8.05183870e-10,
-     .  1.03110161e-09, 1.36680386e-09, 1.85161253e-09, 2.56487751e-09,
-     .  3.56462855e-09, 4.89450926e-09, 6.49252022e-09, 9.62029335e-09,
-     .  1.32335015e-08, 1.75502184e-08, 2.19240625e-08, 3.03304156e-08,
-     .  4.07715972e-08, 5.00414911e-08, 7.09722331e-08, 1.00773751e-07,
-     .  1.31427409e-07, 1.42289041e-07, 1.49066787e-07, 2.01558515e-07,
-     .  2.99106105e-07, 4.03902086e-07, 4.54292169e-07, 5.21906983e-07,
-     .  6.27643362e-07, 9.43955678e-07, 1.33464494e-06, 1.97278315e-06,
-     .  2.31801329e-06, 2.20584676e-06, 1.85568138e-06, 1.73395193e-06,
-     .  1.73101406e-06, 1.91333936e-06, 2.26413019e-06, 3.23959718e-06,
-     .  4.94316963e-06, 6.89378896e-06, 1.02237444e-05, 1.21439656e-05,
-     .  1.31567585e-05, 1.33448288e-05, 1.32000000e-05, 1.31608040e-05,
-     .  1.33048369e-05, 1.40321464e-05, 1.51526244e-05, 1.80342858e-05,
-     .  3.82875736e-05, 1.07325259e-04, 2.11961637e-04, 3.82008054e-04,
-     .  5.30897470e-04, 5.29244735e-04, 4.90876605e-04, 4.33905427e-04,
-     .  3.77795349e-04, 3.17633099e-04, 2.81078564e-04, 2.57579485e-04,
-     .  2.42203100e-04, 2.23789060e-04, 2.04306870e-04, 1.87909255e-04,
-     .  1.73117146e-04, 1.61533186e-04, 1.53420328e-04, 1.47578033e-04,
-     .  1.42334776e-04, 1.35691466e-04, 1.30495414e-04, 1.36065123e-04,
-     .  1.70928821e-04, 2.66389730e-04, 4.80957955e-04, 8.25041961e-04,
-     .  1.21654792e-03, 1.50232875e-03, 1.62316078e-03, 1.61649750e-03,
-     .  1.53736801e-03, 1.42343711e-03, 1.24459117e-03, 1.02388611e-03,
-     .  7.89112523e-04, 5.97204264e-04, 4.57152413e-04, 3.62341259e-04,
-     .  2.99128332e-04, 2.57035569e-04, 2.26992203e-04, 2.07110355e-04,
-     .  2.05835688e-04, 2.25108810e-04, 2.64262893e-04, 3.23594011e-04,
-     .  3.93061117e-04, 4.62789970e-04, 5.19664416e-04, 5.59739628e-04,
-     .  5.93476084e-04, 6.22797885e-04, 6.57484833e-04, 6.92849600e-04,
-     .  7.26584901e-04, 7.56604648e-04, 7.68009488e-04, 7.65579073e-04,
-     .  7.50526164e-04, 7.39809972e-04, 7.55622847e-04, 8.05099514e-04,
-     .  9.67279246e-04, 1.16281559e-03, 1.42570247e-03, 2.04986585e-03,
-     .  2.93971170e-03, 4.49827711e-03, 7.32537532e-03, 1.18889734e-02,
-     .  1.85851805e-02, 2.86242532e-02, 4.34131035e-02, 6.37828307e-02,
-     .  9.24145850e-02, 1.35547945e-01, 1.94143245e-01, 2.54542814e-01,
-     .  3.02282024e-01, 3.42214181e-01, 3.85475065e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,
-     .  4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01/
-
-
-      Pas     =(lmax-lmin)/nlambda
-      ropt    = dopt/2.0
-      SSA     = 3.0/(rhoIce*ropt)
-      cos30   = cos(30.0/180.0*pi)
-
-
-      albint=0.
-      norm=0.
-        
-      DO i = 1,nlambda
-          gamm = 4.0 * pi * ni(i) / wavelengths(i)
-          cosalb = 2.0 / (SSA * rhoice) * B_amp * gamm
-          alpha = 16. / 3 * cosalb / (1.0 - g_asy)
-          R = exp(-(alpha**0.5) * 3.0 / 7.0 * (1.0 + 2.0 * cossza))
-          alb30 = exp(-(alpha**0.5)* 3.0 / 7.0 * (1.0 + 20 * cos30))
-
-          IF ((wavelengths(i)>=lambdamin).AND.
-     .       (wavelengths(i)<lambdamax)) THEN
-          albint=albint+R*Pas  ! rectangle integration -> can be improved with trapezintegration
-          norm=norm+Pas
-          ENDIF
-
-      END DO
-
-      albint=max(0.,min(albint/max(norm,1E-10),albmax))
-
-      END
-  
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_sno_albedo.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_sno_albedo.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_sno_albedo.f90	(revision 5105)
@@ -0,0 +1,765 @@
+SUBROUTINE SnOptP(jjtime)
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR/SISVAT   SnOptP                                    12-08-2019  MAR |
+  ! |   SubRoutine SnOptP computes the Snow Pack optical Properties          |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     Grid Boxes       |
+  ! |                     X       Number of Mosaic Cell per Grid Box         |
+  ! |                                                                        |
+  ! |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   ^^^^^    ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
+  ! |                                                                        |
+  ! |                                                                        |
+  ! |   INPUT:   G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+  ! |   ^^^^^    G2snSV   : Sphericity (>0) or Size            of Snow Layer |
+  ! |            agsnSV   : Snow       Age                             [day] |
+  ! |            ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
+  ! |            eta_SV   : Water      Content                       [m3/m3] |
+  ! |            rusnSV   : Surficial  Water   Thickness   [kg/m2] .OR. [mm] |
+  ! |            SWS_SV   : Surficial  Water   Status                        |
+  ! |            dzsnSV   : Snow       Layer   Thickness                 [m] |
+  ! |                                                                        |
+  ! |            albssv   : Soil       Albedo                            [-] |
+  ! |            zzsnsv   : Snow       Pack    Thickness                 [m] |
+  ! |                                                                        |
+  ! |   OUTPUT:  albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
+  ! |   ^^^^^^   sEX_sv   : Verticaly Integrated Extinction Coefficient      |
+  ! |            DOPsnSV   : Snow Optical diameter [m]                       |
+  ! |                                                                        |
+  ! |   Internal Variables:                                                  |
+  ! |   ^^^^^^^^^^^^^^^^^^                                                   |
+  ! |            SnOpSV   : Snow Grain optical Size                      [m] |
+  ! |            EX1_sv   : Integrated Snow Extinction (0.3--0.8micr.m)      |
+  ! |            EX2_sv   : Integrated Snow Extinction (0.8--1.5micr.m)      |
+  ! |            EX3_sv   : Integrated Snow Extinction (1.5--2.8micr.m)      |
+  ! |                                                                        |
+  ! |   METHODE:    Calcul de la taille optique des grains ? partir de       |
+  ! |   ^^^^^^^    -leur type decrit par les deux variables descriptives     |
+  ! |                    continues sur la plage -99/+99 passees en appel.    |
+  ! |              -la taille optique (1/10mm) des etoiles,                  |
+  ! |                                          des grains fins et            |
+  ! |                                          des jeunes faces planes       |
+  ! |                                                                        |
+  ! |   METHOD:     Computation of the optical diameter of the grains        |
+  ! |   ^^^^^^      described with the CROCUS formalism G1snSV / G2snSV      |
+  ! |                                                                        |
+  ! |   REFERENCE: Brun et al.      1989, J. Glaciol 35 pp. 333--342         |
+  ! |   ^^^^^^^^^  Brun et al.      1992, J. Glaciol 38 pp.  13-- 22         |
+  ! |              Eric Martin Sept.1996                                     |
+  ! |                                                                        |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VARxSV
+  use VARySV
+  use VARtSV
+  USE surface_data, only: iflag_albcalc,correc_alb
+
+  IMPLICIT NONE
+
+
+  ! + -- INPUT
+  integer :: jjtime
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  real :: coalb1(knonv)                      ! weighted Coalbedo, Vis.
+  real :: coalb2(knonv)                      ! weighted Coalbedo, nIR 1
+  real :: coalb3(knonv)                      ! weighted Coalbedo, nIR 2
+  real :: coalbm                             ! weighted Coalbedo, mean
+  real :: sExt_1(knonv)                      ! Extinction Coeff., Vis.
+  real :: sExt_2(knonv)                      ! Extinction Coeff., nIR 1
+  real :: sExt_3(knonv)                      ! Extinction Coeff., nIR 2
+  real :: SnOpSV(knonv,      nsno)           ! Snow Grain optical Size
+  ! #AG real      agesno
+
+  integer :: isn   ,ikl   ,isn1, i
+  real :: sbeta1,sbeta2,sbeta3,sbeta4,sbeta5
+  real :: AgeMax,AlbMin,HSnoSV,HIceSV,doptmx,SignG1,Sph_OK
+  real :: dalbed,dalbeS,dalbeW
+  real :: bsegal,czemax,csegal,csza
+  real :: RoFrez,DiffRo,SignRo,SnowOK,OpSqrt
+  real :: albSn1,albIc1,a_SnI1,a_SII1
+  real :: albSn2,albIc2,a_SnI2,a_SII2
+  real :: albSn3,albIc3,a_SnI3,a_SII3
+  real :: albSno,albIce,albSnI,albSII,albWIc,albmax
+  real :: doptic,Snow_H,SIce_H,SnownH,SIcenH
+  real :: exarg1,exarg2,exarg3,sign_0,sExt_0
+  real :: albedo_old,albCor
+  real :: ro_ave,dz_ave,minalb
+  real :: l1min,l1max,l2min,l2max,l3min,l3max
+  real :: l6min(6), l6max(6), albSn6(6), a_SII6(6)
+  real :: lmintmp,lmaxtmp,albtmp
+
+  ! +--Local   DATA
+  ! +  ============
+
+  ! +--For the computation of the solar irradiance extinction in snow
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  data      sbeta1/0.0192/,sbeta2/0.4000/,sbeta3/0.1098/
+  data      sbeta4/1.0000/
+  data      sbeta5/2.00e1/
+
+  ! +--Snow Age Maximum (Taiga, e.g. Col de Porte)
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  data      AgeMax  /60.0/
+  ! +...          AgeMax:  Snow Age Maximum                              [day]
+
+  data      AlbMin  /0.94/
+  ! +...          AlbMin:  Albedo   Minimum / visible (0.3--0.8 micrometers)
+
+  data      HSnoSV  /0.01/
+  ! +...          HSnoSV:  Snow     Thickness through witch
+  ! +                      Albedo is interpolated to Ice  Albedo
+  data      HIceSV  /0.10/
+  ! +...          HIceSV:  Snow/Ice Thickness through witch
+  ! +                      Albedo is interpolated to Soil Albedo
+  data      doptmx  /2.3e-3/
+  ! +...          doptmx:  Maximum  optical Diameter    (pi * R**2)        [m]
+  ! +
+  data      czeMAX  /0.173648178/  ! 80.deg (Segal et al., 1991 JAS)
+
+  data      bsegal  /4.00       /  !
+  data      albmax  /0.99       /  ! Albedo max
+
+  ! +-- wavelength limits [m] for each broad band
+
+  data      l1min/400.0e-9/,l1max/800.0e-9/
+  data      l2min/800.0e-9/,l2max/1500.0e-9/
+  data      l3min/1500.0e-9/,l3max/2800.0e-9/
+
+  data      l6min/185.0e-9,250.0e-9,400.0e-9, &
+        690.0e-9,1190.0e-9,2380.0e-9/
+  data      l6max/250.0e-9,400.0e-9, &
+        690.0e-9,1190.0e-9,2380.0e-9,4000.0e-9/
+
+
+  ! +--Snow Grain optical Size
+  ! +  =======================
+
+    DO ikl=1,knonv
+     DO   isn=1,max(1,isnoSV(ikl))
+
+      G2snSV(ikl,isn) =  max(epsi,G2snSV(ikl,isn))
+  ! +...    Avoid non physical Values
+
+      SignG1          = sign(unun,G1snSV(ikl,isn))
+      Sph_OK          =  max(zero,SignG1)
+
+      SnOpSV(ikl,isn) =   1.e-4 * &
+  ! +...    SI:           (from 1/10 mm to m)
+
+
+  ! +--Contribution of Non Dendritic Snow
+  ! +  ----------------------------------
+
+            (    Sph_OK *(      G2snSV(ikl,isn)*G1snSV(ikl,isn)/G1_dSV &
+            +max(demi*G2snSV(ikl,isn),DFcdSV) &
+            *(unun-G1snSV(ikl,isn)                /G1_dSV)) &
+
+
+  ! +--Contribution of     Dendritic Snow
+  ! +  ----------------------------------
+
+            +(1.-Sph_OK)*(     -G1snSV(ikl,isn)*DDcdSV         /G1_dSV &
+            +(unun+G1snSV(ikl,isn)                /G1_dSV) &
+            *    (G2snSV(ikl,isn)*DScdSV         /G1_dSV &
+            +(unun-G2snSV(ikl,isn)                /G1_dSV) &
+            *DFcdSV                 )))
+      SnOpSV(ikl,isn) =  max(zero,SnOpSV(ikl,isn))
+
+  ! + --For outputs (Etienne)
+  ! + ------------------------
+      DOPsnSV(ikl,isn)=SnOpSV(ikl,isn)
+    END DO
+  END DO
+
+
+
+
+  ! +--Snow/Ice Albedo
+  ! +  ===============
+
+
+
+  ! +--Uppermost effective Snow Layer
+  ! +  ------------------------------
+
+    DO ikl=1,knonv
+
+      isn   =  max(iun,isnoSV(ikl))
+
+      SignRo = sign(unun, rocdSV - ro__SV(ikl,isn))
+      SnowOK =  max(zero,SignRo) ! Ice Density Threshold
+
+      OpSqrt = sqrt(SnOpSV(ikl,isn))
+
+  !CA    +--Correction of snow albedo for Antarctica/Greenland
+  !CA       --------------------------------------------------
+
+
+      albCor = correc_alb
+  ! #GL     albCor = 1.01
+  ! #AC    albCor = 1.01
+
+
+      IF (iflag_albcalc >= 1) THEN  ! Albedo calculation according to Kokhanovsky and Zege 2004
+
+      dalbed = 0.0
+      doptic=SnOpSV(ikl,isn)
+      csza=coszSV(ikl)
+
+      CALL albedo_kokhanovsky(l1min,l1max,csza,doptic,albSn1)
+      CALL albedo_kokhanovsky(l2min,l2max,csza,doptic,albSn2)
+      CALL albedo_kokhanovsky(l3min,l3max,csza,doptic,albSn3)
+
+      DO i=1,6
+         lmintmp=l6min(i)
+         lmaxtmp=l6max(i)
+         CALL albedo_kokhanovsky(lmintmp,lmaxtmp,csza,doptic,albtmp)
+         albSn6(i)=albtmp
+      ENDDO
+
+
+      ELSE ! Default calculation in SISVAT
+
+  !    Zenith Angle Correction (Segal et al.,         1991, JAS 48, p.1025)
+  !--------------------------- (Wiscombe & Warren, dec1980, JAS   , p.2723)
+  !                            (Warren,               1982,  RG   , p.  81)
+                         ! -------------------------------------------------
+
+      dalbed = 0.0
+
+      csegal = max(czemax                   ,coszSV(ikl))
+  ! #cz     dalbeS =   ((bsegal+unun)/(unun+2.0*bsegal*csegal)
+  ! #cz.                -       unun                          )*0.32
+  ! #cz.              /  bsegal
+  ! #cz     dalbeS = max(dalbeS,zero)
+  ! #cz     dalbed =     dalbeS      *       min(1,isnoSV(ikl))
+
+      dalbeW =(0.64 - csegal  )*0.0625  ! Warren 1982, RevGeo, fig.12b
+                                        ! ! 0.0625 = 5% * 1/0.8,   p.81
+                                        ! ! 0.64   = cos(50)
+      dalbed =     dalbeW      *       min(1,isnoSV(ikl))
+  !-------------------------------------------------------------------------
+
+      albSn1 =  0.96-1.580*OpSqrt
+      albSn1 =  max(albSn1,AlbMin)
+
+      albSn1 =  max(albSn1,zero)
+      albSn1 =  min(albSn1*albCor,unun)
+
+      albSn2 =  0.95-15.40*OpSqrt
+      albSn2 =  max(albSn2,zero)
+      albSn2 =  min(albSn2*albCor,unun)
+
+      doptic =  min(SnOpSV(ikl,isn),doptmx)
+      albSn3 =  346.3*doptic -32.31*OpSqrt +0.88
+      albSn3 =  max(albSn3,zero)
+      albSn3 =  min(albSn3*albCor,unun)
+
+      albSn6(1:3)=albSn1
+      albSn6(4:6)=albSn2
+
+      ! !snow albedo corection if wetsnow
+  ! #GL     albSn1 =  albSn1*max(0.9,(1.-1.5*eta_SV(ikl,isn)))
+  ! #GL     albSn2 =  albSn2*max(0.9,(1.-1.5*eta_SV(ikl,isn)))
+  ! #GL     albSn3 =  albSn3*max(0.9,(1.-1.5*eta_SV(ikl,isn)))
+
+      ENDIF
+
+
+      albSno =  So1dSV*albSn1 &
+            +  So2dSV*albSn2 &
+            +  So3dSV*albSn3
+
+  !XF
+      minalb =  (aI2dSV + (aI3dSV -aI2dSV) &
+            *  (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice))
+      minalb =  min(aI3dSV,max(aI2dSV,minalb)) ! pure/firn albedo
+
+      SnowOK =  SnowOK*max(zero,sign(unun,     albSno-minalb))
+      albSn1 =  SnowOK*albSn1+(1.0-SnowOK)*max(albSno,minalb)
+      albSn2 =  SnowOK*albSn2+(1.0-SnowOK)*max(albSno,minalb)
+      albSn3 =  SnowOK*albSn3+(1.0-SnowOK)*max(albSno,minalb)
+      albSn6(:) =  SnowOK*albSn6(:)+(1.0-SnowOK)*max(albSno,minalb)
+
+
+  ! +           ro < roSdSV |          min al > aI3dSV
+  ! +  roSdSV < ro < rocdSV | aI2dSV < min al < aI3dSV (fct of density)
+
+
+  ! +--Snow/Ice Pack Thickness
+  ! +  -----------------------
+
+      isn    =    max(min(isnoSV(ikl) ,ispiSV(ikl)),0)
+      Snow_H =  zzsnsv(ikl,isnoSV(ikl))-zzsnsv(ikl,isn)
+      SIce_H =  zzsnsv(ikl,isnoSV(ikl))
+      SnownH =  Snow_H  /  HSnoSV
+      SnownH =  min(unun,  SnownH)
+      SIcenH =  SIce_H  / (HIceSV)
+      SIcenH =  min(unun,  SIcenH)
+
+  ! +       The value of SnownH is set to 1 in case of ice lenses above
+  ! +       1m of dry snow (ro<600kg/m3) for using CROCUS albedo
+
+      ! ro_ave =  0.
+      ! dz_ave =  0.
+      ! SnowOK =  1.
+   ! do isn    =  isnoSV(ikl),1,-1
+   !    ro_ave =  ro_ave + ro__SV(ikl,isn) * dzsnSV(ikl,isn) * SnowOK
+   !    dz_ave =  dz_ave +                   dzsnSV(ikl,isn) * SnowOK
+   !    SnowOK =  max(zero,sign(unun,1.-dz_ave))
+   ! enddo
+
+   !    ro_ave =  ro_ave / max(dz_ave,epsi)
+   !    SnowOK =  max(zero,sign(unun,600.-ro_ave))
+   !    SnownH =  SnowOK + SnownH * (1. - SnowOK)
+
+  ! +--Integrated Snow/Ice Albedo: Case of Water on Bare Ice
+  ! +  -----------------------------------------------------
+
+      isn    =  max(min(isnoSV(ikl) ,ispiSV(ikl)),0)
+
+      albWIc =  aI1dSV-(aI1dSV-aI2dSV) &
+            *  exp(-(rusnSV(ikl) & !
+            *  (1. -SWS_SV(ikl) & ! 0 <=> freezing
+            *  (1  -min(1,iabs(isn-isnoSV(ikl))))) & ! 1 <=> isn=isnoSV
+            /   ru_dSV)**0.50)                        !
+      ! albWIc = max(aI1dSV,min(aI2dSV,albWIc+slopSV(ikl)*
+  !    .             min(5.,max(1.,dx/10000.))))
+
+      SignRo = sign(unun,ro_Ice-5.-ro__SV(ikl,isn))    ! RoSN<920kg/m3
+      SnowOK =  max(zero,SignRo)
+
+      albWIc = (1. - SnowOK) * albWIc + SnowOK &
+            * (aI2dSV + (aI3dSV -aI2dSV) &
+            * (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice))
+
+  ! +  rocdSV < ro < ro_ice | aI2dSV< al <aI3dSV (fct of density)
+  ! +           ro > ro_ice | aI1dSV< al <aI2dSV (fct of superficial water content
+
+
+  ! +--Integrated Snow/Ice      Albedo
+  ! +  -------------------------------
+
+      a_SII1      =     albWIc      +(albSn1-albWIc)     *SnownH
+      a_SII1      = min(a_SII1       ,albSn1)
+
+      a_SII2      =     albWIc      +(albSn2-albWIc)     *SnownH
+      a_SII2      = min(a_SII2       ,albSn2)
+
+      a_SII3      =     albWIc      +(albSn3-albWIc)     *SnownH
+      a_SII3      = min(a_SII3       ,albSn3)
+
+      DO i=1,6
+      a_SII6(i)   = albWIc      +(albSn6(i)-albWIc)     *SnownH
+      a_SII6(i)   = min(a_SII6(i)       ,albSn6(i))
+      ENDDO
+
+  !c #AG     agesno =      min(agsnSV(ikl,isn)          ,AgeMax)
+  !c #AG     a_SII1      =     a_SII1      -0.175*agesno/AgeMax
+  ! +...                                   Impurities: Col de Porte Parameter.
+
+
+
+  ! +--Elsewhere    Integrated Snow/Ice Albedo
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ! #cp     ELSE
+        albSII =     So1dSV*a_SII1 &
+              + So2dSV*a_SII2 &
+              + So3dSV*a_SII3
+  ! #cp     END IF
+
+
+  ! +--Integrated Snow/Ice/Soil Albedo
+  ! +  -------------------------------
+
+        alb1sv(ikl) =     albssv(ikl) +(a_SII1-albssv(ikl))*SIcenH
+        alb1sv(ikl) = min(alb1sv(ikl)  ,a_SII1)
+
+        alb2sv(ikl) =     albssv(ikl) +(a_SII2-albssv(ikl))*SIcenH
+        alb2sv(ikl) = min(alb2sv(ikl)  ,a_SII2)
+
+        alb3sv(ikl) =     albssv(ikl) +(a_SII3-albssv(ikl))*SIcenH
+        alb3sv(ikl) = min(alb3sv(ikl)  ,a_SII3)
+
+        albisv(ikl) =     albssv(ikl) +(albSII-albssv(ikl))*SIcenH
+        albisv(ikl) = min(albisv(ikl)  ,albSII)
+
+        DO i=1,6
+        alb6sv(ikl,i) = albssv(ikl) +(a_SII6(i)-albssv(ikl))*SIcenH
+        alb6sv(ikl,i) = min(alb6sv(ikl,i)  ,a_SII6(i))
+        ENDDO
+
+
+  ! +--Integrated Snow/Ice/Soil Albedo: Clouds Correction! Greuell & all., 1994
+  ! +  --------------------------------------------------! Glob.&t Planet.Change
+                                                   ! ! (9):91-114
+        alb1sv(ikl) = alb1sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH &
+              + dalbed      *    (1.-cld_SV(ikl))
+        alb2sv(ikl) = alb2sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH &
+              + dalbed      *    (1.-cld_SV(ikl))
+        alb3sv(ikl) = alb3sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH &
+              + dalbed      *    (1.-cld_SV(ikl))
+        alb6sv(ikl,:) =alb6sv(ikl,:)+0.05 *(cld_SV(ikl)-0.5)*SIcenH &
+              + dalbed      *    (1.-cld_SV(ikl))
+        albisv(ikl) = albisv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH &
+              + dalbed      *    (1.-cld_SV(ikl))
+
+  ! +--Integrated Snow/Ice/Soil Albedo: Minimum snow albedo = aI1dSV
+  ! +  -------------------------------------------------------------
+
+        albedo_old  = albisv(ikl)
+        albisv(ikl) = max(albisv(ikl),aI1dSV   * SIcenH &
+              + albssv(ikl) *(1.0        - SIcenH))
+        alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0 & ! 33 %
+              * (albedo_old-albisv(ikl)) / So1dSV
+        alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0 & ! 33 %
+              * (albedo_old-albisv(ikl)) / So2dSV
+        alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0 & ! 33 %
+              * (albedo_old-albisv(ikl)) / So3dSV
+        alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0 & ! 16 %
+              * (albedo_old-albisv(ikl)) / (So1dSV/3)
+        alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0 & ! 16 %
+              * (albedo_old-albisv(ikl)) / (So2dSV/3)
+
+
+  ! +--Integrated Snow/Ice/Soil Albedo: Maximum albedo = 95%
+  ! +  -----------------------------------------------------
+
+        albedo_old  = albisv(ikl)
+        albisv(ikl) = min(albisv(ikl),0.95)
+        alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0 & ! 33 %
+              * (albedo_old-albisv(ikl)) / So1dSV
+        alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0 & ! 33 %
+              * (albedo_old-albisv(ikl)) / So2dSV
+        alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0 & ! 33 %
+              * (albedo_old-albisv(ikl)) / So3dSV
+        alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0 & ! 16 %
+              * (albedo_old-albisv(ikl)) / (So1dSV/3)
+        alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0 & ! 16 %
+              * (albedo_old-albisv(ikl)) / (So2dSV/3)
+
+
+    !Sea Ice/snow permanent-interractive prescription from Nemo
+    !AO_CK 20/02/2020
+
+    ! ! No check if coupling update since MAR and NEMO albedo are too different
+    ! and since MAR albedo is computed on properties that are not in NEMO
+    ! ! prescription for each time step with NEMO values
+
+  ! #AO      if (LSmask(ikl) .eq. 0 .and. coupling_ao .eq. .TRUE.) then
+  ! #AO       if (AOmask(ikl) .eq. 0) then
+  ! #AO       albisv(ikl) =  (1.-AOmask(ikl))* albAOsisv(ikl)
+  ! #AO.                    +(AOmask(ikl)*albisv(ikl))
+  ! #AO       alb1sv(ikl) =   (1.-AOmask(ikl))* albAOsisv(ikl)
+  ! #AO.                    +(AOmask(ikl)*alb1sv(ikl))
+  ! #AO       alb2sv(ikl) =   (1.-AOmask(ikl))* albAOsisv(ikl)
+  ! #AO.                    +(AOmask(ikl)*alb2sv(ikl))
+  ! #AO       alb3sv(ikl) =   (1.-AOmask(ikl))* albAOsisv(ikl)
+  ! #AO.                    +(AOmask(ikl)*alb3sv(ikl))
+  ! #AO       endif
+  ! #AO      endif
+
+
+        alb1sv(ikl) = min(max(zero,alb1sv(ikl)),albmax)
+        alb2sv(ikl) = min(max(zero,alb2sv(ikl)),albmax)
+        alb3sv(ikl) = min(max(zero,alb3sv(ikl)),albmax)
+
+        DO i=1,6
+            alb6sv(ikl,i) = min(max(zero,alb6sv(ikl,i)),albmax)
+        ENDDO
+    END DO
+
+
+  ! +--Extinction Coefficient: Exponential Factor
+  ! +  ==========================================
+
+    DO ikl=1,knonv
+      sExt_1(ikl)        = 1.
+      sExt_2(ikl)        = 1.
+      sExt_3(ikl)        = 1.
+      sEX_sv(ikl,nsno+1) = 1.
+
+      coalb1(ikl) = (1.          -alb1sv(ikl))*So1dSV
+      coalb2(ikl) = (1.          -alb2sv(ikl))*So2dSV
+      coalb3(ikl) = (1.          -alb3sv(ikl))*So3dSV
+      coalbm      =  coalb1(ikl) +coalb2(ikl) +coalb3(ikl)
+      coalb1(ikl) =  coalb1(ikl)              /coalbm
+      coalb2(ikl) =  coalb2(ikl)              /coalbm
+      coalb3(ikl) =  coalb3(ikl)              /coalbm
+    END DO
+
+  !XF
+
+    DO   isn=nsno,1,-1
+      DO ikl=1,knonv
+        sEX_sv(ikl,isn) = 1.0
+       ! !sEX_sv(ikl,isn) = 0.95 ! if MAR is too warm in summer
+      END DO
+    END DO
+
+    DO ikl=1,knonv
+     DO isn=max(1,isnoSV(ikl)),1,-1
+
+      SignRo = sign(unun, rocdSV - ro__SV(ikl,isn))
+      SnowOK =  max(zero,SignRo) ! Ice Density Threshold
+
+      RoFrez =  1.e-3      * ro__SV(ikl,isn) * (1.0-eta_SV(ikl,isn))
+
+      OpSqrt = sqrt(max(epsi,SnOpSV(ikl,isn)))
+      exarg1 =      SnowOK  *1.e2 *max(sbeta1*RoFrez/OpSqrt,sbeta2) &
+            +(1.0-SnowOK)           *sbeta5
+      exarg2 =      SnowOK  *1.e2 *max(sbeta3*RoFrez/OpSqrt,sbeta4) &
+            +(1.0-SnowOK)           *sbeta5
+      exarg3 =      SnowOK  *1.e2     *sbeta5 &
+            +(1.0-SnowOK)           *sbeta5
+
+
+  ! +--Integrated Extinction of Solar Irradiance (Normalized Value)
+  ! +  ============================================================
+
+      sExt_1(ikl) = sExt_1(ikl) &
+            * exp(min(0.0,-exarg1 *dzsnSV(ikl,isn)))
+      sign_0      =              sign(unun,eps9   -sExt_1(ikl))
+      sExt_0      =               max(zero,sign_0)*sExt_1(ikl)
+      sExt_1(ikl) = sExt_1(ikl)                   -sExt_0
+
+      sExt_2(ikl) = sExt_2(ikl) &
+            * exp(min(0.0,-exarg2 *dzsnSV(ikl,isn)))
+      sign_0      =              sign(unun,eps9   -sExt_2(ikl))
+      sExt_0      =               max(zero,sign_0)*sExt_2(ikl)
+      sExt_2(ikl) = sExt_2(ikl)                   -sExt_0
+
+      sExt_3(ikl) = sExt_3(ikl) &
+            * exp(min(0.0,-exarg3 *dzsnSV(ikl,isn)))
+      sign_0      =              sign(unun,eps9   -sExt_3(ikl))
+      sExt_0      =               max(zero,sign_0)*sExt_3(ikl)
+      sExt_3(ikl) = sExt_3(ikl)                   -sExt_0
+
+      sEX_sv(ikl,isn) = coalb1(ikl) * sExt_1(ikl) &
+            + coalb2(ikl) * sExt_2(ikl) &
+            + coalb3(ikl) * sExt_3(ikl)
+    END DO
+  END DO
+
+  DO   isn=0,-nsol,-1
+    DO ikl=1,knonv
+      sEX_sv(ikl,isn) = 0.0
+    END DO
+  END DO
+
+
+
+
+
+end subroutine snoptp
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE albedo_kokhanovsky(lambdamin,lambdamax, &
+        cossza,dopt,albint)
+  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! Authors: Hajar El Habchi El Fenniri, Etienne Vignon, Cecile Agosta
+       ! Ghislain Picard
+  ! Routine that calculates the  integrated snow spectral albedo between
+  ! lambdamin and lambdamax following Kokhanisky and Zege 2004,
+  ! Scattering optics of snow, Applied Optics, Vol 43, No7
+  ! Code inspired from the snowoptics package of Ghislain Picard:
+  ! https://github.com/ghislainp/snowoptics
+  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+  USE VARphy
+
+  IMPLICIT NONE
+
+  ! Inputs
+  !--------
+  REAL :: lambdamin   ! minimum wavelength for integration [m]
+  REAL :: lambdamax   ! maximum wavelength for integration [m]
+  REAL :: cossza     ! solar zenith angle cosinus
+  REAL :: dopt        ! optical diameter [m]
+
+  !Outputs
+  !-------
+  REAL :: albint
+
+  ! Local Variables
+  !-----------------
+
+  REAL :: ropt,cosalb,norm,Pas
+  REAL :: SSA,alpha,gamm,R,cos30,alb30
+  INTEGER :: i
+
+
+  REAL :: B_amp                       ! amplification factor
+  PARAMETER (B_amp=1.6)
+
+  REAL :: g_asy                       ! asymetry factor
+  PARAMETER (g_asy=0.845)
+
+  INTEGER :: nlambda                  ! length of wavelength vector
+  PARAMETER(nlambda=200)
+
+  REAL :: lmin
+  PARAMETER(lmin=185.0E-9)
+
+  REAL :: lmax
+  PARAMETER(lmax=4000.0E-9)
+
+  REAL :: albmax
+  PARAMETER(albmax=0.99)
+
+  REAL :: wavelengths(nlambda)
+  REAL :: ni(nlambda)
+
+  DATA wavelengths / 1.85000000e-07, 2.04170854e-07, &
+        2.23341709e-07, 2.42512563e-07, &
+        2.61683417e-07, 2.80854271e-07, 3.00025126e-07, 3.19195980e-07, &
+        3.38366834e-07, 3.57537688e-07, 3.76708543e-07, 3.95879397e-07, &
+        4.15050251e-07, 4.34221106e-07, 4.53391960e-07, 4.72562814e-07, &
+        4.91733668e-07, 5.10904523e-07, 5.30075377e-07, 5.49246231e-07, &
+        5.68417085e-07, 5.87587940e-07, 6.06758794e-07, 6.25929648e-07, &
+        6.45100503e-07, 6.64271357e-07, 6.83442211e-07, 7.02613065e-07, &
+        7.21783920e-07, 7.40954774e-07, 7.60125628e-07, 7.79296482e-07, &
+        7.98467337e-07, 8.17638191e-07, 8.36809045e-07, 8.55979899e-07, &
+        8.75150754e-07, 8.94321608e-07, 9.13492462e-07, 9.32663317e-07, &
+        9.51834171e-07, 9.71005025e-07, 9.90175879e-07, 1.00934673e-06, &
+        1.02851759e-06, 1.04768844e-06, 1.06685930e-06, 1.08603015e-06, &
+        1.10520101e-06, 1.12437186e-06, 1.14354271e-06, 1.16271357e-06, &
+        1.18188442e-06, 1.20105528e-06, 1.22022613e-06, 1.23939698e-06, &
+        1.25856784e-06, 1.27773869e-06, 1.29690955e-06, 1.31608040e-06, &
+        1.33525126e-06, 1.35442211e-06, 1.37359296e-06, 1.39276382e-06, &
+        1.41193467e-06, 1.43110553e-06, 1.45027638e-06, 1.46944724e-06, &
+        1.48861809e-06, 1.50778894e-06, 1.52695980e-06, 1.54613065e-06, &
+        1.56530151e-06, 1.58447236e-06, 1.60364322e-06, 1.62281407e-06, &
+        1.64198492e-06, 1.66115578e-06, 1.68032663e-06, 1.69949749e-06, &
+        1.71866834e-06, 1.73783920e-06, 1.75701005e-06, 1.77618090e-06, &
+        1.79535176e-06, 1.81452261e-06, 1.83369347e-06, 1.85286432e-06, &
+        1.87203518e-06, 1.89120603e-06, 1.91037688e-06, 1.92954774e-06, &
+        1.94871859e-06, 1.96788945e-06, 1.98706030e-06, 2.00623116e-06, &
+        2.02540201e-06, 2.04457286e-06, 2.06374372e-06, 2.08291457e-06, &
+        2.10208543e-06, 2.12125628e-06, 2.14042714e-06, 2.15959799e-06, &
+        2.17876884e-06, 2.19793970e-06, 2.21711055e-06, 2.23628141e-06, &
+        2.25545226e-06, 2.27462312e-06, 2.29379397e-06, 2.31296482e-06, &
+        2.33213568e-06, 2.35130653e-06, 2.37047739e-06, 2.38964824e-06, &
+        2.40881910e-06, 2.42798995e-06, 2.44716080e-06, 2.46633166e-06, &
+        2.48550251e-06, 2.50467337e-06, 2.52384422e-06, 2.54301508e-06, &
+        2.56218593e-06, 2.58135678e-06, 2.60052764e-06, 2.61969849e-06, &
+        2.63886935e-06, 2.65804020e-06, 2.67721106e-06, 2.69638191e-06, &
+        2.71555276e-06, 2.73472362e-06, 2.75389447e-06, 2.77306533e-06, &
+        2.79223618e-06, 2.81140704e-06, 2.83057789e-06, 2.84974874e-06, &
+        2.86891960e-06, 2.88809045e-06, 2.90726131e-06, 2.92643216e-06, &
+        2.94560302e-06, 2.96477387e-06, 2.98394472e-06, 3.00311558e-06, &
+        3.02228643e-06, 3.04145729e-06, 3.06062814e-06, 3.07979899e-06, &
+        3.09896985e-06, 3.11814070e-06, 3.13731156e-06, 3.15648241e-06, &
+        3.17565327e-06, 3.19482412e-06, 3.21399497e-06, 3.23316583e-06, &
+        3.25233668e-06, 3.27150754e-06, 3.29067839e-06, 3.30984925e-06, &
+        3.32902010e-06, 3.34819095e-06, 3.36736181e-06, 3.38653266e-06, &
+        3.40570352e-06, 3.42487437e-06, 3.44404523e-06, 3.46321608e-06, &
+        3.48238693e-06, 3.50155779e-06, 3.52072864e-06, 3.53989950e-06, &
+        3.55907035e-06, 3.57824121e-06, 3.59741206e-06, 3.61658291e-06, &
+        3.63575377e-06, 3.65492462e-06, 3.67409548e-06, 3.69326633e-06, &
+        3.71243719e-06, 3.73160804e-06, 3.75077889e-06, 3.76994975e-06, &
+        3.78912060e-06, 3.80829146e-06, 3.82746231e-06, 3.84663317e-06, &
+        3.86580402e-06, 3.88497487e-06, 3.90414573e-06, 3.92331658e-06, &
+        3.94248744e-06, 3.96165829e-06, 3.98082915e-06, 4.00000000e-06/
+
+
+  DATA ni /7.74508407e-10, 7.74508407e-10, &
+        7.74508407e-10, 7.74508407e-10, &
+        7.74508407e-10, 7.74508407e-10, 7.74508407e-10, 7.74508407e-10, &
+        6.98381122e-10, 6.23170274e-10, 5.97655992e-10, 5.84106004e-10, &
+        5.44327597e-10, 5.71923510e-10, 6.59723827e-10, 8.05183870e-10, &
+        1.03110161e-09, 1.36680386e-09, 1.85161253e-09, 2.56487751e-09, &
+        3.56462855e-09, 4.89450926e-09, 6.49252022e-09, 9.62029335e-09, &
+        1.32335015e-08, 1.75502184e-08, 2.19240625e-08, 3.03304156e-08, &
+        4.07715972e-08, 5.00414911e-08, 7.09722331e-08, 1.00773751e-07, &
+        1.31427409e-07, 1.42289041e-07, 1.49066787e-07, 2.01558515e-07, &
+        2.99106105e-07, 4.03902086e-07, 4.54292169e-07, 5.21906983e-07, &
+        6.27643362e-07, 9.43955678e-07, 1.33464494e-06, 1.97278315e-06, &
+        2.31801329e-06, 2.20584676e-06, 1.85568138e-06, 1.73395193e-06, &
+        1.73101406e-06, 1.91333936e-06, 2.26413019e-06, 3.23959718e-06, &
+        4.94316963e-06, 6.89378896e-06, 1.02237444e-05, 1.21439656e-05, &
+        1.31567585e-05, 1.33448288e-05, 1.32000000e-05, 1.31608040e-05, &
+        1.33048369e-05, 1.40321464e-05, 1.51526244e-05, 1.80342858e-05, &
+        3.82875736e-05, 1.07325259e-04, 2.11961637e-04, 3.82008054e-04, &
+        5.30897470e-04, 5.29244735e-04, 4.90876605e-04, 4.33905427e-04, &
+        3.77795349e-04, 3.17633099e-04, 2.81078564e-04, 2.57579485e-04, &
+        2.42203100e-04, 2.23789060e-04, 2.04306870e-04, 1.87909255e-04, &
+        1.73117146e-04, 1.61533186e-04, 1.53420328e-04, 1.47578033e-04, &
+        1.42334776e-04, 1.35691466e-04, 1.30495414e-04, 1.36065123e-04, &
+        1.70928821e-04, 2.66389730e-04, 4.80957955e-04, 8.25041961e-04, &
+        1.21654792e-03, 1.50232875e-03, 1.62316078e-03, 1.61649750e-03, &
+        1.53736801e-03, 1.42343711e-03, 1.24459117e-03, 1.02388611e-03, &
+        7.89112523e-04, 5.97204264e-04, 4.57152413e-04, 3.62341259e-04, &
+        2.99128332e-04, 2.57035569e-04, 2.26992203e-04, 2.07110355e-04, &
+        2.05835688e-04, 2.25108810e-04, 2.64262893e-04, 3.23594011e-04, &
+        3.93061117e-04, 4.62789970e-04, 5.19664416e-04, 5.59739628e-04, &
+        5.93476084e-04, 6.22797885e-04, 6.57484833e-04, 6.92849600e-04, &
+        7.26584901e-04, 7.56604648e-04, 7.68009488e-04, 7.65579073e-04, &
+        7.50526164e-04, 7.39809972e-04, 7.55622847e-04, 8.05099514e-04, &
+        9.67279246e-04, 1.16281559e-03, 1.42570247e-03, 2.04986585e-03, &
+        2.93971170e-03, 4.49827711e-03, 7.32537532e-03, 1.18889734e-02, &
+        1.85851805e-02, 2.86242532e-02, 4.34131035e-02, 6.37828307e-02, &
+        9.24145850e-02, 1.35547945e-01, 1.94143245e-01, 2.54542814e-01, &
+        3.02282024e-01, 3.42214181e-01, 3.85475065e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, &
+        4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01/
+
+
+  Pas     =(lmax-lmin)/nlambda
+  ropt    = dopt/2.0
+  SSA     = 3.0/(rhoIce*ropt)
+  cos30   = cos(30.0/180.0*pi)
+
+
+  albint=0.
+  norm=0.
+
+  DO i = 1,nlambda
+      gamm = 4.0 * pi * ni(i) / wavelengths(i)
+      cosalb = 2.0 / (SSA * rhoice) * B_amp * gamm
+      alpha = 16. / 3 * cosalb / (1.0 - g_asy)
+      R = exp(-(alpha**0.5) * 3.0 / 7.0 * (1.0 + 2.0 * cossza))
+      alb30 = exp(-(alpha**0.5)* 3.0 / 7.0 * (1.0 + 20 * cos30))
+
+      IF ((wavelengths(i)>=lambdamin).AND. &
+            (wavelengths(i)<lambdamax)) THEN
+      albint=albint+R*Pas  ! rectangle integration -> can be improved with trapezintegration
+      norm=norm+Pas
+      ENDIF
+
+  END DO
+
+  albint=max(0.,min(albint/max(norm,1E-10),albmax))
+
+END SUBROUTINE albedo_kokhanovsky
+
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_ts2.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_ts2.F	(revision 5104)
+++ 	(revision )
@@ -1,477 +1,0 @@
-      SUBROUTINE SISVAT_TS2
-c #ES.                     (ETSo_0,ETSo_1,ETSo_d)                               
-                                                                                
-C +------------------------------------------------------------------------+    
-C | MAR          SISVAT_TS2                            Mon 16-08-2009  MAR |    
-C |   SubRoutine SISVAT_TS2 computes the Soil/Snow temperature and fluxes  |
-C |   using the same method as in LMDZ for consistency.                    |
-C |   The corresponding LMDZ routines are soil (soil.F90) and calcul_fluxs |
-C |   (calcul_fluxs_mod.F90).                                              |   
-C +------------------------------------------------------------------------+    
-C |                                                                        |    
-C |                                                                        |    
-C |   PARAMETERS:  klonv: Total Number of columns =                        |    
-C |   ^^^^^^^^^^        = Total Number of grid boxes of surface type       |    
-C |                       (land ice for now)                               |    
-C |                                                                        |    
-C |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |    
-C |   ^^^^^    sol_SV   : Downward Solar Radiation                  [W/m2] |    
-C |            IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |       
-C |            VV__SV   : SBL Top    Wind Speed                      [m/s] |    
-C |            TaT_SV   : SBL Top    Temperature                       [K] |     
-C |            QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |      
-C |            dzsnSV   : Snow Layer Thickness                         [m] |        
-C |            dt__SV   : Time Step                                    [s] |    
-C |                                                                        |    
-C |            SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |    
-C |            Eso_sv   : Soil+Snow       Emissivity                   [-] |    
-C |   ?        rah_sv   : Aerodynamic Resistance for Heat            [s/m] |    
-C |                                                                        | 
-C |            dz1_SV    : "inverse" layer thickness (centered)      [1/m] |
-C |            dz2_SV    : layer thickness (layer above (?))           [m] |
-C |            AcoHSV    : coefficient for Enthalpy evolution, from atm.   |
-C |            AcoHSV    : coefficient for Enthalpy evolution, from atm.   |
-C |            AcoQSV    : coefficient for Humidity evolution, from atm.   | 
-C |            BcoQSV    : coefficient for Humidity evolution, from atm.   |
-C |            ps__SV    : surface pressure                           [Pa] |
-C |            p1l_SV    : 1st atmospheric layer pressure             [Pa] |     
-C |            cdH_SV    : drag coeff Energy (?)                           |
-C |            rsolSV    : Radiation balance surface                [W/m2] |
-C |            lambSV    : Coefficient for soil layer geometry         [-] |
-C |                                                                        |    
-C |   INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|    
-C |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |    
-C |   ^^^^^^   rsolSV   : Radiation balance surface                 [W/m2] |     
-C |                                                                        |    
-C |   OUTPUT:  IRs_SV   : Soil      IR Radiation                    [W/m2] |    
-C |   ^^^^^^   HSs_sv   : Sensible  Heat Flux                       [W/m2] |    
-C |            HLs_sv   : Latent    Heat Flux                       [W/m2] |  
-C |            TsfnSV   : new surface temperature                      [K] |
-C |            Evp_sv   : Evaporation                              [kg/m2] |
-C |            dSdTSV   : Sensible Heat Flux temp. derivative     [W/m2/K] |
-C |            dLdTSV   : Latent Heat Flux temp. derivative       [W/m2/K] |
-C |                                                                        | 
-C |   ?        ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |    
-C |   ?        ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |    
-C |   ?        ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |    
-C |                                                                        | 
-C |________________________________________________________________________|
-
-      USE VAR_SV
-      USE VARdSV
- 
-      USE VARySV                      
-      USE VARtSV                      
-      USE VARxSV 
-      USE VARphy
-      USE indice_sol_mod
-
-
-      IMPLICIT NONE                                                                    
-                                                                                
-                                                                                
-C +--Global Variables                                                           
-C +  ================                                                          
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-!      INCLUDE "indicesol.h"
-      INCLUDE "comsoil.h"
-!      include  "LMDZphy.inc"   
-                                                                        
-C +--OUTPUT for Stand Alone NetCDF File                                         
-C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~                                         
-c #NC      real*8        SOsoKL(klonv)             ! Absorbed Solar Radiation        
-c #NC      real*8        IRsoKL(klonv)             ! Absorbed IR    Radiation        
-c #NC      real*8        HSsoKL(klonv)             ! Absorbed Sensible Heat Flux     
-c #NC      real*8        HLsoKL(klonv)             ! Absorbed Latent   Heat Flux     
-c #NC      real*8        HLs_KL(klonv)             ! Evaporation                     
-c #NC      real*8        HLv_KL(klonv)             ! Transpiration                   
-c #NC      common/DumpNC/SOsoKL,IRsoKL                                               
-c #NC     .             ,HSsoKL,HLsoKL                                               
-c #NC     .             ,HLs_KL,HLv_KL          
-
-C +--Internal Variables                                                         
-C +  ==================    
-
-      integer ig,jk,isl
-      real mu     
-      real Tsrf(klonv)               ! surface temperature as extrapolated from soil
-      real mug(klonv)                 !hj coef top layers 
-      real ztherm_i(klonv),zdz2(klonv,-nsol:nsno),z1s
-      real pfluxgrd(klonv), pcapcal(klonv), cal(klonv)
-      real beta(klonv), dif_grnd(klonv)
-      real C_coef(klonv,-nsol:nsno),D_coef(klonv,-nsol:nsno)
-
-      REAL, DIMENSION(klonv)   :: zx_mh, zx_nh, zx_oh
-      REAL, DIMENSION(klonv)   :: zx_mq, zx_nq, zx_oq
-      REAL, DIMENSION(klonv)   :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
-      REAL, DIMENSION(klonv)   :: zx_sl, zx_k1
-      REAL, DIMENSION(klonv)   :: d_ts
-      REAL                     :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
-      REAL                     :: qsat_new, q1_new
-C      REAL, PARAMETER          :: t_grnd = 271.35, t_coup = 273.15
-C      REAL, PARAMETER          :: max_eau_sol = 150.0
-      REAL, DIMENSION(klonv)   :: IRs__D, dIRsdT
-
-
-      REAL t_grnd                      ! not used
-      parameter(t_grnd = 271.35)       !
-      REAL t_coup                      ! distinguish evap/sublimation
-      parameter(t_coup = 273.15)       !
-      REAL max_eau_sol
-      parameter(max_eau_sol = 150.0)
-
-
-!        write(*,*)'T check'
-
-!        DO  ig = 1,knonv  
-!            DO  jk = 1,isnoSV(ig) !nsno       
-!              IF (TsisSV(ig,jk) <= 1.) THEN          !hj check
-!                TsisSV(ig,jk) = TsisSV(ig,isnoSV(ig))
-!              ENDIF  
-
-!              IF (TsisSV(ig,jk) <= 1.) THEN          !hj check
-!                TsisSV(ig,jk) = 273.15
-!              ENDIF   
-!            END DO
-!        END DO     
-
-C!=======================================================================
-C! I. First part: corresponds to soil.F90 in LMDZ
-C!=======================================================================
-
-      DO ig = 1,knonv      
-        DO jk =1,isnoSV(ig)
-          dz2_SV(ig,jk)=dzsnSV(ig,jk)
-C! use arithmetic center between layers to derive dz1 for snow layers for simplicity: 
-          dz1_SV(ig,jk)=2./(dzsnSV(ig,jk)+dzsnSV(ig,jk-1)) 
-        ENDDO
-      ENDDO
-
-      DO ig = 1,knonv
-        ztherm_i(ig)   = inertie_lic
-        IF (isnoSV(ig) > 0) ztherm_i(ig)   = inertie_sno
-      ENDDO
-
-C!-----------------------------------------------------------------------
-C! 1)
-C! Calculation of Cgrf and Dgrd coefficients using soil temperature from 
-C! previous time step.
-C!
-C! These variables are recalculated on the local compressed grid instead 
-C! of saved in restart file.
-C!-----------------------------------------------------------------------
-      DO ig=1,knonv
-        DO jk=-nsol,nsno
-          zdz2(ig,jk)=dz2_SV(ig,jk)/dt__SV                                !ptimestep
-        ENDDO
-      ENDDO
- 
-      DO ig=1,knonv
-        z1s = zdz2(ig,-nsol)+dz1_SV(ig,-nsol+1)
-        C_coef(ig,-nsol+1)=zdz2(ig,-nsol)*TsisSV(ig,-nsol)/z1s
-        D_coef(ig,-nsol+1)=dz1_SV(ig,-nsol+1)/z1s
-      ENDDO
-
-      DO ig=1,knonv
-        DO jk=-nsol+1,isnoSV(ig)-1,1
-          z1s = 1./(zdz2(ig,jk)+dz1_SV(ig,jk+1)+dz1_SV(ig,jk)           &
-     &          *(1.-D_coef(ig,jk)))
-          C_coef(ig,jk+1)=                                              &
-     &          (TsisSV(ig,jk)*zdz2(ig,jk)                              &
-     &          +dz1_SV(ig,jk)*C_coef(ig,jk)) * z1s
-          D_coef(ig,jk+1)=dz1_SV(ig,jk+1)*z1s
-        ENDDO
-      ENDDO
-
-C!-----------------------------------------------------------------------
-C! 2)
-C! Computation of the soil temperatures using the Cgrd and Dgrd
-C! coefficient computed above
-C!
-C!-----------------------------------------------------------------------
-C! Extrapolate surface Temperature                   !hj check
-      mu=1./((2.**1.5-1.)/(2.**(0.5)-1.)-1.)
-
-!     IF (knonv>0) THEN 
-!      DO ig=1,8 
-!        write(*,*)ig,'sisvat: Tsis ',TsisSV(ig,isnoSV(ig))
-!        write(*,*)'max-1            ',TsisSV(ig,isnoSV(ig)-1)
-!        write(*,*)'max-2            ',TsisSV(ig,isnoSV(ig)-2)
-!        write(*,*)'0                ',TsisSV(ig,0)
-!!        write(*,*)min(max(isnoSV(ig),0),1),max(1-isnoSV(ig),0)
-!      ENDDO
-!     END IF
-
-      DO ig=1,knonv    
-        IF (isnoSV(ig)>0) THEN
-          IF (isnoSV(ig)>1) THEN
-           mug(ig)=1./(1.+dzsnSV(ig,isnoSV(ig)-1)/dzsnSV(ig,isnoSV(ig))) !mu
-          ELSE
-           mug(ig) = 1./(1.+dzsnSV(ig,isnoSV(ig)-1)/dz_dSV(0)) !mu
-          ENDIF
-        ELSE
-          mug(ig) = lambSV
-        ENDIF
-
-        IF (mug(ig)  <= 0.05) THEN
-         write(*,*)'Attention mu low', mug(ig)
-        ENDIF
-        IF (mug(ig)  >= 0.98) THEN
-         write(*,*)'Attention mu high', mug(ig)
-        ENDIF
-
-        Tsrf(ig)=(1.5*TsisSV(ig,isnoSV(ig))-0.5*TsisSV(ig,isnoSV(ig)-1))&
-     &           *min(max(isnoSV(ig),0),1)+                             &
-     &           ((mug(ig)+1)*TsisSV(ig,0)-mug(ig)*TsisSV(ig,-1))       &
-     &           *max(1-isnoSV(ig),0)  
-      ENDDO
-
-  
-
-C! Surface temperature
-      DO ig=1,knonv
-      TsisSV(ig,isnoSV(ig))=(mug(ig)*C_coef(ig,isnoSV(ig))+Tsf_SV(ig))/ &
-     &        (mug(ig)*(1.-D_coef(ig,isnoSV(ig)))+1.)
-      ENDDO
-  
-C! Other temperatures
-      DO ig=1,knonv
-        DO jk=isnoSV(ig),-nsol+1,-1
-          TsisSV(ig,jk-1)=C_coef(ig,jk)+D_coef(ig,jk)                   &
-     &          *TsisSV(ig,jk)
-        ENDDO
-      ENDDO
-C      write(*,*)ig,'Tsis',TsisSV(ig,0)
-
-C      IF (indice == is_sic) THEN
-C        DO ig = 1,knonv
-C          TsisSV(ig,-nsol) = RTT - 1.8
-C        END DO
-C      ENDIF
-
-CC      !hj new 11 03 2010
-        DO ig=1,knonv                                                          
-          isl         = isnoSV(ig)                                             
-C          dIRsdT(ig) = Eso_sv(ig)* SteBo   * 4.                        & ! - d(IR)/d(T)   
-C     &                             * Tsf_SV(ig)                         & !T TsisSV(ig,isl)           !                
-C     &                             * Tsf_SV(ig)                         & !TsisSV(ig,isl)           !                
-C     &                             * Tsf_SV(ig) !TsisSV(ig,isl)           !                
-C          IRs__D(ig) = dIRsdT(ig)* Tsf_SV(ig) * 0.75 !TsisSV(ig,isl) * 0.75    !: 
-          dIRsdT(ig) = Eso_sv(ig)* StefBo   * 4.                        & ! - d(IR)/d(T)   
-     &                             * TsisSV(ig,isl)                     & !
-     &                             * TsisSV(ig,isl)                     & !
-     &                             * TsisSV(ig,isl)                     & !
-          IRs__D(ig) = dIRsdT(ig)* TsisSV(ig,isl) * 0.75                  !: 
-         END DO
-       !hj
-C!-----------------------------------------------------------------------
-C! 3)
-C! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil 
-C! temperature
-C!-----------------------------------------------------------------------
-      DO ig=1,knonv
-        z1s = zdz2(ig,-nsol)+dz1_SV(ig,-nsol+1)
-        C_coef(ig,-nsol+1) = zdz2(ig,-nsol)*TsisSV(ig,-nsol)/z1s
-        D_coef(ig,-nsol+1) = dz1_SV(ig,-nsol+1)/z1s
-      ENDDO
-
-      DO ig=1,knonv  
-        DO jk=-nsol+1,isnoSV(ig)-1,1
-          z1s = 1./(zdz2(ig,jk)+dz1_SV(ig,jk+1)+dz1_SV(ig,jk)           &
-     &          *(1.-D_coef(ig,jk)))
-          C_coef(ig,jk+1) = (TsisSV(ig,jk)*zdz2(ig,jk)+                 &
-     &          dz1_SV(ig,jk)*C_coef(ig,jk)) * z1s
-          D_coef(ig,jk+1) = dz1_SV(ig,jk+1)*z1s
-        ENDDO
-      ENDDO
-
-C!-----------------------------------------------------------------------
-C! 4)
-C! Computation of the surface diffusive flux from ground and
-C! calorific capacity of the ground
-C!-----------------------------------------------------------------------
-      DO ig=1,knonv
-C! (pfluxgrd)
-        pfluxgrd(ig) = ztherm_i(ig)*dz1_SV(ig,isnoSV(ig))*              &
-     &      (C_coef(ig,isnoSV(ig))+(D_coef(ig,isnoSV(ig))-1.)           &
-     &      *TsisSV(ig,isnoSV(ig)))
-C! (pcapcal)
-        pcapcal(ig)  = ztherm_i(ig)*                                    &
-     &      (dz2_SV(ig,isnoSV(ig))+dt__SV*(1.-D_coef(ig,isnoSV(ig)))    &
-     &      *dz1_SV(ig,isnoSV(ig)))
-        z1s = mug(ig)*(1.-D_coef(ig,isnoSV(ig)))+1.
-        pcapcal(ig)  = pcapcal(ig)/z1s
-        pfluxgrd(ig) = ( pfluxgrd(ig)                                   &
-     &       + pcapcal(ig) * (TsisSV(ig,isnoSV(ig)) * z1s               &
-     &       - mug(ig)* C_coef(ig,isnoSV(ig))                           &
-     &       - Tsf_SV(ig))       /dt__SV )
-      ENDDO
-        
-      
-      cal(1:knonv) = RCPD / pcapcal(1:knonv)
-      rsolSV(1:knonv)  = rsolSV(1:knonv) + pfluxgrd(1:knonv)
-C!=======================================================================
-C! II. Second part: corresponds to calcul_fluxs_mod.F90 in LMDZ
-C!=======================================================================
-
-      Evp_sv = 0.
-c #NC HSsoKL=0.
-c #NC HLsoKL=0.
-      dSdTSV = 0.
-      dLdTSV = 0.
-	
-      beta(:) = 1.0
-      dif_grnd(:) = 0.0
-
-C! zx_qs = qsat en kg/kg
-C!**********************************************************************x***************
-
-      DO ig = 1,knonv
-        IF (ps__SV(ig)<1.) THEN
-!          write(*,*)'ig',ig,'ps',ps__SV(ig)
-          ps__SV(ig)=max(ps__SV(ig),1.e-8)
-        ENDIF
-        IF (p1l_SV(ig)<1.) THEN
-!          write(*,*)'ig',ig,'p1l',p1l_SV(ig)
-          p1l_SV(ig)=max(p1l_SV(ig),1.e-8)
-        ENDIF
-        IF (TaT_SV(ig)<180.) THEN
-!          write(*,*)'ig',ig,'TaT',TaT_SV(ig)
-          TaT_SV(ig)=max(TaT_SV(ig),180.)
-        ENDIF
-        IF (QaT_SV(ig)<1.e-8) THEN
-!          write(*,*)'ig',ig,'QaT',QaT_SV(ig)
-          QaT_SV(ig)=max(QaT_SV(ig),1.e-8)
-        ENDIF
-        IF (Tsf_SV(ig)<100.) THEN
-!          write(*,*)'ig',ig,'Tsf',Tsf_SV(ig)
-          Tsf_SV(ig)=max(Tsf_SV(ig),180.)
-        ENDIF
-        IF (Tsf_SV(ig)>500.) THEN
-!          write(*,*)'ig',ig,'Tsf',Tsf_SV(ig)
-          Tsf_SV(ig)=min(Tsf_SV(ig),400.)
-        ENDIF
-!         IF (Tsrf(ig).LT.1.) THEN
-!!          write(*,*)'ig',ig,'Tsrf',Tsrf(ig)  
-!           Tsrf(ig)=max(Tsrf(ig),TaT_SV(ig)-20.)
-!         ENDIF
-         IF (cdH_SV(ig)<1.e-10) THEN
-!           IF (ig.le.3)   write(*,*)'ig',ig,'cdH',cdH_SV(ig)
-           cdH_SV(ig)=.5
-         ENDIF
-      ENDDO  
-
-
-      DO ig = 1,knonv
-        zx_pkh(ig) = 1. ! (ps__SV(ig)/ps__SV(ig))**RKAPPA
-        IF (thermcep) THEN
-          zdelta=MAX(0.,SIGN(1.,rtt-Tsf_SV(ig)))
-          zcvm5 = R5LES*LhvH2O*(1.-zdelta) + R5IES*LhsH2O*zdelta
-          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*QaT_SV(ig))
-          zx_qs= r2es * FOEEW(Tsf_SV(ig),zdelta)/ps__SV(ig)
-          zx_qs=MIN(0.5,zx_qs)
-          !write(*,*)'zcor',retv*zx_qs
-          zcor=1./(1.-retv*zx_qs)
-          zx_qs=zx_qs*zcor
-          zx_dq_s_dh = FOEDE(Tsf_SV(ig),zdelta,zcvm5,zx_qs,zcor)        &
-     &          /LhvH2O / zx_pkh(ig)
-        ELSE
-          IF (Tsf_SV(ig)<t_coup) THEN
-             zx_qs = qsats(Tsf_SV(ig)) / ps__SV(ig)
-             zx_dq_s_dh = dqsats(Tsf_SV(ig),zx_qs)/LhvH2O               &
-     &             / zx_pkh(ig)
-          ELSE
-             zx_qs = qsatl(Tsf_SV(ig)) / ps__SV(ig)
-             zx_dq_s_dh = dqsatl(Tsf_SV(ig),zx_qs)/LhvH2O               &
-     &             / zx_pkh(ig)
-          ENDIF
-        ENDIF
-        zx_dq_s_dt(ig) = RCPD * zx_pkh(ig) * zx_dq_s_dh
-        zx_qsat(ig) = zx_qs
-C        zx_coef(ig) = cdH_SV(ig) *                                     &
-C     &       (1.0+SQRT(u1lay(ig)**2+v1lay(ig)**2)) *                   &
-C     &       p1l_SV(ig)/(RD*t1lay(ig))
-        zx_coef(ig) = cdH_SV(ig) *                                      &
-     &       (1.0+VV__SV(ig)) *                                         &
-     &       p1l_SV(ig)/(RD*TaT_SV(ig))
-       
-      ENDDO
-
-
-C! === Calcul de la temperature de surface ===
-C! zx_sl = chaleur latente d'evaporation ou de sublimation
-C!****************************************************************************************
-
-      DO ig = 1,knonv
-        zx_sl(ig) = LhvH2O
-        IF (Tsf_SV(ig) < RTT) zx_sl(ig) = LhsH2O
-        zx_k1(ig) = zx_coef(ig)
-      ENDDO
-    
-
-      DO ig = 1,knonv
-C! Q
-        zx_oq(ig) = 1. - (beta(ig) * zx_k1(ig) * BcoQSV(ig) * dt__SV)
-        zx_mq(ig) = beta(ig) * zx_k1(ig) *                              &
-     &       (AcoQSV(ig) - zx_qsat(ig) +                                &
-     &       zx_dq_s_dt(ig) * Tsf_SV(ig))                               &
-     &       / zx_oq(ig)
-        zx_nq(ig) = beta(ig) * zx_k1(ig) * (-1. * zx_dq_s_dt(ig))       &
-     &       / zx_oq(ig)
-       
-C! H
-        zx_oh(ig) = 1. - (zx_k1(ig) * BcoHSV(ig) * dt__SV)
-        zx_mh(ig) = zx_k1(ig) * AcoHSV(ig) / zx_oh(ig)
-        zx_nh(ig) = - (zx_k1(ig) * RCPD * zx_pkh(ig))/ zx_oh(ig)
-     
-C! surface temperature
-        TsfnSV(ig) = (Tsf_SV(ig) + cal(ig)/RCPD * zx_pkh(ig) * dt__SV * &
-     &       (rsolSV(ig) + zx_mh(ig) + zx_sl(ig) * zx_mq(ig))           & 
-     &       + dif_grnd(ig) * t_grnd * dt__SV)/                         &
-     &       ( 1. - dt__SV * cal(ig)/(RCPD * zx_pkh(ig)) *              &
-     &       (zx_nh(ig) + zx_sl(ig) * zx_nq(ig))                        &  
-     &       + dt__SV * dif_grnd(ig))
-
-!hj rajoute 22 11 2010 tuning...
-        TsfnSV(ig) = min(RTT+0.02,TsfnSV(ig))
-       
-        d_ts(ig) = TsfnSV(ig) - Tsf_SV(ig)
-
-
-C!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
-C!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
-        Evp_sv(ig) = - zx_mq(ig) - zx_nq(ig) * TsfnSV(ig) 
-        HLs_sv(ig) = - Evp_sv(ig) * zx_sl(ig)
-        HSs_sv(ig) = zx_mh(ig) + zx_nh(ig) * TsfnSV(ig)
-       
-C! Derives des flux dF/dTs (W m-2 K-1):
-        dSdTSV(ig) = zx_nh(ig)
-        dLdTSV(ig) = zx_sl(ig) * zx_nq(ig)
-
-
-!hj  new 11 03 2010                                      
-        isl         = isnoSV(ig)
-!        TsisSV(ig,isl) = TsfnSV(ig)                                         
-        IRs_SV(ig) = IRs__D(ig)                                         &!     
-     &                - dIRsdT(ig) * TsfnSV(ig) !TsisSV(ig,isl)?      !  
-
-! hj
-c #NC   SOsoKL(ig) = sol_SV(ig) * SoSosv(ig)              ! Absorbed Sol.    
-c #NC   IRsoKL(ig) =               IRs_SV(ig)                           & !Up Surf. IR
-c #NC&        +     tau_sv(ig)      *IRd_SV(ig)*Eso_sv(ig)              & !Down Atm IR
-c #NC&        -(1.0-tau_sv(ig)) *0.5*IRv_sv(ig)            ! Down Veg IR  
-c #NC   HLsoKL(ig) = HLs_sv(ig) 
-c #NC   HSsoKL(ig) = HSs_sv(ig) 
-c #NC   HLs_KL(ig) = Evp_sv(ig)
-
-C! Nouvelle valeure de l'humidite au dessus du sol
-        qsat_new=zx_qsat(ig) + zx_dq_s_dt(ig) * d_ts(ig)
-        q1_new = AcoQSV(ig) - BcoQSV(ig)* Evp_sv(ig)*dt__SV
-        QaT_SV(ig)=q1_new*(1.-beta(ig)) + beta(ig)*qsat_new 
-
-      ENDDO
-
-      end ! SUBROUTINE SISVAT_TS2
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_ts2.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_ts2.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_ts2.f90	(revision 5105)
@@ -0,0 +1,472 @@
+SUBROUTINE SISVAT_TS2
+  ! #ES.                     (ETSo_0,ETSo_1,ETSo_d)
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_TS2                            Mon 16-08-2009  MAR |
+  ! |   SubRoutine SISVAT_TS2 computes the Soil/Snow temperature and fluxes  |
+  ! |   using the same method as in LMDZ for consistency.                    |
+  ! |   The corresponding LMDZ routines are soil (soil.F90) and calcul_fluxs |
+  ! |   (calcul_fluxs_mod.F90).                                              |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |                                                                        |
+  ! |   PARAMETERS:  klonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of grid boxes of surface type       |
+  ! |                       (land ice for now)                               |
+  ! |                                                                        |
+  ! |   INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   ^^^^^    sol_SV   : Downward Solar Radiation                  [W/m2] |
+  ! |            IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
+  ! |            VV__SV   : SBL Top    Wind Speed                      [m/s] |
+  ! |            TaT_SV   : SBL Top    Temperature                       [K] |
+  ! |            QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
+  ! |            dzsnSV   : Snow Layer Thickness                         [m] |
+  ! |            dt__SV   : Time Step                                    [s] |
+  ! |                                                                        |
+  ! |            SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
+  ! |            Eso_sv   : Soil+Snow       Emissivity                   [-] |
+  ! |   ?        rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
+  ! |                                                                        |
+  ! |            dz1_SV    : "inverse" layer thickness (centered)      [1/m] |
+  ! |            dz2_SV    : layer thickness (layer above (?))           [m] |
+  ! |            AcoHSV    : coefficient for Enthalpy evolution, from atm.   |
+  ! |            AcoHSV    : coefficient for Enthalpy evolution, from atm.   |
+  ! |            AcoQSV    : coefficient for Humidity evolution, from atm.   |
+  ! |            BcoQSV    : coefficient for Humidity evolution, from atm.   |
+  ! |            ps__SV    : surface pressure                           [Pa] |
+  ! |            p1l_SV    : 1st atmospheric layer pressure             [Pa] |
+  ! |            cdH_SV    : drag coeff Energy (?)                           |
+  ! |            rsolSV    : Radiation balance surface                [W/m2] |
+  ! |            lambSV    : Coefficient for soil layer geometry         [-] |
+  ! |                                                                        |
+  ! |   INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+  ! |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  ! |   ^^^^^^   rsolSV   : Radiation balance surface                 [W/m2] |
+  ! |                                                                        |
+  ! |   OUTPUT:  IRs_SV   : Soil      IR Radiation                    [W/m2] |
+  ! |   ^^^^^^   HSs_sv   : Sensible  Heat Flux                       [W/m2] |
+  ! |            HLs_sv   : Latent    Heat Flux                       [W/m2] |
+  ! |            TsfnSV   : new surface temperature                      [K] |
+  ! |            Evp_sv   : Evaporation                              [kg/m2] |
+  ! |            dSdTSV   : Sensible Heat Flux temp. derivative     [W/m2/K] |
+  ! |            dLdTSV   : Latent Heat Flux temp. derivative       [W/m2/K] |
+  ! |                                                                        |
+  ! |   ?        ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
+  ! |   ?        ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
+  ! |   ?        ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
+  ! |                                                                        |
+  ! |________________________________________________________________________|
+
+  USE VAR_SV
+  USE VARdSV
+
+  USE VARySV
+  USE VARtSV
+  USE VARxSV
+  USE VARphy
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "FCTTRE.h"
+  ! INCLUDE "indicesol.h"
+  INCLUDE "comsoil.h"
+  ! include  "LMDZphy.inc"
+
+  ! +--OUTPUT for Stand Alone NetCDF File
+  ! +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ! #NC      real*8        SOsoKL(klonv)             ! Absorbed Solar Radiation
+  ! #NC      real*8        IRsoKL(klonv)             ! Absorbed IR    Radiation
+  ! #NC      real*8        HSsoKL(klonv)             ! Absorbed Sensible Heat Flux
+  ! #NC      real*8        HLsoKL(klonv)             ! Absorbed Latent   Heat Flux
+  ! #NC      real*8        HLs_KL(klonv)             ! Evaporation
+  ! #NC      real*8        HLv_KL(klonv)             ! Transpiration
+  ! #NC      common/DumpNC/SOsoKL,IRsoKL
+  ! #NC     .             ,HSsoKL,HLsoKL
+  ! #NC     .             ,HLs_KL,HLv_KL
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  integer :: ig, jk, isl
+  real :: mu
+  real :: Tsrf(klonv)               ! surface temperature as extrapolated from soil
+  real :: mug(klonv)                 !hj coef top layers
+  real :: ztherm_i(klonv), zdz2(klonv, -nsol:nsno), z1s
+  real :: pfluxgrd(klonv), pcapcal(klonv), cal(klonv)
+  real :: beta(klonv), dif_grnd(klonv)
+  real :: C_coef(klonv, -nsol:nsno), D_coef(klonv, -nsol:nsno)
+
+  REAL, DIMENSION(klonv) :: zx_mh, zx_nh, zx_oh
+  REAL, DIMENSION(klonv) :: zx_mq, zx_nq, zx_oq
+  REAL, DIMENSION(klonv) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+  REAL, DIMENSION(klonv) :: zx_sl, zx_k1
+  REAL, DIMENSION(klonv) :: d_ts
+  REAL :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+  REAL :: qsat_new, q1_new
+  ! REAL, PARAMETER          :: t_grnd = 271.35, t_coup = 273.15
+  ! REAL, PARAMETER          :: max_eau_sol = 150.0
+  REAL, DIMENSION(klonv) :: IRs__D, dIRsdT
+
+  REAL :: t_grnd                      ! not used
+  parameter(t_grnd = 271.35)       !
+  REAL :: t_coup                      ! distinguish evap/sublimation
+  parameter(t_coup = 273.15)       !
+  REAL :: max_eau_sol
+  parameter(max_eau_sol = 150.0)
+
+
+  ! write(*,*)'T check'
+
+  ! DO  ig = 1,knonv
+  !     DO  jk = 1,isnoSV(ig) !nsno
+  !       IF (TsisSV(ig,jk) <= 1.) THEN          !hj check
+  !         TsisSV(ig,jk) = TsisSV(ig,isnoSV(ig))
+  !       ENDIF
+
+  !       IF (TsisSV(ig,jk) <= 1.) THEN          !hj check
+  !         TsisSV(ig,jk) = 273.15
+  !       ENDIF
+  !     END DO
+  !        END DO
+
+  !!=======================================================================
+  !! I. First part: corresponds to soil.F90 in LMDZ
+  !!=======================================================================
+
+  DO ig = 1, knonv
+    DO jk = 1, isnoSV(ig)
+      dz2_SV(ig, jk) = dzsnSV(ig, jk)
+      !! use arithmetic center between layers to derive dz1 for snow layers for simplicity:
+      dz1_SV(ig, jk) = 2. / (dzsnSV(ig, jk) + dzsnSV(ig, jk - 1))
+    ENDDO
+  ENDDO
+
+  DO ig = 1, knonv
+    ztherm_i(ig) = inertie_lic
+    IF (isnoSV(ig) > 0) ztherm_i(ig) = inertie_sno
+  ENDDO
+
+  !!-----------------------------------------------------------------------
+  !! 1)
+  !! Calculation of Cgrf and Dgrd coefficients using soil temperature from
+  !! previous time step.
+  !!
+  !! These variables are recalculated on the local compressed grid instead
+  !! of saved in restart file.
+  !!-----------------------------------------------------------------------
+  DO ig = 1, knonv
+    DO jk = -nsol, nsno
+      zdz2(ig, jk) = dz2_SV(ig, jk) / dt__SV                                !ptimestep
+    ENDDO
+  ENDDO
+
+  DO ig = 1, knonv
+    z1s = zdz2(ig, -nsol) + dz1_SV(ig, -nsol + 1)
+    C_coef(ig, -nsol + 1) = zdz2(ig, -nsol) * TsisSV(ig, -nsol) / z1s
+    D_coef(ig, -nsol + 1) = dz1_SV(ig, -nsol + 1) / z1s
+  ENDDO
+
+  DO ig = 1, knonv
+    DO jk = -nsol + 1, isnoSV(ig) - 1, 1
+      z1s = 1. / (zdz2(ig, jk) + dz1_SV(ig, jk + 1) + dz1_SV(ig, jk)           &
+              * (1. - D_coef(ig, jk)))
+      C_coef(ig, jk + 1) = &
+              (TsisSV(ig, jk) * zdz2(ig, jk)                              &
+                      + dz1_SV(ig, jk) * C_coef(ig, jk)) * z1s
+      D_coef(ig, jk + 1) = dz1_SV(ig, jk + 1) * z1s
+    ENDDO
+  ENDDO
+
+  !!-----------------------------------------------------------------------
+  !! 2)
+  !! Computation of the soil temperatures using the Cgrd and Dgrd
+  !! coefficient computed above
+  !!
+  !!-----------------------------------------------------------------------
+  !! Extrapolate surface Temperature                   !hj check
+  mu = 1. / ((2.**1.5 - 1.) / (2.**(0.5) - 1.) - 1.)
+
+  ! IF (knonv>0) THEN
+  !  DO ig=1,8
+  !    write(*,*)ig,'sisvat: Tsis ',TsisSV(ig,isnoSV(ig))
+  !    write(*,*)'max-1            ',TsisSV(ig,isnoSV(ig)-1)
+  !    write(*,*)'max-2            ',TsisSV(ig,isnoSV(ig)-2)
+  !    write(*,*)'0                ',TsisSV(ig,0)
+  !!        write(*,*)min(max(isnoSV(ig),0),1),max(1-isnoSV(ig),0)
+  !  ENDDO
+  ! END IF
+
+  DO ig = 1, knonv
+    IF (isnoSV(ig)>0) THEN
+      IF (isnoSV(ig)>1) THEN
+        mug(ig) = 1. / (1. + dzsnSV(ig, isnoSV(ig) - 1) / dzsnSV(ig, isnoSV(ig))) !mu
+      ELSE
+        mug(ig) = 1. / (1. + dzsnSV(ig, isnoSV(ig) - 1) / dz_dSV(0)) !mu
+      ENDIF
+    ELSE
+      mug(ig) = lambSV
+    ENDIF
+
+    IF (mug(ig)  <= 0.05) THEN
+      write(*, *)'Attention mu low', mug(ig)
+    ENDIF
+    IF (mug(ig)  >= 0.98) THEN
+      write(*, *)'Attention mu high', mug(ig)
+    ENDIF
+
+    Tsrf(ig) = (1.5 * TsisSV(ig, isnoSV(ig)) - 0.5 * TsisSV(ig, isnoSV(ig) - 1))&
+            * min(max(isnoSV(ig), 0), 1) + &
+            ((mug(ig) + 1) * TsisSV(ig, 0) - mug(ig) * TsisSV(ig, -1))       &
+                    * max(1 - isnoSV(ig), 0)
+  ENDDO
+
+
+
+  !! Surface temperature
+  DO ig = 1, knonv
+    TsisSV(ig, isnoSV(ig)) = (mug(ig) * C_coef(ig, isnoSV(ig)) + Tsf_SV(ig)) / &
+            (mug(ig) * (1. - D_coef(ig, isnoSV(ig))) + 1.)
+  ENDDO
+
+  !! Other temperatures
+  DO ig = 1, knonv
+    DO jk = isnoSV(ig), -nsol + 1, -1
+      TsisSV(ig, jk - 1) = C_coef(ig, jk) + D_coef(ig, jk)                   &
+              * TsisSV(ig, jk)
+    ENDDO
+  ENDDO
+  ! write(*,*)ig,'Tsis',TsisSV(ig,0)
+
+  ! IF (indice == is_sic) THEN
+  !   DO ig = 1,knonv
+  !     TsisSV(ig,-nsol) = RTT - 1.8
+  !   END DO
+  ! ENDIF
+
+  !C      !hj new 11 03 2010
+  DO ig = 1, knonv
+    isl = isnoSV(ig)
+    ! dIRsdT(ig) = Eso_sv(ig)* SteBo   * 4.                        & ! - d(IR)/d(T)
+    ! &                             * Tsf_SV(ig)                         & !T TsisSV(ig,isl)           !
+    ! &                             * Tsf_SV(ig)                         & !TsisSV(ig,isl)           !
+    ! &                             * Tsf_SV(ig) !TsisSV(ig,isl)           !
+    !      IRs__D(ig) = dIRsdT(ig)* Tsf_SV(ig) * 0.75 !TsisSV(ig,isl) * 0.75    !:
+    dIRsdT(ig) = Eso_sv(ig) * StefBo * 4.                        & ! - d(IR)/d(T)
+            * TsisSV(ig, isl)                     & !
+            * TsisSV(ig, isl)                     & !
+            * TsisSV(ig, isl)
+    IRs__D(ig) = dIRsdT(ig)* TsisSV(ig, isl) * 0.75                  !:
+  END DO
+  ! !hj
+  !!-----------------------------------------------------------------------
+  !! 3)
+  !! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil
+  !! temperature
+  !!-----------------------------------------------------------------------
+  DO ig = 1, knonv
+    z1s = zdz2(ig, -nsol) + dz1_SV(ig, -nsol + 1)
+    C_coef(ig, -nsol + 1) = zdz2(ig, -nsol) * TsisSV(ig, -nsol) / z1s
+    D_coef(ig, -nsol + 1) = dz1_SV(ig, -nsol + 1) / z1s
+  ENDDO
+
+  DO ig = 1, knonv
+    DO jk = -nsol + 1, isnoSV(ig) - 1, 1
+      z1s = 1. / (zdz2(ig, jk) + dz1_SV(ig, jk + 1) + dz1_SV(ig, jk)           &
+              * (1. - D_coef(ig, jk)))
+      C_coef(ig, jk + 1) = (TsisSV(ig, jk) * zdz2(ig, jk) + &
+              dz1_SV(ig, jk) * C_coef(ig, jk)) * z1s
+      D_coef(ig, jk + 1) = dz1_SV(ig, jk + 1) * z1s
+    ENDDO
+  ENDDO
+
+  !!-----------------------------------------------------------------------
+  !! 4)
+  !! Computation of the surface diffusive flux from ground and
+  !! calorific capacity of the ground
+  !!-----------------------------------------------------------------------
+  DO ig = 1, knonv
+    !! (pfluxgrd)
+    pfluxgrd(ig) = ztherm_i(ig) * dz1_SV(ig, isnoSV(ig)) * &
+            (C_coef(ig, isnoSV(ig)) + (D_coef(ig, isnoSV(ig)) - 1.)           &
+                    * TsisSV(ig, isnoSV(ig)))
+    !! (pcapcal)
+    pcapcal(ig) = ztherm_i(ig) * &
+            (dz2_SV(ig, isnoSV(ig)) + dt__SV * (1. - D_coef(ig, isnoSV(ig)))    &
+                    * dz1_SV(ig, isnoSV(ig)))
+    z1s = mug(ig) * (1. - D_coef(ig, isnoSV(ig))) + 1.
+    pcapcal(ig) = pcapcal(ig) / z1s
+    pfluxgrd(ig) = (pfluxgrd(ig)                                   &
+            + pcapcal(ig) * (TsisSV(ig, isnoSV(ig)) * z1s               &
+                    - mug(ig) * C_coef(ig, isnoSV(ig))                           &
+                    - Tsf_SV(ig)) / dt__SV)
+  ENDDO
+
+  cal(1:knonv) = RCPD / pcapcal(1:knonv)
+  rsolSV(1:knonv) = rsolSV(1:knonv) + pfluxgrd(1:knonv)
+  !!=======================================================================
+  !! II. Second part: corresponds to calcul_fluxs_mod.F90 in LMDZ
+  !!=======================================================================
+
+  Evp_sv = 0.
+  ! #NC HSsoKL=0.
+  ! #NC HLsoKL=0.
+  dSdTSV = 0.
+  dLdTSV = 0.
+
+  beta(:) = 1.0
+  dif_grnd(:) = 0.0
+
+  !! zx_qs = qsat en kg/kg
+  !!**********************************************************************x***************
+
+  DO ig = 1, knonv
+    IF (ps__SV(ig)<1.) THEN
+      ! write(*,*)'ig',ig,'ps',ps__SV(ig)
+      ps__SV(ig) = max(ps__SV(ig), 1.e-8)
+    ENDIF
+    IF (p1l_SV(ig)<1.) THEN
+      ! write(*,*)'ig',ig,'p1l',p1l_SV(ig)
+      p1l_SV(ig) = max(p1l_SV(ig), 1.e-8)
+    ENDIF
+    IF (TaT_SV(ig)<180.) THEN
+      ! write(*,*)'ig',ig,'TaT',TaT_SV(ig)
+      TaT_SV(ig) = max(TaT_SV(ig), 180.)
+    ENDIF
+    IF (QaT_SV(ig)<1.e-8) THEN
+      ! write(*,*)'ig',ig,'QaT',QaT_SV(ig)
+      QaT_SV(ig) = max(QaT_SV(ig), 1.e-8)
+    ENDIF
+    IF (Tsf_SV(ig)<100.) THEN
+      ! write(*,*)'ig',ig,'Tsf',Tsf_SV(ig)
+      Tsf_SV(ig) = max(Tsf_SV(ig), 180.)
+    ENDIF
+    IF (Tsf_SV(ig)>500.) THEN
+      ! write(*,*)'ig',ig,'Tsf',Tsf_SV(ig)
+      Tsf_SV(ig) = min(Tsf_SV(ig), 400.)
+    ENDIF
+    ! IF (Tsrf(ig).LT.1.) THEN
+    !!          write(*,*)'ig',ig,'Tsrf',Tsrf(ig)
+    !   Tsrf(ig)=max(Tsrf(ig),TaT_SV(ig)-20.)
+    ! ENDIF
+    IF (cdH_SV(ig)<1.e-10) THEN
+      ! IF (ig.le.3)   write(*,*)'ig',ig,'cdH',cdH_SV(ig)
+      cdH_SV(ig) = .5
+    ENDIF
+  ENDDO
+
+  DO ig = 1, knonv
+    zx_pkh(ig) = 1. ! (ps__SV(ig)/ps__SV(ig))**RKAPPA
+    IF (thermcep) THEN
+      zdelta = MAX(0., SIGN(1., rtt - Tsf_SV(ig)))
+      zcvm5 = R5LES * LhvH2O * (1. - zdelta) + R5IES * LhsH2O * zdelta
+      zcvm5 = zcvm5 / RCPD / (1.0 + RVTMP2 * QaT_SV(ig))
+      zx_qs = r2es * FOEEW(Tsf_SV(ig), zdelta) / ps__SV(ig)
+      zx_qs = MIN(0.5, zx_qs)
+      ! !write(*,*)'zcor',retv*zx_qs
+      zcor = 1. / (1. - retv * zx_qs)
+      zx_qs = zx_qs * zcor
+      zx_dq_s_dh = FOEDE(Tsf_SV(ig), zdelta, zcvm5, zx_qs, zcor)        &
+              / LhvH2O / zx_pkh(ig)
+    ELSE
+      IF (Tsf_SV(ig)<t_coup) THEN
+        zx_qs = qsats(Tsf_SV(ig)) / ps__SV(ig)
+        zx_dq_s_dh = dqsats(Tsf_SV(ig), zx_qs) / LhvH2O               &
+                / zx_pkh(ig)
+      ELSE
+        zx_qs = qsatl(Tsf_SV(ig)) / ps__SV(ig)
+        zx_dq_s_dh = dqsatl(Tsf_SV(ig), zx_qs) / LhvH2O               &
+                / zx_pkh(ig)
+      ENDIF
+    ENDIF
+    zx_dq_s_dt(ig) = RCPD * zx_pkh(ig) * zx_dq_s_dh
+    zx_qsat(ig) = zx_qs
+    ! zx_coef(ig) = cdH_SV(ig) *                                     &
+    ! &       (1.0+SQRT(u1lay(ig)**2+v1lay(ig)**2)) *                   &
+    ! &       p1l_SV(ig)/(RD*t1lay(ig))
+    zx_coef(ig) = cdH_SV(ig) * &
+            (1.0 + VV__SV(ig)) * &
+            p1l_SV(ig) / (RD * TaT_SV(ig))
+
+  ENDDO
+
+
+  !! === Calcul de la temperature de surface ===
+  !! zx_sl = chaleur latente d'evaporation ou de sublimation
+  !!****************************************************************************
+
+  DO ig = 1, knonv
+    zx_sl(ig) = LhvH2O
+    IF (Tsf_SV(ig) < RTT) zx_sl(ig) = LhsH2O
+    zx_k1(ig) = zx_coef(ig)
+  ENDDO
+
+  DO ig = 1, knonv
+    !! Q
+    zx_oq(ig) = 1. - (beta(ig) * zx_k1(ig) * BcoQSV(ig) * dt__SV)
+    zx_mq(ig) = beta(ig) * zx_k1(ig) * &
+            (AcoQSV(ig) - zx_qsat(ig) + &
+                    zx_dq_s_dt(ig) * Tsf_SV(ig))                               &
+            / zx_oq(ig)
+    zx_nq(ig) = beta(ig) * zx_k1(ig) * (-1. * zx_dq_s_dt(ig))       &
+            / zx_oq(ig)
+
+    !! H
+    zx_oh(ig) = 1. - (zx_k1(ig) * BcoHSV(ig) * dt__SV)
+    zx_mh(ig) = zx_k1(ig) * AcoHSV(ig) / zx_oh(ig)
+    zx_nh(ig) = - (zx_k1(ig) * RCPD * zx_pkh(ig)) / zx_oh(ig)
+
+    !! surface temperature
+    TsfnSV(ig) = (Tsf_SV(ig) + cal(ig) / RCPD * zx_pkh(ig) * dt__SV * &
+            (rsolSV(ig) + zx_mh(ig) + zx_sl(ig) * zx_mq(ig))           &
+            + dif_grnd(ig) * t_grnd * dt__SV) / &
+            (1. - dt__SV * cal(ig) / (RCPD * zx_pkh(ig)) * &
+                    (zx_nh(ig) + zx_sl(ig) * zx_nq(ig))                        &
+                    + dt__SV * dif_grnd(ig))
+
+    !hj rajoute 22 11 2010 tuning...
+    TsfnSV(ig) = min(RTT + 0.02, TsfnSV(ig))
+
+    d_ts(ig) = TsfnSV(ig) - Tsf_SV(ig)
+
+
+    !!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+    !!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+    Evp_sv(ig) = - zx_mq(ig) - zx_nq(ig) * TsfnSV(ig)
+    HLs_sv(ig) = - Evp_sv(ig) * zx_sl(ig)
+    HSs_sv(ig) = zx_mh(ig) + zx_nh(ig) * TsfnSV(ig)
+
+    !! Derives des flux dF/dTs (W m-2 K-1):
+    dSdTSV(ig) = zx_nh(ig)
+    dLdTSV(ig) = zx_sl(ig) * zx_nq(ig)
+
+
+    !hj  new 11 03 2010
+    isl = isnoSV(ig)
+    ! TsisSV(ig,isl) = TsfnSV(ig)
+    IRs_SV(ig) = IRs__D(ig)                                         & !
+            - dIRsdT(ig) * TsfnSV(ig) !TsisSV(ig,isl)?      !
+
+    ! hj
+    ! #NC   SOsoKL(ig) = sol_SV(ig) * SoSosv(ig)              ! Absorbed Sol.
+    ! #NC   IRsoKL(ig) =               IRs_SV(ig)                           & !Up Surf. IR
+    ! #NC&        +     tau_sv(ig)      *IRd_SV(ig)*Eso_sv(ig)              & !Down Atm IR
+    ! #NC&        -(1.0-tau_sv(ig)) *0.5*IRv_sv(ig)            ! Down Veg IR
+    ! #NC   HLsoKL(ig) = HLs_sv(ig)
+    ! #NC   HSsoKL(ig) = HSs_sv(ig)
+    ! #NC   HLs_KL(ig) = Evp_sv(ig)
+
+    !! Nouvelle valeure de l'humidite au dessus du sol
+    qsat_new = zx_qsat(ig) + zx_dq_s_dt(ig) * d_ts(ig)
+    q1_new = AcoQSV(ig) - BcoQSV(ig) * Evp_sv(ig) * dt__SV
+    QaT_SV(ig) = q1_new * (1. - beta(ig)) + beta(ig) * qsat_new
+
+  ENDDO
+
+end subroutine sisvat_ts2
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_tso.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_tso.F	(revision 5104)
+++ 	(revision )
@@ -1,675 +1,0 @@
- 
- 
- 
- 
-      SUBROUTINE SISVAT_TSo
-! #e1.                     (ETSo_0,ETSo_1,ETSo_d)
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_TSo                                06-10-2020  MAR |
-C |   SubRoutine SISVAT_TSo computes the Soil/Snow Energy Balance          |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT:   isotSV   = 0,...,11:   Soil       Type                      |
-C |   ^^^^^               0:          Water, Solid or Liquid               |
-C |            isnoSV   = total Nb of Ice/Snow Layers                      |
-C |            dQa_SV   = Limitation of  Water Vapor  Turbulent Flux       |
-C |                                                                        |
-C |   INPUT:   sol_SV   : Downward Solar Radiation                  [W/m2] |
-C |   ^^^^^    IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
-C |            za__SV   : SBL Top    Height                            [m] |
-C |            VV__SV   : SBL Top    Wind Speed                      [m/s] |
-C |            TaT_SV   : SBL Top    Temperature                       [K] |
-C |            rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
-C |            QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
-C |            LSdzsv   : Vertical   Discretization Factor             [-] |
-C |                     =    1. Soil                                       |
-C |                     = 1000. Ocean                                      |
-C |            dzsnSV   : Snow Layer Thickness                         [m] |
-C |            ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
-C |            eta_SV   : Soil Water Content                       [m3/m3] |
-C |            dt__SV   : Time Step                                    [s] |
-C |                                                                        |
-C |            SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
-C |            Eso_sv   : Soil+Snow       Emissivity                   [-] |
-C |            rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
-C |            Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
-C |            sEX_sv   : Verticaly Integrated Extinction Coefficient  [-] |
-C |                                                                        |
-C |   INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
-C |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
-C |   ^^^^^^                                                               |
-C |                                                                        |
-C |   OUTPUT:  IRs_SV   : Soil      IR Radiation                    [W/m2] |
-C |   ^^^^^^   HSs_sv   : Sensible  Heat Flux                       [W/m2] |
-C |            HLs_sv   : Latent    Heat Flux                       [W/m2] |
-C |            ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
-C |            ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
-C |            ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
-C |                                                                        |
-C |   Internal Variables:                                                  |
-C |   ^^^^^^^^^^^^^^^^^^                                                   |
-C |                                                                        |
-C |   METHOD: NO   Skin Surface Temperature                                |
-C |   ^^^^^^  Semi-Implicit Crank Nicholson Scheme                         |
-C |                                                                        |
-C | # OPTIONS: #E0: Energy Budget Verification                             |
-C | # ^^^^^^^  #kd: KDsvat Option:NO Flux  Limitor     on HL               |
-C | #          #KD: KDsvat Option:Explicit Formulation of HL               |
-C | #          #NC: OUTPUT for Stand Alone NetCDF File                     |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
- 
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VARxSV
-      use VARySV
-      use VARtSV
-      use VAR0SV
-      
-
-      IMPLICIT NONE
-
- 
-C +--OUTPUT
-C +  ------
- 
-! #e1 real      ETSo_0(knonv)                 ! Soil/Snow Power, before Forcing
-! #e1 real      ETSo_1(knonv)                 ! Soil/Snow Power, after  Forcing
-! #e1 real      ETSo_d(knonv)                 ! Soil/Snow Power, Forcing
- 
- 
-C +--Internal Variables
-C +  ==================
- 
-      integer   ikl   ,isl   ,jsl   ,ist      !
-      integer   ist__s,ist__w                 ! Soil/Water  Body Identifier
-      integer   islsgn                        ! Soil/Snow Surfac.Identifier
-      real      eps__3                        ! Arbitrary    Low Number
-      real      etaMid,psiMid                 ! Layer Interface's Humidity
-      real      mu_eta                        !     Soil thermal Conductivity
-      real      mu_exp                        ! arg Soil thermal Conductivity
-      real      mu_min                        ! Min Soil thermal Conductivity
-      real      mu_max                        ! Max Soil thermal Conductivity
-      real      mu_sno(knonv),mu_aux          !     Snow thermal Conductivity
-      real      mu__dz(knonv,-nsol:nsno+1)    ! mu_(eta,sno)   / dz
-      real      dtC_sv(knonv,-nsol:nsno)      ! dt      / C
-      real      IRs__D(knonv)                 ! UpwardIR Previous Iter.Contr.
-      real      dIRsdT(knonv)                 ! UpwardIR           T Derivat.
-      real      f_HSHL(knonv)                 ! Factor common to HS and HL
-      real      dRidTs(knonv)                 ! d(Rib)/d(Ts)
-      real      HS___D(knonv)                 ! Sensible Heat Flux Atm.Contr.
-      real      f___HL(knonv)                 !
-      real      HL___D(knonv)                 ! Latent   Heat Flux Atm.Contr.
-      REAL      TSurf0(knonv),dTSurf          ! Previous Surface Temperature
-      real      qsatsg(knonv) !,den_qs,arg_qs ! Soil   Saturat. Spec. Humidity
-      real      dqs_dT(knonv)                 ! d(qsatsg)/dTv
-      real      Psi(   knonv)                 ! 1st Soil Layer Water Potential
-      real      RHuSol(knonv)                 ! Soil Surface Relative Humidity
-      real      etaSol                        ! Soil Surface          Humidity
-      real      d__eta                        ! Soil Surface Humidity Increm.
-      real      Elem_A,Elem_C                 !   Diagonal Coefficients
-      real      Diag_A(knonv,-nsol:nsno)      ! A Diagonal
-      real      Diag_B(knonv,-nsol:nsno)      ! B Diagonal
-      real      Diag_C(knonv,-nsol:nsno)      ! C Diagonal
-      real      Term_D(knonv,-nsol:nsno)      !   Independant Term
-      real      Aux__P(knonv,-nsol:nsno)      ! P Auxiliary Variable
-      real      Aux__Q(knonv,-nsol:nsno)      ! Q Auxiliary Variable
-      real      Ts_Min,Ts_Max                 ! Temperature Limits
-! #e1 real      Exist0                        ! Existing Layer Switch
-      real      psat_wat, psat_ice, sp        ! computation of qsat
-
-      integer   nt_srf,it_srf,itEuBk          ! HL: Surface Scheme
-      parameter(nt_srf=10)                     ! 10 before
-      real      agpsrf,xgpsrf,dt_srf,dt_ver   !
-      real      etaBAK(knonv)                 !
-      real      etaNEW(knonv)                 !
-      real      etEuBk(knonv)                 !
-      real      fac_dt(knonv),faceta(knonv)   !
-      real      PsiArg(knonv),SHuSol(knonv)   !
- 
-
- 
-C +--Internal DATA
-C +  =============
- 
-      data      eps__3 /   1.e-3   /          ! Arbitrary    Low Number
-      data      mu_exp /  -0.4343  /          ! Soil Thermal Conductivity
-      data      mu_min /   0.172   /          ! Min Soil Thermal Conductivity
-      data      mu_max /   2.000   /          ! Max Soil Thermal Conductivity
-      data      Ts_Min / 175.      /          ! Temperature            Minimum
-      data      Ts_Max / 300.      /          ! Temperature Acceptable Maximum
-C +                                           ! including   Snow Melt  Energy
- 
-C +-- Initilialisation of local arrays
-C +   ================================
-        DO ikl=1,knonv
-
-          mu_sno(ikl)=0.
-          mu__dz(ikl,:)=0.    
-          dtC_sv(ikl,:)=0.      
-          IRs__D(ikl)=0.                 
-          dIRsdT(ikl)=0.                 
-          f_HSHL(ikl)=0.                 
-          dRidTs(ikl)=0.                 
-          HS___D(ikl)=0.                
-          f___HL(ikl)=0.             
-          HL___D(ikl)=0.            
-          TSurf0(ikl)=0.      
-          qsatsg(ikl)=0. 
-          dqs_dT(ikl)=0.                 
-          Psi(ikl)=0.               
-          RHuSol(ikl)=0.                 
-          Diag_A(ikl,:)=0.      
-          Diag_B(ikl,:)=0.      
-          Diag_C(ikl,:)=0.      
-          Term_D(ikl,:)=0.      
-          Aux__P(ikl,:)=0.      
-          Aux__Q(ikl,:)=0.      
-          etaBAK(ikl)=0.                
-          etaNEW(ikl)=0.               
-          etEuBk(ikl)=0.                 
-          fac_dt(ikl)=0. 
-          faceta(ikl)=0.  
-          PsiArg(ikl)=0. 
-          SHuSol(ikl)=0.  
-
-        END DO
-
-        
-
-C +--Heat Conduction Coefficient (zero in the Layers over the highest one)
-C +  ===========================
-C +                             ---------------- isl    eta_SV, rho C (isl)
-C +
-C +--Soil                       ++++++++++++++++        etaMid,    mu (isl)
-C +  ----
-C +                             ---------------- isl-1  eta_SV, rho C (isl-1)
-           isl=-nsol
-        DO ikl=1,knonv
-
-          mu__dz(ikl,isl) = 0.
- 
-          dtC_sv(ikl,isl) = dtz_SV2(isl)  * dt__SV        ! dt / (dz X rho C)
-     .                   /((rocsSV(isotSV(ikl))           ! [s / (m.J/m3/K)]
-     .                     +rcwdSV*eta_SV(ikl,isl))       !
-     .                     *LSdzsv(ikl)            )      !
-        END DO
-      DO   isl=-nsol+1,0
-        DO ikl=1,knonv
-          ist    =      isotSV(ikl)                       ! Soil Type
-          ist__s =  min(ist, 1)                           ! 1 => Soil
-          ist__w =  1 - ist__s                            ! 1 => Water Body
- 
-          etaMid = 0.5*(dz_dSV(isl-1)*eta_SV(ikl,isl-1)   ! eta at layers
-     .                 +dz_dSV(isl)  *eta_SV(ikl,isl)  )  !     interface
-     .                 /dzmiSV(isl)                       ! LSdzsv implicit !
-          etaMid =  max(etaMid,epsi)
-          psiMid =      psidSV(ist)
-     .                *(etadSV(ist)/etaMid)**bCHdSV(ist)
-          mu_eta =      3.82      *(psiMid)**mu_exp       ! Soil Thermal
-          mu_eta =  min(max(mu_eta, mu_min), mu_max)      ! Conductivity
-C +                                                       ! DR97 eq.3.31
-          mu_eta =  ist__s *mu_eta +ist__w * vK_dSV       ! Water Bodies
-C +                                                       ! Correction
-          mu__dz(ikl,isl) = mu_eta/(dzmiSV(isl)           !
-     .                             *LSdzsv(ikl))          !
- 
-          dtC_sv(ikl,isl) = dtz_SV2(isl)* dt__SV          ! dt / (dz X rho C)
-     .                   /((rocsSV(isotSV(ikl))           !
-     .                     +rcwdSV*eta_SV(ikl,isl))       !
-     .                     *LSdzsv(ikl)            )      !
-        END DO
-      END DO
- 
- 
-C +--Soil/Snow Interface
-C +  -------------------
- 
-C +--Soil Contribution
-C +  ^^^^^^^^^^^^^^^^^
-           isl=1
-        DO ikl=1,knonv
-          ist    =      isotSV(ikl)                       ! Soil Type
-          ist__s =  min(ist, 1)                           ! 1 => Soil
-          ist__w =  1 - ist__s                            ! 1 => Water Body
-          psiMid =      psidSV(ist)                       ! Snow => Saturation
-          mu_eta =      3.82      *(psiMid)**mu_exp       ! Soil Thermal
-          mu_eta =  min(max(mu_eta, mu_min), mu_max)      ! Conductivity
-C +                                                       ! DR97 eq.3.31
-          mu_eta =  ist__s *mu_eta +ist__w * vK_dSV       ! Water Bodies
- 
-C +--Snow Contribution
-C +  ^^^^^^^^^^^^^^^^^
-          mu_sno(ikl) =  CdidSV                           !
-     .                 *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 !
-          mu_sno(ikl) =          max(epsi,mu_sno(ikl))    !
-C +...    mu_sno :  Snow Heat Conductivity Coefficient [Wm/K]
-C +                 (Yen 1981, CRREL Rep., 81-10)
- 
-C +--Combined Heat Conductivity
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-          mu__dz(ikl,isl) = 2./(dzsnSV(ikl,isl  )         ! Combined Heat
-     .                         /mu_sno(ikl)               ! Conductivity
-     .                         +LSdzsv(ikl)               !
-     .                         *dz_dSV(    isl-1)/mu_eta) ! Coefficient
- 
-C +--Inverted Heat Capacity
-C +  ^^^^^^^^^^^^^^^^^^^^^^
-          dtC_sv(ikl,isl) = dt__SV/max(epsi,              ! dt / (dz X rho C)
-     .    dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV)      !
-        END DO
- 
- 
-C +--Snow
-C +  ----
- 
-      DO ikl=1,knonv
-      DO   isl=1,min(nsno,isnoSV(ikl)+1)
-          ro__SV(ikl,isl) =                               !
-     .                   ro__SV(ikl ,isl)                 !
-     .       * max(0,min(isnoSV(ikl)-isl+1,1))            !
-
-        END DO
-      END DO
- 
-      DO ikl=1,knonv
-      DO   isl=1,min(nsno,isnoSV(ikl)+1)
- 
-C +--Combined Heat Conductivity
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-          mu_aux      =  CdidSV                           !
-     .                 *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 !
-          mu__dz(ikl,isl) =                               !
-     .      2.                        *mu_aux*mu_sno(ikl) ! Combined Heat
-     .     /max(epsi,dzsnSV(ikl,isl  )*mu_sno(ikl)        ! Conductivity
-     .              +dzsnSV(ikl,isl-1)*mu_aux     )       ! For upper Layer
-          mu_sno(ikl)     =            mu_aux             !
- 
-C +--Inverted Heat Capacity
-C +  ^^^^^^^^^^^^^^^^^^^^^^
-          dtC_sv(ikl,isl) = dt__SV/max(eps__3,            ! dt / (dz X rho C)
-     .    dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV)      !
-        END DO
-      END DO
- 
- 
-C +--Uppermost Effective Layer: NO conduction
-C +  ----------------------------------------
- 
-        DO ikl=1,knonv
-          mu__dz(ikl,isnoSV(ikl)+1) = 0.0
-        END DO
- 
- 
-C +--Energy Budget (IN)
-C +  ==================
- 
-! #e1   DO ikl=1,knonv
-! #e1     ETSo_0(ikl) = 0.
-! #e1   END DO
-! #e1 DO   isl= -nsol,nsno
-! #e1   DO ikl=1,knonv
-! #e1     Exist0      = isl -           isnoSV(ikl)
-! #e1     Exist0      = 1.  - max(zero,min(unun,Exist0))
-! #e1     ETSo_0(ikl) = ETSo_0(ikl)
-! #e1.                +(TsisSV(ikl,isl)-TfSnow)*Exist0
-! #e1.                                 /dtC_sv(ikl,isl)
-! #e1   END DO
-! #e1 END DO
- 
- 
-C +--Tridiagonal Elimination: Set Up
-C +  ===============================
- 
-C +--Soil/Snow Interior
-C +  ^^^^^^^^^^^^^^^^^^
-      DO ikl=1,knonv
-      DO   isl=-nsol+1,min(nsno-1,isnoSV(ikl)+1)
-
-          Elem_A          =  dtC_sv(ikl,isl)         *mu__dz(ikl,isl)
-          Elem_C          =  dtC_sv(ikl,isl)         *mu__dz(ikl,isl+1)
-          Diag_A(ikl,isl) = -Elem_A  *Implic
-          Diag_C(ikl,isl) = -Elem_C  *Implic
-          Diag_B(ikl,isl) =  1.0d+0  -Diag_A(ikl,isl)-Diag_C(ikl,isl)
-          Term_D(ikl,isl) =  Explic *(Elem_A         *TsisSV(ikl,isl-1)
-     .                               +Elem_C         *TsisSV(ikl,isl+1))
-     .             +(1.0d+0 -Explic *(Elem_A+Elem_C))*TsisSV(ikl,isl)
-     .  + dtC_sv(ikl,isl)           * sol_SV(ikl)    *SoSosv(ikl)
-     .                                               *(sEX_sv(ikl,isl+1)
-     .                                               -sEX_sv(ikl,isl  ))
-        END DO
-      END DO
- 
-C +--Soil  lowest Layer
-C +  ^^^^^^^^^^^^^^^^^^
-           isl= -nsol
-        DO ikl=1,knonv
-          Elem_A          =  0.
-          Elem_C          =  dtC_sv(ikl,isl)         *mu__dz(ikl,isl+1)
-          Diag_A(ikl,isl) =  0.
-          Diag_C(ikl,isl) = -Elem_C  *Implic
-          Diag_B(ikl,isl) =  1.0d+0  -Diag_A(ikl,isl)-Diag_C(ikl,isl)
-          Term_D(ikl,isl) =  Explic * Elem_C         *TsisSV(ikl,isl+1)
-     .             +(1.0d+0 -Explic * Elem_C)        *TsisSV(ikl,isl)
-     .  + dtC_sv(ikl,isl)           * sol_SV(ikl)    *SoSosv(ikl)
-     .                                              *(sEX_sv(ikl,isl+1)
-     .                                               -sEX_sv(ikl,isl  ))
-        END DO
- 
-C +--Snow highest Layer (dummy!)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-        !EV!isl=  min(isnoSV(1)+1,nsno)
-
-        DO ikl=1,knonv
-! EV try to calculate isl at the ikl grid point
-          isl=  min(isnoSV(ikl)+1,nsno)
-
-          Elem_A          =  dtC_sv(ikl,isl)  *mu__dz(ikl,isl)
-          Elem_C          =  0.
-          Diag_A(ikl,isl) = -Elem_A  *Implic
-          Diag_C(ikl,isl) =  0.
-          Diag_B(ikl,isl) =  1.0d+0  -Diag_A(ikl,isl)
-          Term_D(ikl,isl) =  Explic * Elem_A  *TsisSV(ikl,isl-1)
-     .             +(1.0d+0 -Explic * Elem_A) *TsisSV(ikl,isl)
-     .  + dtC_sv(ikl,isl) * (sol_SV(ikl)      *SoSosv(ikl)
-     .                                       *(sEX_sv(ikl,isl+1)
-     .                                        -sEX_sv(ikl,isl  )))
-        END DO
- 
-C +--Surface: UPwardIR Heat Flux
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=1,knonv
-          isl         = isnoSV(ikl)
-          dIRsdT(ikl) = Eso_sv(ikl)* StefBo          * 4.      ! - d(IR)/d(T)
-     .                             * TsisSV(ikl,isl)           !
-     .                             * TsisSV(ikl,isl)           !
-     .                             * TsisSV(ikl,isl)           !
-          IRs__D(ikl) = dIRsdT(ikl)* TsisSV(ikl,isl) * 0.75    !
- 
-C +--Surface: Richardson Number:   T Derivative
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-c #RC     dRidTs(ikl) =-gravit      *    za__SV(ikl)
-c #RC.                /(TaT_SV(ikl) *    VV__SV(ikl)
-c #RC.                              *    VV__SV(ikl))
- 
-C +--Surface: Turbulent Heat Flux: Factors
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          f_HSHL(ikl) = rhT_SV(ikl)  /    rah_sv(ikl)           ! to  HS, HL
-          f___HL(ikl) = f_HSHL(ikl) *    Lx_H2O(ikl)
- 
-C +--Surface: Sensible  Heat Flux: T Derivative
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          dSdTSV(ikl) = f_HSHL(ikl) *    Cp                    !#- d(HS)/d(T)
-c #RC.         *(1.0  -(TsisSV(ikl,isl) -TaT_SV(ikl))          !#Richardson
-c #RC.         * dRidTs(ikl)*dFh_sv(ikl)/rah_sv(ikl))          ! Nb. Correct.
-          HS___D(ikl) = dSdTSV(ikl) *    TaT_SV(ikl)           !
- 
-C +--Surface: Latent    Heat Flux: Saturation Specific Humidity
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-c         den_qs      =         TsisSV(ikl,isl)- 35.8          !
-c         arg_qs      = 17.27 *(TsisSV(ikl,isl)-273.16)        !
-c    .                                   / den_qs              !
-c         qsatsg(ikl) = .0038 *        exp(arg_qs)             !
-!          sp = (pst_SV(ikl) + ptopSV) * 10.
-
-          !sp=ps__SV(ikl)
-          ! Etienne: in the formula herebelow sp should be in hPa, not
-          ! in Pa so I divide by 100.
-          sp=ps__SV(ikl)/100.
-          psat_ice = 6.1070 * exp(6150. *(1./273.16 -
-     .                                              1./TsisSV(ikl,isl)))
-
-          psat_wat = 6.1078 * exp (5.138*log(273.16   /TsisSV(ikl,isl)))
-     .             * exp (6827.*(1.         /273.16-1./TsisSV(ikl,isl)))
-
-          if(TsisSV(ikl,isl)<=273.16) then
-            qsatsg(ikl) = 0.622 * psat_ice / (sp - 0.378 * psat_ice)
-          else
-            qsatsg(ikl) = 0.622 * psat_wat / (sp - 0.378 * psat_wat)
-          endif
-          QsT_SV(ikl)=qsatsg(ikl)
-
-c         dqs_dT(ikl) = qsatsg(ikl)* 4099.2   /(den_qs *den_qs)!
-          fac_dt(ikl) = f_HSHL(ikl)/(ro_Wat   * dz_dSV(0))     !
-        END DO
-
-
- 
-C +--Surface: Latent    Heat Flux: Surface    Relative Humidity
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-              xgpsrf       =   1.05                            !
-              agpsrf       = dt__SV*(   1.0-xgpsrf        )    !
-     .                             /(   1.0-xgpsrf**nt_srf)    !
-              dt_srf       = agpsrf                            !
-              dt_ver       = 0.                
-
-            DO ikl=1,knonv
-              isl          =          isnoSV(ikl)              
-              ist          = max(0,isotSV(ikl)-100*isnoSV(ikl))! 0 if    H2O                          
-              ist__s       = min(1,ist)                                                                             
-              etaBAK(ikl)  = max(epsi,eta_SV(ikl ,isl))        !
-              etaNEW(ikl)  =          etaBAK(ikl)              !
-              etEuBk(ikl)  =          etaNEW(ikl)              !
-            END DO      
-
-        if(ist__s==1) then ! to reduce computer time                                                  
-
-        DO it_srf=1,nt_srf                                     !
-              dt_ver       = dt_ver     +dt_srf                !
-            DO ikl=1,knonv                                     !
-              faceta(ikl)  = fac_dt(ikl)*dt_srf                !
-c #VX         faceta(ikl)  = faceta(ikl)                       !
-c #VX.                  /(1.+faceta(ikl)*dQa_SV(ikl))          !    Limitation
-                                                               ! by Atm.Conten
-c #??.        *max(0,sign(1.,qsatsg(ikl)-QaT_SV(ikl))))        ! NO Limitation
-                                                               ! of Downw.Flux
-            END DO                                             !
-          DO itEuBk=1,2                                        !
-            DO ikl=1,knonv
-              ist    = max(0,isotSV(ikl)-100*isnoSV(ikl))      ! 0 if    H2O
-
-              Psi(ikl) =                                       !
-     .                psidSV(ist)                              ! DR97, Eqn 3.34
-     .              *(etadSV(ist)                              !
-     .           /max(etEuBk(ikl),epsi))                       !
-     .              **bCHdSV(ist)                              !
-              PsiArg(ikl) = 7.2E-5*Psi(ikl)                    !
-              RHuSol(ikl) =   exp(-min(0.,PsiArg(ikl)))    !
-              SHuSol(ikl) =     qsatsg(ikl)  *RHuSol(ikl)      ! DR97, Eqn 3.15
-              etEuBk(ikl) =                                    !
-     .       (etaNEW(ikl) + faceta(ikl)*(QaT_SV(ikl)           !
-     .                                  -SHuSol(ikl)           !
-     .                    *(1.          -bCHdSV(ist)           !
-     .                                  *PsiArg(ikl))       )) !
-     .      /(1.          + faceta(ikl)* SHuSol(ikl)           !
-     .                                  *bCHdSV(ist)           !
-     .                                  *PsiArg(ikl)           !
-     .                                  /etaNEW(ikl))          !
-              etEuBk(ikl) = etEuBk(ikl)          !
-c    .                                 /(Ro_Wat*dz_dSV(0))     !
-     .                    * dt_srf     /(Ro_Wat*dz_dSV(0))     !
-cXF 15/05/2017 BUG
-            END DO                                             !
-          END DO                                               !
-            DO ikl=1,knonv                                     !
-              etaNEW(ikl) =  max(etEuBk(ikl),epsi)             !
-            END DO                                             !
-              dt_srf      =      dt_srf         * xgpsrf       !
-        END DO          
-
-
-        endif                                       !
- 
-C +--Surface: Latent    Heat Flux: Soil/Water Surface Contributions
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=1,knonv                                         !
-          isl        =  isnoSV(ikl)                            !
-          ist   = max(0,isotSV(ikl)-100*isnoSV(ikl))           ! 0 if    H2O
-          ist__s= min(1,ist)                                   ! 1 if no H2O
-          ist__w=     1-ist__s                                 ! 1 if    H2O
-          d__eta     =  eta_SV(ikl,isl)-etaNEW(ikl)            !
-          ! latent heat flux computation
-          HL___D(ikl)=( ist__s *ro_Wat *dz_dSV(0)              ! Soil Contrib.
-     .                *(etaNEW(ikl)    -etaBAK(ikl)) / dt__SV  !
-     .                 +ist__w         *f_HSHL(ikl)            ! H2O  Contrib.
-     .                *(QaT_SV(ikl)    - qsatsg(ikl))        ) !
-     .                * Lx_H2O(ikl)                            ! common factor
- 
-c #DL     RHuSol(ikl) =(QaT_SV(ikl)                            !
-c #DL.                 -HL___D(ikl)    / f___HL(ikl))          !
-c #DL.                / qsatsg(ikl)                            !
- 
-C +--Surface: Latent    Heat Flux: T Derivative
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          dLdTSV(ikl) = 0.
-c #DL     dLdTSV(ikl) = f___HL(ikl) * RHuSol(ikl) *dqs_dT(ikl) ! - d(HL)/d(T)
-c #DL     HL___D(ikl) = HL___D(ikl)                            !
-c #DL.                 +dLdTSV(ikl) * TsisSV(ikl,isl)          !
-        END DO                                                 !
- 
-C +--Surface: Tridiagonal Matrix Set Up
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=1,knonv
-          isl             =  isnoSV(ikl)
-          TSurf0(ikl)     =  TsisSV(ikl,isl)
-
-          Elem_A          =  dtC_sv(ikl,isl)*mu__dz(ikl,isl)
-          Elem_C          =  0.
-          Diag_A(ikl,isl) = -Elem_A *Implic
-          Diag_C(ikl,isl) =  0.
-          Diag_B(ikl,isl) =  1.0d+0 -Diag_A(ikl,isl)
-          Diag_B(ikl,isl) =  Diag_B(ikl,isl)
-     .  + dtC_sv(ikl,isl) * (dIRsdT(ikl)                       ! Upw. Sol IR
-     .                      +dSdTSV(ikl)                       ! HS/Surf.Contr.
-     .                      +dLdTSV(ikl))                      ! HL/Surf.Contr.
-
-          Term_D(ikl,isl) =  Explic *Elem_A *TsisSV(ikl,isl-1)
-     .             +(1.0d+0 -Explic *Elem_A)*TsisSV(ikl,isl)
-
-
-
-          Term_D(ikl,isl) =  Term_D(ikl,isl)
-     .  + dtC_sv(ikl,isl) * (sol_SV(ikl)    *SoSosv(ikl)       ! Absorbed
-     .                                     *(sEX_sv(ikl,isl+1) ! Solar
-     .                                      -sEX_sv(ikl,isl  ))!
-     .                              +   IRd_SV(ikl)*Eso_sv(ikl) ! Down Atm IR
-     .                                +IRs__D(ikl)             ! Upw. Sol IR
-     .                                +HS___D(ikl)             ! HS/Atmo.Contr.
-     .                                +HL___D(ikl)            )! HL/Atmo.Contr.
-     
-        END DO
- 
- 
-C +--Tridiagonal Elimination
-C +  =======================
- 
-C +--Forward  Sweep
-C +  ^^^^^^^^^^^^^^
-        DO ikl=  1,knonv
-          Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol)
-          Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol)
-        END DO
- 
-        DO ikl=      1,knonv
-
-        DO   isl=-nsol+1,min(nsno,isnoSV(ikl)+1)
-          Aux__P(ikl,isl)   = Diag_A(ikl,isl)  *Aux__Q(ikl,isl-1)
-     .                       +Diag_B(ikl,isl)
-          Aux__Q(ikl,isl)   =-Diag_C(ikl,isl)  /Aux__P(ikl,isl)
-        END DO
-        END DO
- 
-        DO ikl=      1,knonv
-          TsisSV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol)
-        END DO
- 
-        DO ikl=      1,knonv
-        DO   isl=-nsol+1,min(nsno,isnoSV(ikl)+1)
-          TsisSV(ikl,isl)   =(Term_D(ikl,isl)
-     .                       -Diag_A(ikl,isl)  *TsisSV(ikl,isl-1))
-     .                                         /Aux__P(ikl,isl)
-
-  
-        END DO
-        END DO
- 
-C +--Backward Sweep
-C +  ^^^^^^^^^^^^^^
-        DO ikl=     1,knonv
-        DO   isl=min(nsno-1,isnoSV(ikl)+1),-nsol,-1
-           
-
-          TsisSV(ikl,isl)   = Aux__Q(ikl,isl)  *TsisSV(ikl,isl+1)
-     .                                         +TsisSV(ikl,isl)
-          if(isl==0.and.isnoSV(ikl)==0) then
- 
-           TsisSV(ikl,isl)  = min(TaT_SV(ikl)+30,TsisSV(ikl,isl))
-           TsisSV(ikl,isl)  = max(TaT_SV(ikl)-30,TsisSV(ikl,isl))
-
-
-c #EU      TsisSV(ikl,isl)  = max(TaT_SV(ikl)-15.,TsisSV(ikl,isl))
-
-          !XF 18/11/2018 to avoid ST reaching 70°C!!
-          !It is an error compensation but does not work over tundra
- 
-          endif
-
-   
-
-        END DO
-       
-      END DO
-
-
- 
-C +--Temperature Limits (avoids problems in case of no Snow Layers)
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=     1,knonv
-           isl              = isnoSV(ikl)
-
-           dTSurf            = TsisSV(ikl,isl) -     TSurf0(ikl)
-          TsisSV(ikl,isl)   = TSurf0(ikl) + sign(1.,dTSurf) ! 180.0 dgC/hr
-     .              * min(abs(dTSurf),5.e-2*dt__SV)         ! =0.05 dgC/s
-
-
-
-        END DO
-
-        DO ikl=     1,knonv
-        DO   isl=min(nsno,isnoSV(ikl)+1),1      ,-1
-          TsisSV(ikl,isl)   = max(Ts_Min,       TsisSV(ikl,isl))
-          TsisSV(ikl,isl)   = min(Ts_Max,       TsisSV(ikl,isl))
-        END DO
-
-        END DO
- 
-C +--Update Surface    Fluxes
-C +  ========================
-        
-
-
-        DO ikl=      1,knonv
-          isl         = isnoSV(ikl)
-          IRs_SV(ikl) = IRs__D(ikl)                          !
-     .                - dIRsdT(ikl) * TsisSV(ikl,isl)        !
-          HSs_sv(ikl) = HS___D(ikl)                          ! Sensible Heat
-     .                - dSdTSV(ikl) * TsisSV(ikl,isl)        ! Downward > 0
-          HLs_sv(ikl) = HL___D(ikl)                          ! Latent   Heat
-     .                - dLdTSV(ikl) * TsisSV(ikl,isl)        ! Downward > 0
-        END DO
-
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_tso.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_tso.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_tso.f90	(revision 5105)
@@ -0,0 +1,675 @@
+
+
+
+
+SUBROUTINE SISVAT_TSo
+  ! #e1.                     (ETSo_0,ETSo_1,ETSo_d)
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_TSo                                06-10-2020  MAR |
+  ! |   SubRoutine SISVAT_TSo computes the Soil/Snow Energy Balance          |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT:   isotSV   = 0,...,11:   Soil       Type                      |
+  ! |   ^^^^^               0:          Water, Solid or Liquid               |
+  ! |            isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |            dQa_SV   = Limitation of  Water Vapor  Turbulent Flux       |
+  ! |                                                                        |
+  ! |   INPUT:   sol_SV   : Downward Solar Radiation                  [W/m2] |
+  ! |   ^^^^^    IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
+  ! |            za__SV   : SBL Top    Height                            [m] |
+  ! |            VV__SV   : SBL Top    Wind Speed                      [m/s] |
+  ! |            TaT_SV   : SBL Top    Temperature                       [K] |
+  ! |            rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
+  ! |            QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
+  ! |            LSdzsv   : Vertical   Discretization Factor             [-] |
+  ! |                     =    1. Soil                                       |
+  ! |                     = 1000. Ocean                                      |
+  ! |            dzsnSV   : Snow Layer Thickness                         [m] |
+  ! |            ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
+  ! |            eta_SV   : Soil Water Content                       [m3/m3] |
+  ! |            dt__SV   : Time Step                                    [s] |
+  ! |                                                                        |
+  ! |            SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
+  ! |            Eso_sv   : Soil+Snow       Emissivity                   [-] |
+  ! |            rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
+  ! |            Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
+  ! |            sEX_sv   : Verticaly Integrated Extinction Coefficient  [-] |
+  ! |                                                                        |
+  ! |   INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+  ! |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  ! |   ^^^^^^                                                               |
+  ! |                                                                        |
+  ! |   OUTPUT:  IRs_SV   : Soil      IR Radiation                    [W/m2] |
+  ! |   ^^^^^^   HSs_sv   : Sensible  Heat Flux                       [W/m2] |
+  ! |            HLs_sv   : Latent    Heat Flux                       [W/m2] |
+  ! |            ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
+  ! |            ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
+  ! |            ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
+  ! |                                                                        |
+  ! |   Internal Variables:                                                  |
+  ! |   ^^^^^^^^^^^^^^^^^^                                                   |
+  ! |                                                                        |
+  ! |   METHOD: NO   Skin Surface Temperature                                |
+  ! |   ^^^^^^  Semi-Implicit Crank Nicholson Scheme                         |
+  ! |                                                                        |
+  ! | # OPTIONS: #E0: Energy Budget Verification                             |
+  ! | # ^^^^^^^  #kd: KDsvat Option:NO Flux  Limitor     on HL               |
+  ! | #          #KD: KDsvat Option:Explicit Formulation of HL               |
+  ! | #          #NC: OUTPUT for Stand Alone NetCDF File                     |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VARxSV
+  use VARySV
+  use VARtSV
+  use VAR0SV
+
+
+  IMPLICIT NONE
+
+
+  ! +--OUTPUT
+  ! +  ------
+
+  ! #e1 real      ETSo_0(knonv)                 ! Soil/Snow Power, before Forcing
+  ! #e1 real      ETSo_1(knonv)                 ! Soil/Snow Power, after  Forcing
+  ! #e1 real      ETSo_d(knonv)                 ! Soil/Snow Power, Forcing
+
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  integer :: ikl   ,isl   ,jsl   ,ist      !
+  integer :: ist__s,ist__w                 ! Soil/Water  Body Identifier
+  integer :: islsgn                        ! Soil/Snow Surfac.Identifier
+  real :: eps__3                        ! Arbitrary    Low Number
+  real :: etaMid,psiMid                 ! Layer Interface's Humidity
+  real :: mu_eta                        !     Soil thermal Conductivity
+  real :: mu_exp                        ! arg Soil thermal Conductivity
+  real :: mu_min                        ! Min Soil thermal Conductivity
+  real :: mu_max                        ! Max Soil thermal Conductivity
+  real :: mu_sno(knonv),mu_aux          !     Snow thermal Conductivity
+  real :: mu__dz(knonv,-nsol:nsno+1)    ! mu_(eta,sno)   / dz
+  real :: dtC_sv(knonv,-nsol:nsno)      ! dt      / C
+  real :: IRs__D(knonv)                 ! UpwardIR Previous Iter.Contr.
+  real :: dIRsdT(knonv)                 ! UpwardIR           T Derivat.
+  real :: f_HSHL(knonv)                 ! Factor common to HS and HL
+  real :: dRidTs(knonv)                 ! d(Rib)/d(Ts)
+  real :: HS___D(knonv)                 ! Sensible Heat Flux Atm.Contr.
+  real :: f___HL(knonv)                 !
+  real :: HL___D(knonv)                 ! Latent   Heat Flux Atm.Contr.
+  REAL :: TSurf0(knonv),dTSurf          ! Previous Surface Temperature
+  real :: qsatsg(knonv) !,den_qs,arg_qs ! Soil   Saturat. Spec. Humidity
+  real :: dqs_dT(knonv)                 ! d(qsatsg)/dTv
+  real :: Psi(   knonv)                 ! 1st Soil Layer Water Potential
+  real :: RHuSol(knonv)                 ! Soil Surface Relative Humidity
+  real :: etaSol                        ! Soil Surface          Humidity
+  real :: d__eta                        ! Soil Surface Humidity Increm.
+  real :: Elem_A,Elem_C                 !   Diagonal Coefficients
+  real :: Diag_A(knonv,-nsol:nsno)      ! A Diagonal
+  real :: Diag_B(knonv,-nsol:nsno)      ! B Diagonal
+  real :: Diag_C(knonv,-nsol:nsno)      ! C Diagonal
+  real :: Term_D(knonv,-nsol:nsno)      !   Independant Term
+  real :: Aux__P(knonv,-nsol:nsno)      ! P Auxiliary Variable
+  real :: Aux__Q(knonv,-nsol:nsno)      ! Q Auxiliary Variable
+  real :: Ts_Min,Ts_Max                 ! Temperature Limits
+  ! #e1 real      Exist0                        ! Existing Layer Switch
+  real :: psat_wat, psat_ice, sp        ! computation of qsat
+
+  integer :: nt_srf,it_srf,itEuBk          ! HL: Surface Scheme
+  parameter(nt_srf=10)                     ! 10 before
+  real :: agpsrf,xgpsrf,dt_srf,dt_ver   !
+  real :: etaBAK(knonv)                 !
+  real :: etaNEW(knonv)                 !
+  real :: etEuBk(knonv)                 !
+  real :: fac_dt(knonv),faceta(knonv)   !
+  real :: PsiArg(knonv),SHuSol(knonv)   !
+
+
+
+  ! +--Internal DATA
+  ! +  =============
+
+  data      eps__3 /   1.e-3   /          ! Arbitrary    Low Number
+  data      mu_exp /  -0.4343  /          ! Soil Thermal Conductivity
+  data      mu_min /   0.172   /          ! Min Soil Thermal Conductivity
+  data      mu_max /   2.000   /          ! Max Soil Thermal Conductivity
+  data      Ts_Min / 175.      /          ! Temperature            Minimum
+  data      Ts_Max / 300.      /          ! Temperature Acceptable Maximum
+  ! +                                           ! including   Snow Melt  Energy
+
+  ! +-- Initilialisation of local arrays
+  ! +   ================================
+    DO ikl=1,knonv
+
+      mu_sno(ikl)=0.
+      mu__dz(ikl,:)=0.
+      dtC_sv(ikl,:)=0.
+      IRs__D(ikl)=0.
+      dIRsdT(ikl)=0.
+      f_HSHL(ikl)=0.
+      dRidTs(ikl)=0.
+      HS___D(ikl)=0.
+      f___HL(ikl)=0.
+      HL___D(ikl)=0.
+      TSurf0(ikl)=0.
+      qsatsg(ikl)=0.
+      dqs_dT(ikl)=0.
+      Psi(ikl)=0.
+      RHuSol(ikl)=0.
+      Diag_A(ikl,:)=0.
+      Diag_B(ikl,:)=0.
+      Diag_C(ikl,:)=0.
+      Term_D(ikl,:)=0.
+      Aux__P(ikl,:)=0.
+      Aux__Q(ikl,:)=0.
+      etaBAK(ikl)=0.
+      etaNEW(ikl)=0.
+      etEuBk(ikl)=0.
+      fac_dt(ikl)=0.
+      faceta(ikl)=0.
+      PsiArg(ikl)=0.
+      SHuSol(ikl)=0.
+
+    END DO
+
+
+
+  ! +--Heat Conduction Coefficient (zero in the Layers over the highest one)
+  ! +  ===========================
+  ! +                             ---------------- isl    eta_SV, rho C (isl)
+  ! +
+  ! +--Soil                       ++++++++++++++++        etaMid,    mu (isl)
+  ! +  ----
+  ! +                             ---------------- isl-1  eta_SV, rho C (isl-1)
+       isl=-nsol
+    DO ikl=1,knonv
+
+      mu__dz(ikl,isl) = 0.
+
+      dtC_sv(ikl,isl) = dtz_SV2(isl)  * dt__SV & ! dt / (dz X rho C)
+            /((rocsSV(isotSV(ikl)) & ! [s / (m.J/m3/K)]
+            +rcwdSV*eta_SV(ikl,isl)) & !
+            *LSdzsv(ikl)            )      !
+    END DO
+  DO   isl=-nsol+1,0
+    DO ikl=1,knonv
+      ist    =      isotSV(ikl)                       ! Soil Type
+      ist__s =  min(ist, 1)                           ! 1 => Soil
+      ist__w =  1 - ist__s                            ! 1 => Water Body
+
+      etaMid = 0.5*(dz_dSV(isl-1)*eta_SV(ikl,isl-1) & ! eta at layers
+            +dz_dSV(isl)  *eta_SV(ikl,isl)  ) & !     interface
+            /dzmiSV(isl)                       ! LSdzsv implicit !
+      etaMid =  max(etaMid,epsi)
+      psiMid =      psidSV(ist) &
+            *(etadSV(ist)/etaMid)**bCHdSV(ist)
+      mu_eta =      3.82      *(psiMid)**mu_exp       ! Soil Thermal
+      mu_eta =  min(max(mu_eta, mu_min), mu_max)      ! Conductivity
+  ! +                                                       ! DR97 eq.3.31
+      mu_eta =  ist__s *mu_eta +ist__w * vK_dSV       ! Water Bodies
+  ! +                                                       ! Correction
+      mu__dz(ikl,isl) = mu_eta/(dzmiSV(isl) & !
+            *LSdzsv(ikl))          !
+
+      dtC_sv(ikl,isl) = dtz_SV2(isl)* dt__SV & ! dt / (dz X rho C)
+            /((rocsSV(isotSV(ikl)) & !
+            +rcwdSV*eta_SV(ikl,isl)) & !
+            *LSdzsv(ikl)            )      !
+    END DO
+  END DO
+
+
+  ! +--Soil/Snow Interface
+  ! +  -------------------
+
+  ! +--Soil Contribution
+  ! +  ^^^^^^^^^^^^^^^^^
+       isl=1
+    DO ikl=1,knonv
+      ist    =      isotSV(ikl)                       ! Soil Type
+      ist__s =  min(ist, 1)                           ! 1 => Soil
+      ist__w =  1 - ist__s                            ! 1 => Water Body
+      psiMid =      psidSV(ist)                       ! Snow => Saturation
+      mu_eta =      3.82      *(psiMid)**mu_exp       ! Soil Thermal
+      mu_eta =  min(max(mu_eta, mu_min), mu_max)      ! Conductivity
+  ! +                                                       ! DR97 eq.3.31
+      mu_eta =  ist__s *mu_eta +ist__w * vK_dSV       ! Water Bodies
+
+  ! +--Snow Contribution
+  ! +  ^^^^^^^^^^^^^^^^^
+      mu_sno(ikl) =  CdidSV & !
+            *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 !
+      mu_sno(ikl) =          max(epsi,mu_sno(ikl))    !
+  ! +...    mu_sno :  Snow Heat Conductivity Coefficient [Wm/K]
+  ! +                 (Yen 1981, CRREL Rep., 81-10)
+
+  ! +--Combined Heat Conductivity
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+      mu__dz(ikl,isl) = 2./(dzsnSV(ikl,isl  ) & ! Combined Heat
+            /mu_sno(ikl) & ! Conductivity
+            +LSdzsv(ikl) & !
+            *dz_dSV(    isl-1)/mu_eta) ! Coefficient
+
+  ! +--Inverted Heat Capacity
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^
+      dtC_sv(ikl,isl) = dt__SV/max(epsi, & ! dt / (dz X rho C)
+            dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV)      !
+    END DO
+
+
+  ! +--Snow
+  ! +  ----
+
+  DO ikl=1,knonv
+  DO   isl=1,min(nsno,isnoSV(ikl)+1)
+      ro__SV(ikl,isl) = & !
+            ro__SV(ikl ,isl) & !
+            * max(0,min(isnoSV(ikl)-isl+1,1))            !
+
+    END DO
+  END DO
+
+  DO ikl=1,knonv
+  DO   isl=1,min(nsno,isnoSV(ikl)+1)
+
+  ! +--Combined Heat Conductivity
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+      mu_aux      =  CdidSV & !
+            *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 !
+      mu__dz(ikl,isl) = & !
+            2.                        *mu_aux*mu_sno(ikl) & ! Combined Heat
+            /max(epsi,dzsnSV(ikl,isl  )*mu_sno(ikl) & ! Conductivity
+            +dzsnSV(ikl,isl-1)*mu_aux     )       ! For upper Layer
+      mu_sno(ikl)     =            mu_aux             !
+
+  ! +--Inverted Heat Capacity
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^
+      dtC_sv(ikl,isl) = dt__SV/max(eps__3, & ! dt / (dz X rho C)
+            dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV)      !
+    END DO
+  END DO
+
+
+  ! +--Uppermost Effective Layer: NO conduction
+  ! +  ----------------------------------------
+
+    DO ikl=1,knonv
+      mu__dz(ikl,isnoSV(ikl)+1) = 0.0
+    END DO
+
+
+  ! +--Energy Budget (IN)
+  ! +  ==================
+
+  ! #e1   DO ikl=1,knonv
+  ! #e1     ETSo_0(ikl) = 0.
+  ! #e1   END DO
+  ! #e1 DO   isl= -nsol,nsno
+  ! #e1   DO ikl=1,knonv
+  ! #e1     Exist0      = isl -           isnoSV(ikl)
+  ! #e1     Exist0      = 1.  - max(zero,min(unun,Exist0))
+  ! #e1     ETSo_0(ikl) = ETSo_0(ikl)
+  ! #e1.                +(TsisSV(ikl,isl)-TfSnow)*Exist0
+  ! #e1.                                 /dtC_sv(ikl,isl)
+  ! #e1   END DO
+  ! #e1 END DO
+
+
+  ! +--Tridiagonal Elimination: Set Up
+  ! +  ===============================
+
+  ! +--Soil/Snow Interior
+  ! +  ^^^^^^^^^^^^^^^^^^
+  DO ikl=1,knonv
+  DO   isl=-nsol+1,min(nsno-1,isnoSV(ikl)+1)
+
+      Elem_A          =  dtC_sv(ikl,isl)         *mu__dz(ikl,isl)
+      Elem_C          =  dtC_sv(ikl,isl)         *mu__dz(ikl,isl+1)
+      Diag_A(ikl,isl) = -Elem_A  *Implic
+      Diag_C(ikl,isl) = -Elem_C  *Implic
+      Diag_B(ikl,isl) =  1.0d+0  -Diag_A(ikl,isl)-Diag_C(ikl,isl)
+      Term_D(ikl,isl) =  Explic *(Elem_A         *TsisSV(ikl,isl-1) &
+            +Elem_C         *TsisSV(ikl,isl+1)) &
+            +(1.0d+0 -Explic *(Elem_A+Elem_C))*TsisSV(ikl,isl) &
+            + dtC_sv(ikl,isl)           * sol_SV(ikl)    *SoSosv(ikl) &
+            *(sEX_sv(ikl,isl+1) &
+            -sEX_sv(ikl,isl  ))
+    END DO
+  END DO
+
+  ! +--Soil  lowest Layer
+  ! +  ^^^^^^^^^^^^^^^^^^
+       isl= -nsol
+    DO ikl=1,knonv
+      Elem_A          =  0.
+      Elem_C          =  dtC_sv(ikl,isl)         *mu__dz(ikl,isl+1)
+      Diag_A(ikl,isl) =  0.
+      Diag_C(ikl,isl) = -Elem_C  *Implic
+      Diag_B(ikl,isl) =  1.0d+0  -Diag_A(ikl,isl)-Diag_C(ikl,isl)
+      Term_D(ikl,isl) =  Explic * Elem_C         *TsisSV(ikl,isl+1) &
+            +(1.0d+0 -Explic * Elem_C)        *TsisSV(ikl,isl) &
+            + dtC_sv(ikl,isl)           * sol_SV(ikl)    *SoSosv(ikl) &
+            *(sEX_sv(ikl,isl+1) &
+            -sEX_sv(ikl,isl  ))
+    END DO
+
+  ! +--Snow highest Layer (dummy!)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+    ! !EV!isl=  min(isnoSV(1)+1,nsno)
+
+    DO ikl=1,knonv
+  ! EV try to calculate isl at the ikl grid point
+      isl=  min(isnoSV(ikl)+1,nsno)
+
+      Elem_A          =  dtC_sv(ikl,isl)  *mu__dz(ikl,isl)
+      Elem_C          =  0.
+      Diag_A(ikl,isl) = -Elem_A  *Implic
+      Diag_C(ikl,isl) =  0.
+      Diag_B(ikl,isl) =  1.0d+0  -Diag_A(ikl,isl)
+      Term_D(ikl,isl) =  Explic * Elem_A  *TsisSV(ikl,isl-1) &
+            +(1.0d+0 -Explic * Elem_A) *TsisSV(ikl,isl) &
+            + dtC_sv(ikl,isl) * (sol_SV(ikl)      *SoSosv(ikl) &
+            *(sEX_sv(ikl,isl+1) &
+            -sEX_sv(ikl,isl  )))
+    END DO
+
+  ! +--Surface: UPwardIR Heat Flux
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=1,knonv
+      isl         = isnoSV(ikl)
+      dIRsdT(ikl) = Eso_sv(ikl)* StefBo          * 4. & ! - d(IR)/d(T)
+            * TsisSV(ikl,isl) & !
+            * TsisSV(ikl,isl) & !
+            * TsisSV(ikl,isl)           !
+      IRs__D(ikl) = dIRsdT(ikl)* TsisSV(ikl,isl) * 0.75    !
+
+  ! +--Surface: Richardson Number:   T Derivative
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  ! #RC     dRidTs(ikl) =-gravit      *    za__SV(ikl)
+  ! #RC.                /(TaT_SV(ikl) *    VV__SV(ikl)
+  ! #RC.                              *    VV__SV(ikl))
+
+  ! +--Surface: Turbulent Heat Flux: Factors
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      f_HSHL(ikl) = rhT_SV(ikl)  /    rah_sv(ikl)           ! to  HS, HL
+      f___HL(ikl) = f_HSHL(ikl) *    Lx_H2O(ikl)
+
+  ! +--Surface: Sensible  Heat Flux: T Derivative
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      dSdTSV(ikl) = f_HSHL(ikl) *    Cp                    !#- d(HS)/d(T)
+  ! #RC.         *(1.0  -(TsisSV(ikl,isl) -TaT_SV(ikl))          !#Richardson
+  ! #RC.         * dRidTs(ikl)*dFh_sv(ikl)/rah_sv(ikl))          ! Nb. Correct.
+      HS___D(ikl) = dSdTSV(ikl) *    TaT_SV(ikl)           !
+
+  ! +--Surface: Latent    Heat Flux: Saturation Specific Humidity
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      ! den_qs      =         TsisSV(ikl,isl)- 35.8          !
+      ! arg_qs      = 17.27 *(TsisSV(ikl,isl)-273.16)        !
+  !    .                                   / den_qs              !
+  !         qsatsg(ikl) = .0038 *        exp(arg_qs)             !
+      !  sp = (pst_SV(ikl) + ptopSV) * 10.
+
+      ! !sp=ps__SV(ikl)
+      ! ! Etienne: in the formula herebelow sp should be in hPa, not
+      ! ! in Pa so I divide by 100.
+      sp=ps__SV(ikl)/100.
+      psat_ice = 6.1070 * exp(6150. *(1./273.16 - &
+            1./TsisSV(ikl,isl)))
+
+      psat_wat = 6.1078 * exp (5.138*log(273.16   /TsisSV(ikl,isl))) &
+            * exp (6827.*(1.         /273.16-1./TsisSV(ikl,isl)))
+
+      if(TsisSV(ikl,isl)<=273.16) then
+        qsatsg(ikl) = 0.622 * psat_ice / (sp - 0.378 * psat_ice)
+      else
+        qsatsg(ikl) = 0.622 * psat_wat / (sp - 0.378 * psat_wat)
+      endif
+      QsT_SV(ikl)=qsatsg(ikl)
+
+      ! dqs_dT(ikl) = qsatsg(ikl)* 4099.2   /(den_qs *den_qs)!
+      fac_dt(ikl) = f_HSHL(ikl)/(ro_Wat   * dz_dSV(0))     !
+    END DO
+
+
+
+  ! +--Surface: Latent    Heat Flux: Surface    Relative Humidity
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+          xgpsrf       =   1.05                            !
+          agpsrf       = dt__SV*(   1.0-xgpsrf        ) & !
+                /(   1.0-xgpsrf**nt_srf)    !
+          dt_srf       = agpsrf                            !
+          dt_ver       = 0.
+
+        DO ikl=1,knonv
+          isl          =          isnoSV(ikl)
+          ist          = max(0,isotSV(ikl)-100*isnoSV(ikl))! 0 if    H2O
+          ist__s       = min(1,ist)
+          etaBAK(ikl)  = max(epsi,eta_SV(ikl ,isl))        !
+          etaNEW(ikl)  =          etaBAK(ikl)              !
+          etEuBk(ikl)  =          etaNEW(ikl)              !
+        END DO
+
+    if(ist__s==1) then ! to reduce computer time
+
+    DO it_srf=1,nt_srf                                     !
+          dt_ver       = dt_ver     +dt_srf                !
+        DO ikl=1,knonv                                     !
+          faceta(ikl)  = fac_dt(ikl)*dt_srf                !
+  ! #VX         faceta(ikl)  = faceta(ikl)                       !
+  ! #VX.                  /(1.+faceta(ikl)*dQa_SV(ikl))          !    Limitation
+  !                                                              ! by Atm.Conten
+  ! #??.        *max(0,sign(1.,qsatsg(ikl)-QaT_SV(ikl))))        ! NO Limitation
+                                                           ! ! of Downw.Flux
+        END DO                                             !
+      DO itEuBk=1,2                                        !
+        DO ikl=1,knonv
+          ist    = max(0,isotSV(ikl)-100*isnoSV(ikl))      ! 0 if    H2O
+
+          Psi(ikl) = & !
+                psidSV(ist) & ! DR97, Eqn 3.34
+                *(etadSV(ist) & !
+                /max(etEuBk(ikl),epsi)) & !
+                **bCHdSV(ist)                              !
+          PsiArg(ikl) = 7.2E-5*Psi(ikl)                    !
+          RHuSol(ikl) =   exp(-min(0.,PsiArg(ikl)))    !
+          SHuSol(ikl) =     qsatsg(ikl)  *RHuSol(ikl)      ! DR97, Eqn 3.15
+          etEuBk(ikl) = & !
+                (etaNEW(ikl) + faceta(ikl)*(QaT_SV(ikl) & !
+                -SHuSol(ikl) & !
+                *(1.          -bCHdSV(ist) & !
+                *PsiArg(ikl))       )) & !
+                /(1.          + faceta(ikl)* SHuSol(ikl) & !
+                *bCHdSV(ist) & !
+                *PsiArg(ikl) & !
+                /etaNEW(ikl))          !
+          etEuBk(ikl) = etEuBk(ikl) & !
+  !    .                                 /(Ro_Wat*dz_dSV(0))     !
+                * dt_srf     /(Ro_Wat*dz_dSV(0))     !
+  !XF 15/05/2017 BUG
+        END DO                                             !
+      END DO                                               !
+        DO ikl=1,knonv                                     !
+          etaNEW(ikl) =  max(etEuBk(ikl),epsi)             !
+        END DO                                             !
+          dt_srf      =      dt_srf         * xgpsrf       !
+    END DO
+
+
+    endif                                       !
+
+  ! +--Surface: Latent    Heat Flux: Soil/Water Surface Contributions
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=1,knonv                                         !
+      isl        =  isnoSV(ikl)                            !
+      ist   = max(0,isotSV(ikl)-100*isnoSV(ikl))           ! 0 if    H2O
+      ist__s= min(1,ist)                                   ! 1 if no H2O
+      ist__w=     1-ist__s                                 ! 1 if    H2O
+      d__eta     =  eta_SV(ikl,isl)-etaNEW(ikl)            !
+      ! ! latent heat flux computation
+      HL___D(ikl)=( ist__s *ro_Wat *dz_dSV(0) & ! Soil Contrib.
+            *(etaNEW(ikl)    -etaBAK(ikl)) / dt__SV & !
+            +ist__w         *f_HSHL(ikl) & ! H2O  Contrib.
+            *(QaT_SV(ikl)    - qsatsg(ikl))        ) & !
+            * Lx_H2O(ikl)                            ! common factor
+
+  ! #DL     RHuSol(ikl) =(QaT_SV(ikl)                            !
+  ! #DL.                 -HL___D(ikl)    / f___HL(ikl))          !
+  ! #DL.                / qsatsg(ikl)                            !
+
+  ! +--Surface: Latent    Heat Flux: T Derivative
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      dLdTSV(ikl) = 0.
+  ! #DL     dLdTSV(ikl) = f___HL(ikl) * RHuSol(ikl) *dqs_dT(ikl) ! - d(HL)/d(T)
+  ! #DL     HL___D(ikl) = HL___D(ikl)                            !
+  ! #DL.                 +dLdTSV(ikl) * TsisSV(ikl,isl)          !
+    END DO                                                 !
+
+  ! +--Surface: Tridiagonal Matrix Set Up
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=1,knonv
+      isl             =  isnoSV(ikl)
+      TSurf0(ikl)     =  TsisSV(ikl,isl)
+
+      Elem_A          =  dtC_sv(ikl,isl)*mu__dz(ikl,isl)
+      Elem_C          =  0.
+      Diag_A(ikl,isl) = -Elem_A *Implic
+      Diag_C(ikl,isl) =  0.
+      Diag_B(ikl,isl) =  1.0d+0 -Diag_A(ikl,isl)
+      Diag_B(ikl,isl) =  Diag_B(ikl,isl) &
+            + dtC_sv(ikl,isl) * (dIRsdT(ikl) & ! Upw. Sol IR
+            +dSdTSV(ikl) & ! HS/Surf.Contr.
+            +dLdTSV(ikl))                      ! HL/Surf.Contr.
+
+      Term_D(ikl,isl) =  Explic *Elem_A *TsisSV(ikl,isl-1) &
+            +(1.0d+0 -Explic *Elem_A)*TsisSV(ikl,isl)
+
+
+
+      Term_D(ikl,isl) =  Term_D(ikl,isl) &
+            + dtC_sv(ikl,isl) * (sol_SV(ikl)    *SoSosv(ikl) & ! Absorbed
+            *(sEX_sv(ikl,isl+1) & ! Solar
+            -sEX_sv(ikl,isl  )) & !
+            +   IRd_SV(ikl)*Eso_sv(ikl) & ! Down Atm IR
+            +IRs__D(ikl) & ! Upw. Sol IR
+            +HS___D(ikl) & ! HS/Atmo.Contr.
+            +HL___D(ikl)            )! HL/Atmo.Contr.
+
+    END DO
+
+
+  ! +--Tridiagonal Elimination
+  ! +  =======================
+
+  ! +--Forward  Sweep
+  ! +  ^^^^^^^^^^^^^^
+    DO ikl=  1,knonv
+      Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol)
+      Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol)
+    END DO
+
+    DO ikl=      1,knonv
+
+    DO   isl=-nsol+1,min(nsno,isnoSV(ikl)+1)
+      Aux__P(ikl,isl)   = Diag_A(ikl,isl)  *Aux__Q(ikl,isl-1) &
+            +Diag_B(ikl,isl)
+      Aux__Q(ikl,isl)   =-Diag_C(ikl,isl)  /Aux__P(ikl,isl)
+    END DO
+    END DO
+
+    DO ikl=      1,knonv
+      TsisSV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol)
+    END DO
+
+    DO ikl=      1,knonv
+    DO   isl=-nsol+1,min(nsno,isnoSV(ikl)+1)
+      TsisSV(ikl,isl)   =(Term_D(ikl,isl) &
+            -Diag_A(ikl,isl)  *TsisSV(ikl,isl-1)) &
+            /Aux__P(ikl,isl)
+
+
+    END DO
+    END DO
+
+  ! +--Backward Sweep
+  ! +  ^^^^^^^^^^^^^^
+    DO ikl=     1,knonv
+    DO   isl=min(nsno-1,isnoSV(ikl)+1),-nsol,-1
+
+
+      TsisSV(ikl,isl)   = Aux__Q(ikl,isl)  *TsisSV(ikl,isl+1) &
+            +TsisSV(ikl,isl)
+      if(isl==0.and.isnoSV(ikl)==0) then
+
+       TsisSV(ikl,isl)  = min(TaT_SV(ikl)+30,TsisSV(ikl,isl))
+       TsisSV(ikl,isl)  = max(TaT_SV(ikl)-30,TsisSV(ikl,isl))
+
+
+  ! #EU      TsisSV(ikl,isl)  = max(TaT_SV(ikl)-15.,TsisSV(ikl,isl))
+
+      ! !XF 18/11/2018 to avoid ST reaching 70°C!!
+      ! !It is an error compensation but does not work over tundra
+
+      endif
+
+
+
+    END DO
+
+  END DO
+
+
+
+  ! +--Temperature Limits (avoids problems in case of no Snow Layers)
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=     1,knonv
+       isl              = isnoSV(ikl)
+
+       dTSurf            = TsisSV(ikl,isl) -     TSurf0(ikl)
+      TsisSV(ikl,isl)   = TSurf0(ikl) + sign(1.,dTSurf) & ! 180.0 dgC/hr
+            * min(abs(dTSurf),5.e-2*dt__SV)         ! =0.05 dgC/s
+
+
+
+    END DO
+
+    DO ikl=     1,knonv
+    DO   isl=min(nsno,isnoSV(ikl)+1),1      ,-1
+      TsisSV(ikl,isl)   = max(Ts_Min,       TsisSV(ikl,isl))
+      TsisSV(ikl,isl)   = min(Ts_Max,       TsisSV(ikl,isl))
+    END DO
+
+    END DO
+
+  ! +--Update Surface    Fluxes
+  ! +  ========================
+
+
+
+    DO ikl=      1,knonv
+      isl         = isnoSV(ikl)
+      IRs_SV(ikl) = IRs__D(ikl) & !
+            - dIRsdT(ikl) * TsisSV(ikl,isl)        !
+      HSs_sv(ikl) = HS___D(ikl) & ! Sensible Heat
+            - dSdTSV(ikl) * TsisSV(ikl,isl)        ! Downward > 0
+      HLs_sv(ikl) = HL___D(ikl) & ! Latent   Heat
+            - dLdTSV(ikl) * TsisSV(ikl,isl)        ! Downward > 0
+    END DO
+
+
+end subroutine sisvat_tso
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_weq.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_weq.F	(revision 5104)
+++ 	(revision )
@@ -1,104 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_wEq( labWEq ,istart)
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_wEq                                22-09-2001  MAR |
-C |   SubRoutine SISVAT_wEq computes the Snow/Ice  Water  Equivalent       |
-C |                                                                        |
-C |                                                                        |
-C |   Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
-C |   ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
-C |   FILE                 |      CONTENT                                  |
-C |   ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
-C | # SISVAT_wEq.ve        | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. |
-C |                        |      unit 45, SubRoutine  SISVAT_wEq **ONLY** |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
-
-      use VARphy
-      use VAR_SV
-      use VARxSV
- 
-      IMPLICIT NONE
-
- 
- 
-      character*6         labWEq
-      integer             istart
- 
-      logical             logWEq
-      common/SISVAT_wEq_L/logWEq
- 
- 
-C +--Local  Variables
-C +  ================
- 
-      integer  ikl   ,isn
-      real     SnoWEQ,IceWEQ
- 
- 
-C +--Switch Initialization
-C +  =====================
- 
-      IF (.NOT.logWEq)                                              THEN
-               logWEq = .TRUE.
-               open(unit=45,status='unknown',file='SISVAT_wEq.ve')
-               rewind    45
-      END IF
- 
- 
-C +--Snow Water Equivalent
-C +  =====================
- 
-           ikl   = 1
-      IF          (isnoSV(ikl)>iiceSV(ikl))                      THEN
- 
-          SnoWEQ = 0.
-        DO isn   = iiceSV(ikl)+1 ,isnoSV(ikl)
-          SnoWEQ = SnoWEQ       + ro__SV(ikl,isn) * dzsnSV(ikl,isn)
-        END DO
- 
-      END IF
- 
- 
-C +--Ice  Water Equivalent
-C +  =====================
- 
-      IF        (iiceSV(1)>0)                                    THEN
- 
-          IceWEQ = 0.
-        DO isn   =             1 ,iiceSV(ikl)
-          IceWEQ = IceWEQ       + ro__SV(ikl,isn) * dzsnSV(ikl,isn)
-        END DO
- 
-      END IF
- 
- 
-C +--OUTPUT
-C +  ======
- 
- !      IF (istart.eq.1)                                              THEN
- !        write(45,45)dahost,i___SV(lwriSV(1)),j___SV(lwriSV(1)),
- !     .              n___SV(lwriSV(1))
- ! 45     format(a18,10('-'),'Pt.',3i4,60('-'))
- !      END IF
- 
- !      write(45,450) labWEq,IceWEQ,iiceSV(ikl),SnoWEQ
- !     .                    ,IceWEQ+SnoWEQ,isnoSV(ikl)
- !     .                                  ,drr_SV(ikl)*dt__SV
- !     .                                  ,dsn_SV(ikl)*dt__SV
- !     .                                  ,BufsSV(ikl)
- ! 450  format(a6,3x,'  I+S =',f11.4,'(',i2,') +',f11.4,' =',
- !     .                       f11.4,'(',i2,')',
- !     .             '  drr =', f7.4,
- !     .             '  dsn =', f7.4,
- !     .             '  Buf =', f7.4)
- 
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_weq.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_weq.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_weq.f90	(revision 5105)
@@ -0,0 +1,104 @@
+
+
+SUBROUTINE SISVAT_wEq( labWEq ,istart)
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_wEq                                22-09-2001  MAR |
+  ! |   SubRoutine SISVAT_wEq computes the Snow/Ice  Water  Equivalent       |
+  ! |                                                                        |
+  ! |                                                                        |
+  ! |   Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
+  ! |   ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
+  ! |   FILE                 |      CONTENT                                  |
+  ! |   ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+  ! | # SISVAT_wEq.ve        | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. |
+  ! |                        |      unit 45, SubRoutine  SISVAT_wEq **ONLY** |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  use VARphy
+  use VAR_SV
+  use VARxSV
+
+  IMPLICIT NONE
+
+
+
+  character(len=6) :: labWEq
+  integer :: istart
+
+  logical :: logWEq
+  common/SISVAT_wEq_L/logWEq
+
+
+  ! +--Local  Variables
+  ! +  ================
+
+  integer :: ikl   ,isn
+  real :: SnoWEQ,IceWEQ
+
+
+  ! +--Switch Initialization
+  ! +  =====================
+
+  IF (.NOT.logWEq)                                              THEN
+           logWEq = .TRUE.
+           open(unit=45,status='unknown',file='SISVAT_wEq.ve')
+           rewind    45
+  END IF
+
+
+  ! +--Snow Water Equivalent
+  ! +  =====================
+
+       ikl   = 1
+  IF          (isnoSV(ikl)>iiceSV(ikl))                      THEN
+
+      SnoWEQ = 0.
+    DO isn   = iiceSV(ikl)+1 ,isnoSV(ikl)
+      SnoWEQ = SnoWEQ       + ro__SV(ikl,isn) * dzsnSV(ikl,isn)
+    END DO
+
+  END IF
+
+
+  ! +--Ice  Water Equivalent
+  ! +  =====================
+
+  IF        (iiceSV(1)>0)                                    THEN
+
+      IceWEQ = 0.
+    DO isn   =             1 ,iiceSV(ikl)
+      IceWEQ = IceWEQ       + ro__SV(ikl,isn) * dzsnSV(ikl,isn)
+    END DO
+
+  END IF
+
+
+  ! +--OUTPUT
+  ! +  ======
+
+  !!      IF (istart.eq.1)                                              THEN
+  !!        write(45,45)dahost,i___SV(lwriSV(1)),j___SV(lwriSV(1)),
+  !!     .              n___SV(lwriSV(1))
+  !! 45     format(a18,10('-'),'Pt.',3i4,60('-'))
+  !!      END IF
+
+  !!      write(45,450) labWEq,IceWEQ,iiceSV(ikl),SnoWEQ
+  !!     .                    ,IceWEQ+SnoWEQ,isnoSV(ikl)
+  !!     .                                  ,drr_SV(ikl)*dt__SV
+  !!     .                                  ,dsn_SV(ikl)*dt__SV
+  !!     .                                  ,BufsSV(ikl)
+  !! 450  format(a6,3x,'  I+S =',f11.4,'(',i2,') +',f11.4,' =',
+  !!     .                       f11.4,'(',i2,')',
+  !!     .             '  drr =', f7.4,
+  !!     .             '  dsn =', f7.4,
+  !!     .             '  Buf =', f7.4)
+
+
+end subroutine sisvat_weq
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zag.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zag.F	(revision 5104)
+++ 	(revision )
@@ -1,238 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_zAg
-     .                     (isagra,isagrb,WEagra
-     .                     ,dzagra,dzagrb,T_agra,T_agrb
-     .                     ,roagra,roagrb,etagra,etagrb
-     .                     ,G1agra,G1agrb,G2agra,G2agrb
-     .                     ,agagra,agagrb,Agreg1
-     .                     )
- 
-C +------------------------------------------------------------------------+
-C | MAR SURFACE                                       Sat 30-Apr-2004  MAR |
-C |   SubRoutine SISVAT_zAg aggregates two contiguous snow layers          |
-C |                                                                        |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT:   isagrb   : 2nd     Layer History                            |
-C |   ^^^^^                                                                |
-C |                                                                        |
-C |   INPUT:   dzagrb   : 2nd     Layer Thickness                          |
-C |   ^^^^^    T_agrb   : 2nd     Layer Temperature                        |
-C |            roagrb   : 2nd     Layer Density                            |
-C |            etagrb   : 2nd     Layer Water Content                      |
-C |            G1agrb   : 2nd     Layer Dendricity/Spher.                  |
-C |            G2agrb   : 2nd     Layer Sphericity/Size                    |
-C |            agagrb   : 2nd     Age                                      |
-C |            Agreg1   : 1. when Agregation constrained                   |
-C |                                                                        |
-C |   INPUT /  isagra   : 1st     Layer History                            |
-C |   OUTPUT:                                                              |
-C |   ^^^^^^                                                               |
-C |                                                                        |
-C |   INPUT /  dzagra   : 1st     Layer Thickness                          |
-C |   OUTPUT:  T_agra   : 1st     Layer Temperature                        |
-C |   ^^^^^^   roagra   : 1st     Layer Density                            |
-C |            etagra   : 1st     Layer Water Content                      |
-C |            G1agra   : 1st     Layer Dendricity/Spher.                  |
-C |            G2agra   : 1st     Layer Sphericity/Size                    |
-C |            agagra   : 1st     Age                                      |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
- 
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VAR0SV
-      use VARxSV
-
-      IMPLICIT NONE
-
- 
-C +--INPUT
-C +  -----
- 
-      integer   isagrb(knonv)                 ! 2nd Layer History
-      real      dzagrb(knonv)                 ! 2nd Layer Thickness
-      real      T_agrb(knonv)                 ! 2nd Layer Temperature
-      real      roagrb(knonv)                 ! 2nd Layer Density
-      real      etagrb(knonv)                 ! 2nd Layer Water Content
-      real      G1agrb(knonv)                 ! 2nd Layer Dendricity/Spher.
-      real      G2agrb(knonv)                 ! 2nd Layer Sphericity/Size
-      real      agagrb(knonv)                 ! 2nd Layer Age
- 
- 
-C +--INPUT/OUTPUT
-C +  ------------
- 
-      integer   isagra(knonv)                 ! 1st Layer History
-      real      WEagra(knonv)                 ! 1st Layer Height    [mm w.e.]
-      real      Agreg1(knonv)                 ! 1. ===>   Agregates
-      real      dzagra(knonv)                 ! 1st Layer Thickness
-      real      T_agra(knonv)                 ! 1st Layer Temperature
-      real      roagra(knonv)                 ! 1st Layer Density
-      real      etagra(knonv)                 ! 1st Layer Water Content
-      real      G1agra(knonv)                 ! 1st Layer Dendricity/Spher.
-      real      G2agra(knonv)                 ! 1st Layer Sphericity/Size
-      real      agagra(knonv)                 ! 1st Layer Age
- 
- 
-C +--Internal Variables
-C +  ==================
- 
-      integer   ikl
-      integer   nh                            ! Averaged    Snow History
-      integer   nh__OK                        ! 1=>Conserve Snow History
-      real      rh                            !
-      real      dz                            ! Thickness
-      real      dzro_1                        ! Thickness X Density, Lay.1
-      real      dzro_2                        ! Thickness X Density, Lay.2
-      real      dzro                          ! Thickness X Density, Aver.
-      real      ro                            ! Averaged    Density
-      real      wn                            ! Averaged    Water Content
-      real      tn                            ! Averaged    Temperature
-      real      ag                            ! Averaged    Snow Age
-      real      SameOK                        ! 1. => Same Type of Grains
-      real      G1same                        ! Averaged G1,  same Grains
-      real      G2same                        ! Averaged G2,  same Grains
-      real      typ__1                        ! 1. => Lay1 Type: Dendritic
-      real      zroNEW                        ! dz X ro, if fresh Snow
-      real      G1_NEW                        ! G1,      if fresh Snow
-      real      G2_NEW                        ! G2,      if fresh Snow
-      real      zroOLD                        ! dz X ro, if old   Snow
-      real      G1_OLD                        ! G1,      if old   Snow
-      real      G2_OLD                        ! G2,      if old   Snow
-      real      SizNEW                        ! Size,    if fresh Snow
-      real      SphNEW                        ! Spheric.,if fresh Snow
-      real      SizOLD                        ! Size,    if old   Snow
-      real      SphOLD                        ! Spheric.,if old   Snow
-      real      Siz_av                        ! Averaged    Grain Size
-      real      Sph_av                        ! Averaged    Grain Spher.
-      real      Den_av                        ! Averaged    Grain Dendr.
-      real      DendOK                        ! 1. => Average is  Dendr.
-      real      G1diff                        ! Averaged G1, diff. Grains
-      real      G2diff                        ! Averaged G2, diff. Grains
-      real      G1                            ! Averaged G1
-      real      G2                            ! Averaged G2
- 
-
- 
-C +--Mean   Properties
-C +  =================
- 
-C +-- 1 Densite, Contenu en Eau, Temperature /
-C +     Density, Water Content,  Temperature
-C +     ------------------------------------
- 
-      DO ikl = 1,knonv
-          dz      =  dzagra(ikl) + dzagrb(ikl)
-          dzro_1  =  roagra(ikl) * dzagra(ikl)
-          dzro_2  =  roagrb(ikl) * dzagrb(ikl)
-          dzro    =  dzro_1      + dzro_2
-          ro      =  dzro
-     .     /max(epsi,dz)
-          wn      = (dzro_1*etagra(ikl) + dzro_2*etagrb(ikl))
-     .     /max(epsi,dzro)
-          tn      = (dzro_1*T_agra(ikl) + dzro_2*T_agrb(ikl))
-     .     /max(epsi,dzro)
-          ag      = (dzro_1*agagra(ikl) + dzro_2*agagrb(ikl))
-     .     /max(epsi,dzro)
- 
-          rh      =  max(zero,sign(unun,zWEcSV(ikl)
-     .                                         -0.5*WEagra(ikl)))
-          nh__OK  =  rh
-          nh      =                 max(isagra(ikl),isagrb(ikl))
-c #HB.            *  nh__OK
-c #HB.          + (1-nh__OK)*       min(isagra(ikl),isagrb(ikl))
- 
- 
- 
-C +-- 2 Nouveaux Types de Grains /  new Grain Types
-C +     -------------------------------------------
- 
-C +-- 2.1. Meme  Type  de Neige  / same Grain Type
-C +        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          SameOK  =  max(zero,
-     .                   sign(unun, G1agra(ikl) *G1agrb(ikl)  - eps_21))
-          G1same  = (dzro_1*G1agra(ikl) + dzro_2*G1agrb(ikl))
-     .     /max(epsi,dzro)
-          G2same  = (dzro_1*G2agra(ikl) + dzro_2*G2agrb(ikl))
-     .     /max(epsi,dzro)
- 
-C +-- 2.2. Types differents / differents Types
-C +        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-          typ__1  =  max(zero,sign(unun,epsi-G1agra(ikl))) ! =1.=> Dendritic
-          zroNEW  =     typ__1  *dzro_1                    ! ro of Dendr.Lay.
-     .            + (1.-typ__1) *dzro_2                    !
-          G1_NEW  =     typ__1  *G1agra(ikl)               ! G1 of Dendr.Lay.
-     .            + (1.-typ__1) *G1agrb(ikl)               !
-          G2_NEW  =     typ__1  *G2agra(ikl)               ! G2 of Dendr.Lay.
-     .            + (1.-typ__1) *G2agrb(ikl)               !
-          zroOLD  = (1.-typ__1) *dzro_1                    ! ro of Spher.Lay.
-     .            +     typ__1  *dzro_2                    !
-          G1_OLD  = (1.-typ__1) *G1agra(ikl)               ! G1 of Spher.Lay.
-     .            +     typ__1  *G1agrb(ikl)               !
-          G2_OLD  = (1.-typ__1) *G2agra(ikl)               ! G2 of Spher.Lay.
-     .            +     typ__1  *G2agrb(ikl)               !
-          SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV             ! Size  Dendr.Lay.
-     .             +(1.+G1_NEW         /G1_dSV)            !
-     .                *(G2_NEW  *DScdSV/G1_dSV             !
-     .             +(1.-G2_NEW         /G1_dSV)*DFcdSV)    !
-          SphNEW  =     G2_NEW         /G1_dSV             ! Spher.Dendr.Lay.
-          SizOLD  =     G2_OLD                             ! Size  Spher.Lay.
-          SphOLD  =     G1_OLD         /G1_dSV             ! Spher.Spher.Lay.
-          Siz_av  = (zroNEW*SizNEW+zroOLD*SizOLD)      ! Averaged Size
-     .     /max(epsi,dzro)                             !
-          Sph_av  = (zroNEW*SphNEW+zroOLD*SphOLD)      ! Averaged Sphericity
-     .     /max(epsi,dzro)                             !
-          Den_av  = (Siz_av -(    Sph_av *DScdSV       !
-     .                       +(1.-Sph_av)*DFcdSV))     !
-     .            / (DDcdSV -(    Sph_av *DScdSV       !
-     .                       +(1.-Sph_av)*DFcdSV))     !
-          DendOK  = max(zero,                          !
-     .                  sign(unun,     Sph_av *DScdSV  ! Small   Grains Contr.
-     .                            +(1.-Sph_av)*DFcdSV  ! Faceted Grains Contr.
-     .                            -    Siz_av        ))!
-C +...    REMARQUE: le  type moyen (dendritique ou non) depend
-C +       ^^^^^^^^  de la  comparaison avec le diametre optique
-C +                 d'une neige recente de   dendricite nulle
-C +...    REMARK:   the mean type  (dendritic   or not) depends
-C +       ^^^^^^    on the comparaison with the optical diameter
-C +                 of a recent snow    having zero dendricity
- 
-          G1diff  =(   -DendOK *Den_av
-     .             +(1.-DendOK)*Sph_av) *G1_dSV
-          G2diff  =     DendOK *Sph_av  *G1_dSV
-     .             +(1.-DendOK)*Siz_av
-          G1      =     SameOK *G1same
-     .             +(1.-SameOK)*G1diff
-          G2      =     SameOK *G2same
-     .             +(1.-SameOK)*G2diff
- 
- 
-C +--Assignation to new Properties
-C +  =============================
- 
-          isagra(ikl)   = Agreg1(ikl) *nh +(1.-Agreg1(ikl)) *isagra(ikl)
-          dzagra(ikl)   = Agreg1(ikl) *dz +(1.-Agreg1(ikl)) *dzagra(ikl)
-          T_agra(ikl)   = Agreg1(ikl) *tn +(1.-Agreg1(ikl)) *T_agra(ikl)
-          roagra(ikl)   = Agreg1(ikl) *ro +(1.-Agreg1(ikl)) *roagra(ikl)
-          etagra(ikl)   = Agreg1(ikl) *wn +(1.-Agreg1(ikl)) *etagra(ikl)
-          G1agra(ikl)   = Agreg1(ikl) *G1 +(1.-Agreg1(ikl)) *G1agra(ikl)
-          G2agra(ikl)   = Agreg1(ikl) *G2 +(1.-Agreg1(ikl)) *G2agra(ikl)
-          agagra(ikl)   = Agreg1(ikl) *ag +(1.-Agreg1(ikl)) *agagra(ikl)
- 
-      END DO
- 
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zag.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zag.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zag.f90	(revision 5105)
@@ -0,0 +1,238 @@
+
+
+SUBROUTINE SISVAT_zAg &
+        (isagra,isagrb,WEagra &
+        ,dzagra,dzagrb,T_agra,T_agrb &
+        ,roagra,roagrb,etagra,etagrb &
+        ,G1agra,G1agrb,G2agra,G2agrb &
+        ,agagra,agagrb,Agreg1 &
+        )
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR SURFACE                                       Sat 30-Apr-2004  MAR |
+  ! |   SubRoutine SISVAT_zAg aggregates two contiguous snow layers          |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT:   isagrb   : 2nd     Layer History                            |
+  ! |   ^^^^^                                                                |
+  ! |                                                                        |
+  ! |   INPUT:   dzagrb   : 2nd     Layer Thickness                          |
+  ! |   ^^^^^    T_agrb   : 2nd     Layer Temperature                        |
+  ! |            roagrb   : 2nd     Layer Density                            |
+  ! |            etagrb   : 2nd     Layer Water Content                      |
+  ! |            G1agrb   : 2nd     Layer Dendricity/Spher.                  |
+  ! |            G2agrb   : 2nd     Layer Sphericity/Size                    |
+  ! |            agagrb   : 2nd     Age                                      |
+  ! |            Agreg1   : 1. when Agregation constrained                   |
+  ! |                                                                        |
+  ! |   INPUT /  isagra   : 1st     Layer History                            |
+  ! |   OUTPUT:                                                              |
+  ! |   ^^^^^^                                                               |
+  ! |                                                                        |
+  ! |   INPUT /  dzagra   : 1st     Layer Thickness                          |
+  ! |   OUTPUT:  T_agra   : 1st     Layer Temperature                        |
+  ! |   ^^^^^^   roagra   : 1st     Layer Density                            |
+  ! |            etagra   : 1st     Layer Water Content                      |
+  ! |            G1agra   : 1st     Layer Dendricity/Spher.                  |
+  ! |            G2agra   : 1st     Layer Sphericity/Size                    |
+  ! |            agagra   : 1st     Age                                      |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VAR0SV
+  use VARxSV
+
+  IMPLICIT NONE
+
+
+  ! +--INPUT
+  ! +  -----
+
+  integer :: isagrb(knonv)                 ! 2nd Layer History
+  real :: dzagrb(knonv)                 ! 2nd Layer Thickness
+  real :: T_agrb(knonv)                 ! 2nd Layer Temperature
+  real :: roagrb(knonv)                 ! 2nd Layer Density
+  real :: etagrb(knonv)                 ! 2nd Layer Water Content
+  real :: G1agrb(knonv)                 ! 2nd Layer Dendricity/Spher.
+  real :: G2agrb(knonv)                 ! 2nd Layer Sphericity/Size
+  real :: agagrb(knonv)                 ! 2nd Layer Age
+
+
+  ! +--INPUT/OUTPUT
+  ! +  ------------
+
+  integer :: isagra(knonv)                 ! 1st Layer History
+  real :: WEagra(knonv)                 ! 1st Layer Height    [mm w.e.]
+  real :: Agreg1(knonv)                 ! 1. ===>   Agregates
+  real :: dzagra(knonv)                 ! 1st Layer Thickness
+  real :: T_agra(knonv)                 ! 1st Layer Temperature
+  real :: roagra(knonv)                 ! 1st Layer Density
+  real :: etagra(knonv)                 ! 1st Layer Water Content
+  real :: G1agra(knonv)                 ! 1st Layer Dendricity/Spher.
+  real :: G2agra(knonv)                 ! 1st Layer Sphericity/Size
+  real :: agagra(knonv)                 ! 1st Layer Age
+
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  integer :: ikl
+  integer :: nh                            ! Averaged    Snow History
+  integer :: nh__OK                        ! 1=>Conserve Snow History
+  real :: rh                            !
+  real :: dz                            ! Thickness
+  real :: dzro_1                        ! Thickness X Density, Lay.1
+  real :: dzro_2                        ! Thickness X Density, Lay.2
+  real :: dzro                          ! Thickness X Density, Aver.
+  real :: ro                            ! Averaged    Density
+  real :: wn                            ! Averaged    Water Content
+  real :: tn                            ! Averaged    Temperature
+  real :: ag                            ! Averaged    Snow Age
+  real :: SameOK                        ! 1. => Same Type of Grains
+  real :: G1same                        ! Averaged G1,  same Grains
+  real :: G2same                        ! Averaged G2,  same Grains
+  real :: typ__1                        ! 1. => Lay1 Type: Dendritic
+  real :: zroNEW                        ! dz X ro, if fresh Snow
+  real :: G1_NEW                        ! G1,      if fresh Snow
+  real :: G2_NEW                        ! G2,      if fresh Snow
+  real :: zroOLD                        ! dz X ro, if old   Snow
+  real :: G1_OLD                        ! G1,      if old   Snow
+  real :: G2_OLD                        ! G2,      if old   Snow
+  real :: SizNEW                        ! Size,    if fresh Snow
+  real :: SphNEW                        ! Spheric.,if fresh Snow
+  real :: SizOLD                        ! Size,    if old   Snow
+  real :: SphOLD                        ! Spheric.,if old   Snow
+  real :: Siz_av                        ! Averaged    Grain Size
+  real :: Sph_av                        ! Averaged    Grain Spher.
+  real :: Den_av                        ! Averaged    Grain Dendr.
+  real :: DendOK                        ! 1. => Average is  Dendr.
+  real :: G1diff                        ! Averaged G1, diff. Grains
+  real :: G2diff                        ! Averaged G2, diff. Grains
+  real :: G1                            ! Averaged G1
+  real :: G2                            ! Averaged G2
+
+
+
+  ! +--Mean   Properties
+  ! +  =================
+
+  ! +-- 1 Densite, Contenu en Eau, Temperature /
+  ! +     Density, Water Content,  Temperature
+  ! +     ------------------------------------
+
+  DO ikl = 1,knonv
+      dz      =  dzagra(ikl) + dzagrb(ikl)
+      dzro_1  =  roagra(ikl) * dzagra(ikl)
+      dzro_2  =  roagrb(ikl) * dzagrb(ikl)
+      dzro    =  dzro_1      + dzro_2
+      ro      =  dzro &
+            /max(epsi,dz)
+      wn      = (dzro_1*etagra(ikl) + dzro_2*etagrb(ikl)) &
+            /max(epsi,dzro)
+      tn      = (dzro_1*T_agra(ikl) + dzro_2*T_agrb(ikl)) &
+            /max(epsi,dzro)
+      ag      = (dzro_1*agagra(ikl) + dzro_2*agagrb(ikl)) &
+            /max(epsi,dzro)
+
+      rh      =  max(zero,sign(unun,zWEcSV(ikl) &
+            -0.5*WEagra(ikl)))
+      nh__OK  =  rh
+      nh      =                 max(isagra(ikl),isagrb(ikl))
+  ! #HB.            *  nh__OK
+  ! #HB.          + (1-nh__OK)*       min(isagra(ikl),isagrb(ikl))
+
+
+
+  ! +-- 2 Nouveaux Types de Grains /  new Grain Types
+  ! +     -------------------------------------------
+
+  ! +-- 2.1. Meme  Type  de Neige  / same Grain Type
+  ! +        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      SameOK  =  max(zero, &
+            sign(unun, G1agra(ikl) *G1agrb(ikl)  - eps_21))
+      G1same  = (dzro_1*G1agra(ikl) + dzro_2*G1agrb(ikl)) &
+            /max(epsi,dzro)
+      G2same  = (dzro_1*G2agra(ikl) + dzro_2*G2agrb(ikl)) &
+            /max(epsi,dzro)
+
+  ! +-- 2.2. Types differents / differents Types
+  ! +        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+      typ__1  =  max(zero,sign(unun,epsi-G1agra(ikl))) ! =1.=> Dendritic
+      zroNEW  =     typ__1  *dzro_1 & ! ro of Dendr.Lay.
+            + (1.-typ__1) *dzro_2                    !
+      G1_NEW  =     typ__1  *G1agra(ikl) & ! G1 of Dendr.Lay.
+            + (1.-typ__1) *G1agrb(ikl)               !
+      G2_NEW  =     typ__1  *G2agra(ikl) & ! G2 of Dendr.Lay.
+            + (1.-typ__1) *G2agrb(ikl)               !
+      zroOLD  = (1.-typ__1) *dzro_1 & ! ro of Spher.Lay.
+            +     typ__1  *dzro_2                    !
+      G1_OLD  = (1.-typ__1) *G1agra(ikl) & ! G1 of Spher.Lay.
+            +     typ__1  *G1agrb(ikl)               !
+      G2_OLD  = (1.-typ__1) *G2agra(ikl) & ! G2 of Spher.Lay.
+            +     typ__1  *G2agrb(ikl)               !
+      SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV & ! Size  Dendr.Lay.
+            +(1.+G1_NEW         /G1_dSV) & !
+            *(G2_NEW  *DScdSV/G1_dSV & !
+            +(1.-G2_NEW         /G1_dSV)*DFcdSV)    !
+      SphNEW  =     G2_NEW         /G1_dSV             ! Spher.Dendr.Lay.
+      SizOLD  =     G2_OLD                             ! Size  Spher.Lay.
+      SphOLD  =     G1_OLD         /G1_dSV             ! Spher.Spher.Lay.
+      Siz_av  = (zroNEW*SizNEW+zroOLD*SizOLD) & ! Averaged Size
+            /max(epsi,dzro)                             !
+      Sph_av  = (zroNEW*SphNEW+zroOLD*SphOLD) & ! Averaged Sphericity
+            /max(epsi,dzro)                             !
+      Den_av  = (Siz_av -(    Sph_av *DScdSV & !
+            +(1.-Sph_av)*DFcdSV)) & !
+            / (DDcdSV -(    Sph_av *DScdSV & !
+            +(1.-Sph_av)*DFcdSV))     !
+      DendOK  = max(zero, & !
+            sign(unun,     Sph_av *DScdSV & ! Small   Grains Contr.
+            +(1.-Sph_av)*DFcdSV & ! Faceted Grains Contr.
+            -    Siz_av        ))!
+  ! +...    REMARQUE: le  type moyen (dendritique ou non) depend
+  ! +       ^^^^^^^^  de la  comparaison avec le diametre optique
+  ! +                 d'une neige recente de   dendricite nulle
+  ! +...    REMARK:   the mean type  (dendritic   or not) depends
+  ! +       ^^^^^^    on the comparaison with the optical diameter
+  ! +                 of a recent snow    having zero dendricity
+
+      G1diff  =(   -DendOK *Den_av &
+            +(1.-DendOK)*Sph_av) *G1_dSV
+      G2diff  =     DendOK *Sph_av  *G1_dSV &
+            +(1.-DendOK)*Siz_av
+      G1      =     SameOK *G1same &
+            +(1.-SameOK)*G1diff
+      G2      =     SameOK *G2same &
+            +(1.-SameOK)*G2diff
+
+
+  ! +--Assignation to new Properties
+  ! +  =============================
+
+      isagra(ikl)   = Agreg1(ikl) *nh +(1.-Agreg1(ikl)) *isagra(ikl)
+      dzagra(ikl)   = Agreg1(ikl) *dz +(1.-Agreg1(ikl)) *dzagra(ikl)
+      T_agra(ikl)   = Agreg1(ikl) *tn +(1.-Agreg1(ikl)) *T_agra(ikl)
+      roagra(ikl)   = Agreg1(ikl) *ro +(1.-Agreg1(ikl)) *roagra(ikl)
+      etagra(ikl)   = Agreg1(ikl) *wn +(1.-Agreg1(ikl)) *etagra(ikl)
+      G1agra(ikl)   = Agreg1(ikl) *G1 +(1.-Agreg1(ikl)) *G1agra(ikl)
+      G2agra(ikl)   = Agreg1(ikl) *G2 +(1.-Agreg1(ikl)) *G2agra(ikl)
+      agagra(ikl)   = Agreg1(ikl) *ag +(1.-Agreg1(ikl)) *agagra(ikl)
+
+  END DO
+
+
+end subroutine sisvat_zag
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zcr.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zcr.F	(revision 5104)
+++ 	(revision )
@@ -1,175 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_zCr
-C +
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_zCr                                12-12-2002  MAR |
-C |   SubRoutine SISVAT_zCr determines criteria for Layers Agregation      |
-C |                                                                        |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  klonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
-C |   OUTPUT:  iiceSV   = total Nb of Ice      Layers                      |
-C |   ^^^^^^   ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
-C |            istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
-C |                                                                        |
-C |   INPUT /  ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
-C |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
-C |   ^^^^^^   G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
-C |            G2snSV   : Sphericity (>0) or Size            of Snow Layer |
-C |            agsnSV   : Snow       Age                             [day] |
-C |                                                                        |
-C |   OUTPUT:  LIndsv   : Relative Index of a contiguous Layer to agregate |
-C |   ^^^^^^                                                               |
-C +------------------------------------------------------------------------+
-C +
-C +
-C +
-C +
-C +--Global Variables
-C +  ================
-C  
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VAR0SV
-      use VARxSV
-      use VARySV
-      use VARtSV
-     
-      IMPLICIT NONE
-
-C +
-C +
-C +--Internal Variables
-C +  ==================
-C +
-      integer   ikl   ,isn   ,is0   ,is1
-      integer   isno_1                        ! Switch:  ! Snow Layer over Ice
-      real      Dtyp_0,Dtyp_1                 ! Snow Grains Difference Measure
-      real      DenSph                        ! 1. when contiguous spheric
-C +                                           !     and dendritic  Grains
-      real      DendOK                        ! 1. when dendritic  Grains
-      real      dTypMx                        ! Grain Type Differ.
-      real      dTypSp                        ! Sphericity Weight
-      real      dTypRo                        ! Density    Weight
-      real      dTypDi                        ! Grain Diam.Weight
-      real      dTypHi                        ! History    Weight
- 
- 
-C +--DATA
-C +  ====
- 
-      data      dTypMx / 200.0  /             ! Grain Type Weight
-      data      dTypSp /   0.5  /             ! Sphericity Weight
-      data      dTypRo /   0.5  /             ! Density    Weight
-      data      dTypDi /  10.0  /             ! Grain Diam.Weight
-      data      dTypHi / 100.0  /             ! History    Weight
- 
- 
-C +--Agregation Criteria
-C +  ===================
-C +
-      DO  ikl=1,knonv
-          i_thin(ikl) = min(i_thin(ikl),isnoSV(ikl))
-          isn         = max(1          ,i_thin(ikl))
-C +
-C +
-C +--Comparison with the downward Layer
-C +  ----------------------------------
-C +
-
-          is0    = max(1,        i_thin(ikl)-1 )        ! Downward Layer Index
-          DenSph = max(zero,                            ! isn/is1
-     .                 sign(unun,                       ! Dendricity/Sphericity
-     .                      epsi-G1snSV(ikl,isn)        !            Switch
-     .                          *G1snSV(ikl,is0)))      !
-          DendOK = max(zero,                            ! Dendricity Switch
-     .                 sign(unun,                       !
-     .                      epsi-G1snSV(ikl,isn)))      !
-C +          
-          Dtyp_0 =
-     .         DenSph *      dTypMx
-     .    +(1.-DenSph)
-     .    *    DendOK *((abs(G1snSV(ikl,isn)            ! Dendricity
-     .                      -G1snSV(ikl,is0))           !     Contribution
-     .                  +abs(G2snSV(ikl,isn)            ! Sphericity
-     .                      -G2snSV(ikl,is0))) *dTypSp  !     Contribution
-     .                  +abs(ro__SV(ikl,isn)            ! Density
-     .                      -ro__SV(ikl,is0))  *dTypRo) !     Contribution
-     .    +(1.-DenSph)                                  !
-     .    *(1.-DendOK)*((abs(G1snSV(ikl,isn)            ! Sphericity
-     .                      -G1snSV(ikl,is0))           !     Contribution
-     .                  +abs(G2snSV(ikl,isn)            ! Size
-     .                      -G2snSV(ikl,is0))) *dTypDi  !     Contribution
-     .                  +abs(ro__SV(ikl,isn)            ! Density
-     .                      -ro__SV(ikl,is0))  *dTypRo) !     Contribution
-          Dtyp_0 =                                      !
-     .                   min(dTypMx,                    !
-     .                       Dtyp_0                     !
-     .                  +abs(istoSV(ikl,isn)            ! History
-     .                      -istoSV(ikl,is0))  *dTypHi) !     Contribution
-     .        +             (1 -abs(isn-is0))  * 1.e+6  !"Same Layer"Score
-     .        +  max(0,1-abs(iiceSV(ikl)                !"Ice /Snow
-     .                                 -is0))  * 1.e+6  ! Interface" Score
-C +
-C +
-C +--Comparison with the   upward Layer
-C +  ----------------------------------
-C +
-          is1    = min(          i_thin(ikl)+1,         ! Upward   Layer Index
-     .                 max(1,    isnoSV(ikl)  ))        !
-          DenSph = max(zero,                            ! isn/is1
-     .                 sign(unun,                       ! Dendricity/Sphericity
-     .                      epsi-G1snSV(ikl,isn)        !            Switch
-     .                          *G1snSV(ikl,is1)))      !
-          DendOK = max(zero,                            ! Dendricity Switch
-     .                 sign(unun,                       !
-     .                      epsi-G1snSV(ikl,isn)))      !
-C +
-          Dtyp_1 =
-     .         DenSph *      dTypMx
-     .    +(1.-DenSph)
-     .    *    DendOK *((abs(G1snSV(ikl,isn)            ! Dendricity
-     .                      -G1snSV(ikl,is1))           !     Contribution
-     .                  +abs(G2snSV(ikl,isn)            ! Sphericity
-     .                      -G2snSV(ikl,is1))) *dTypSp  !     Contribution
-     .                  +abs(ro__SV(ikl,isn)            ! Density
-     .                      -ro__SV(ikl,is1))  *dTypRo) !     Contribution
-     .    +(1.-DenSph)                                  !
-     .    *(1.-DendOK)*((abs(G1snSV(ikl,isn)            ! Sphericity
-     .                      -G1snSV(ikl,is1))           !     Contribution
-     .                  +abs(G2snSV(ikl,isn)            ! Size
-     .                      -G2snSV(ikl,is1))) *dTypDi  !     Contribution
-     .                  +abs(ro__SV(ikl,isn)            ! Density
-     .                      -ro__SV(ikl,is1))  *dTypRo) !     Contribution
-          Dtyp_1 =                                      !
-     .                   min(dTypMx,                    !
-     .                       Dtyp_1                     !
-     .                  +abs(istoSV(ikl,isn)            ! History
-     .                      -istoSV(ikl,is1))  *dTypHi) !     Contribution
-     .        +             (1 -abs(isn-is1))  * 1.e+6  !"Same Layer"Score
-     .        +  max(0,1-abs(iiceSV(ikl)                !"Ice /Snow
-     .                                 -isn))  * 1.e+6  ! Interface" Score
-C +
-C +
-C +--Index of the Layer to agregate
-C +  ==============================
-C +
-          LIndsv(ikl) = sign(unun,Dtyp_0
-     .                           -Dtyp_1)
-          isno_1      = (1 -min (abs(isnoSV(ikl)        ! Switch = 1
-     .                              -iiceSV(ikl)-1),1)) !   if isno = iice +1
-     .                * (1 -min (abs(isnoSV(ikl)        ! Switch = 1
-     .                              -i_thin(ikl)  ),1)) !   if isno = i_ithin
-          LIndsv(ikl) = (1 -isno_1) *LIndsv(ikl)        ! Contiguous Layer is
-     .                     -isno_1                      ! downward for top L.
-          i_thin(ikl) =  max(1,   i_thin(ikl)   )
-      END DO
-C +
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zcr.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zcr.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zcr.f90	(revision 5105)
@@ -0,0 +1,175 @@
+
+
+SUBROUTINE SISVAT_zCr
+  ! +
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_zCr                                12-12-2002  MAR |
+  ! |   SubRoutine SISVAT_zCr determines criteria for Layers Agregation      |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  klonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   OUTPUT:  iiceSV   = total Nb of Ice      Layers                      |
+  ! |   ^^^^^^   ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
+  ! |            istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
+  ! |                                                                        |
+  ! |   INPUT /  ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
+  ! |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  ! |   ^^^^^^   G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+  ! |            G2snSV   : Sphericity (>0) or Size            of Snow Layer |
+  ! |            agsnSV   : Snow       Age                             [day] |
+  ! |                                                                        |
+  ! |   OUTPUT:  LIndsv   : Relative Index of a contiguous Layer to agregate |
+  ! |   ^^^^^^                                                               |
+  ! +------------------------------------------------------------------------+
+  ! +
+  ! +
+  ! +
+  ! +
+  ! +--Global Variables
+  ! +  ================
+  !
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VAR0SV
+  use VARxSV
+  use VARySV
+  use VARtSV
+
+  IMPLICIT NONE
+
+  ! +
+  ! +
+  ! +--Internal Variables
+  ! +  ==================
+  ! +
+  integer :: ikl   ,isn   ,is0   ,is1
+  integer :: isno_1                        ! Switch:  ! Snow Layer over Ice
+  real :: Dtyp_0,Dtyp_1                 ! Snow Grains Difference Measure
+  real :: DenSph                        ! 1. when contiguous spheric
+  ! +                                           !     and dendritic  Grains
+  real :: DendOK                        ! 1. when dendritic  Grains
+  real :: dTypMx                        ! Grain Type Differ.
+  real :: dTypSp                        ! Sphericity Weight
+  real :: dTypRo                        ! Density    Weight
+  real :: dTypDi                        ! Grain Diam.Weight
+  real :: dTypHi                        ! History    Weight
+
+
+  ! +--DATA
+  ! +  ====
+
+  data      dTypMx / 200.0  /             ! Grain Type Weight
+  data      dTypSp /   0.5  /             ! Sphericity Weight
+  data      dTypRo /   0.5  /             ! Density    Weight
+  data      dTypDi /  10.0  /             ! Grain Diam.Weight
+  data      dTypHi / 100.0  /             ! History    Weight
+
+
+  ! +--Agregation Criteria
+  ! +  ===================
+  ! +
+  DO  ikl=1,knonv
+      i_thin(ikl) = min(i_thin(ikl),isnoSV(ikl))
+      isn         = max(1          ,i_thin(ikl))
+  ! +
+  ! +
+  ! +--Comparison with the downward Layer
+  ! +  ----------------------------------
+  ! +
+
+      is0    = max(1,        i_thin(ikl)-1 )        ! Downward Layer Index
+      DenSph = max(zero, & ! isn/is1
+            sign(unun, & ! Dendricity/Sphericity
+            epsi-G1snSV(ikl,isn) & !            Switch
+            *G1snSV(ikl,is0)))      !
+      DendOK = max(zero, & ! Dendricity Switch
+            sign(unun, & !
+            epsi-G1snSV(ikl,isn)))      !
+  ! +
+      Dtyp_0 = &
+            DenSph *      dTypMx &
+            +(1.-DenSph) &
+            *    DendOK *((abs(G1snSV(ikl,isn) & ! Dendricity
+            -G1snSV(ikl,is0)) & !     Contribution
+            +abs(G2snSV(ikl,isn) & ! Sphericity
+            -G2snSV(ikl,is0))) *dTypSp & !     Contribution
+            +abs(ro__SV(ikl,isn) & ! Density
+            -ro__SV(ikl,is0))  *dTypRo) & !     Contribution
+            +(1.-DenSph) & !
+            *(1.-DendOK)*((abs(G1snSV(ikl,isn) & ! Sphericity
+            -G1snSV(ikl,is0)) & !     Contribution
+            +abs(G2snSV(ikl,isn) & ! Size
+            -G2snSV(ikl,is0))) *dTypDi & !     Contribution
+            +abs(ro__SV(ikl,isn) & ! Density
+            -ro__SV(ikl,is0))  *dTypRo) !     Contribution
+      Dtyp_0 = & !
+            min(dTypMx, & !
+            Dtyp_0 & !
+            +abs(istoSV(ikl,isn) & ! History
+            -istoSV(ikl,is0))  *dTypHi) & !     Contribution
+            +             (1 -abs(isn-is0))  * 1.e+6 & !"Same Layer"Score
+            +  max(0,1-abs(iiceSV(ikl) & !"Ice /Snow
+            -is0))  * 1.e+6  ! Interface" Score
+  ! +
+  ! +
+  ! +--Comparison with the   upward Layer
+  ! +  ----------------------------------
+  ! +
+      is1    = min(          i_thin(ikl)+1, & ! Upward   Layer Index
+            max(1,    isnoSV(ikl)  ))        !
+      DenSph = max(zero, & ! isn/is1
+            sign(unun, & ! Dendricity/Sphericity
+            epsi-G1snSV(ikl,isn) & !            Switch
+            *G1snSV(ikl,is1)))      !
+      DendOK = max(zero, & ! Dendricity Switch
+            sign(unun, & !
+            epsi-G1snSV(ikl,isn)))      !
+  ! +
+      Dtyp_1 = &
+            DenSph *      dTypMx &
+            +(1.-DenSph) &
+            *    DendOK *((abs(G1snSV(ikl,isn) & ! Dendricity
+            -G1snSV(ikl,is1)) & !     Contribution
+            +abs(G2snSV(ikl,isn) & ! Sphericity
+            -G2snSV(ikl,is1))) *dTypSp & !     Contribution
+            +abs(ro__SV(ikl,isn) & ! Density
+            -ro__SV(ikl,is1))  *dTypRo) & !     Contribution
+            +(1.-DenSph) & !
+            *(1.-DendOK)*((abs(G1snSV(ikl,isn) & ! Sphericity
+            -G1snSV(ikl,is1)) & !     Contribution
+            +abs(G2snSV(ikl,isn) & ! Size
+            -G2snSV(ikl,is1))) *dTypDi & !     Contribution
+            +abs(ro__SV(ikl,isn) & ! Density
+            -ro__SV(ikl,is1))  *dTypRo) !     Contribution
+      Dtyp_1 = & !
+            min(dTypMx, & !
+            Dtyp_1 & !
+            +abs(istoSV(ikl,isn) & ! History
+            -istoSV(ikl,is1))  *dTypHi) & !     Contribution
+            +             (1 -abs(isn-is1))  * 1.e+6 & !"Same Layer"Score
+            +  max(0,1-abs(iiceSV(ikl) & !"Ice /Snow
+            -isn))  * 1.e+6  ! Interface" Score
+  ! +
+  ! +
+  ! +--Index of the Layer to agregate
+  ! +  ==============================
+  ! +
+      LIndsv(ikl) = sign(unun,Dtyp_0 &
+            -Dtyp_1)
+      isno_1      = (1 -min (abs(isnoSV(ikl) & ! Switch = 1
+            -iiceSV(ikl)-1),1)) & !   if isno = iice +1
+            * (1 -min (abs(isnoSV(ikl) & ! Switch = 1
+            -i_thin(ikl)  ),1)) !   if isno = i_ithin
+      LIndsv(ikl) = (1 -isno_1) *LIndsv(ikl) & ! Contiguous Layer is
+            -isno_1                      ! downward for top L.
+      i_thin(ikl) =  max(1,   i_thin(ikl)   )
+  END DO
+  ! +
+
+end subroutine sisvat_zcr
Index: DZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zsn.F
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zsn.F	(revision 5104)
+++ 	(revision )
@@ -1,741 +1,0 @@
- 
- 
-      SUBROUTINE SISVAT_zSn
- 
-C +------------------------------------------------------------------------+
-C | MAR          SISVAT_zSn                                12-07-2019  MAR |
-C |   SubRoutine SISVAT_zSn manages the Snow Pack vertical Discretization  |
-C |                                                                        |
-C +------------------------------------------------------------------------+
-C |                                                                        |
-C |   PARAMETERS:  knonv: Total Number of columns =                        |
-C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-C |                     X       Number of Mosaic Cell per grid box         |
-C |                                                                        |
-C |   INPUT /  NLaysv   = New             Snow Layer  Switch               |
-C |   OUTPUT:  isnoSV   = total Nb of Ice/Snow Layers                      |
-C |   ^^^^^^   ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
-C |            iiceSV   = total Nb of Ice      Layers                      |
-C |            istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
-C |                                                                        |
-C |   INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
-C |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
-C |   ^^^^^^   ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
-C |            eta_SV   : Soil/Snow Water   Content                [m3/m3] |
-C |            dzsnSV   : Snow Layer        Thickness                  [m] |
-C |            G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
-C |            G2snSV   : Sphericity (>0) or Size            of Snow Layer |
-C |            agsnSV   : Snow       Age                             [day] |
-C |                                                                        |
-C |   METHOD:  1) Agregate the thinest Snow Layer                          |
-C |   ^^^^^^      if a new Snow Layer has been precipitated   (NLaysv = 1) |
-C |            2) Divide   a too thick Snow Layer except                   |
-C |               if the maximum Number of Layer is reached                |
-C |               in this case forces                          NLay_s = 1  |
-C |            3) Agregate the thinest Snow Layer                          |
-C |               in order to divide a too thick Snow Layer                |
-C |               at next Time Step when                       NLay_s = 1  |
-C |                                                                        |
-C +------------------------------------------------------------------------+
- 
- 
- 
- 
-C +--Global Variables
-C +  ================
- 
-
-      use VARphy
-      use VAR_SV
-      use VARdSV
-      use VAR0SV
-      use VARxSV
-      use VARySV
-      use surface_data, only: ok_zsn_ii
-
-      IMPLICIT NONE
-
- 
-C +--Internal Variables
-C +  ==================
- 
-      integer   ikl   ,isn   ,i               !
- 
-
-            
-
- 
- 
-      integer   NLay_s(knonv)                 ! Split Snow Layer         Switch
-      integer   isagr1(knonv)                 ! 1st     Layer History
-      integer   isagr2(knonv)                 ! 2nd     Layer History
-      integer   LstLay                        ! 0 ====> isnoSV = 1
-      integer   isno_n                        ! Snow Normal.Profile
-      integer   iice_n                        ! Ice  Normal.Profile
-      integer   iiceOK                        ! Ice         Switch
-      integer   icemix                        ! 0 ====> Agregated Snow+Ice=Snow
-C +                                           ! 1                          Ice
-      integer   isn1  (knonv)                 ! 1st layer to stagger
-      real      staggr                        !              stagger  Switch
- 
-      real      WEagre(knonv)                 ! Snow Water Equivalent Thickness
-      real      dzthin(knonv)                 ! Thickness of the thinest layer
-      real      OKthin                        ! Swich ON  a  new thinest layer
-      real      dz_dif                        ! difference from ideal discret.
-      real      thickL                        ! Thick Layer          Indicator
-      real      OK_ICE                        ! Swich ON   uppermost Ice Layer
- 
-      real      Agrege(knonv)                 ! 1. when Agregation constrained
-      real      dzepsi                        ! Min Single Snw Layer Thickness
-      real      dzxmin                        ! Min Acceptable Layer Thickness
-      real      dz_min                        ! Min            Layer Thickness
-      real      dz_max                        ! Max            Layer Thickness
-      real      dzagr1(knonv)                 ! 1st     Layer Thickness
-      real      dzagr2(knonv)                 ! 2nd     Layer Thickness
-      real      T_agr1(knonv)                 ! 1st     Layer Temperature
-      real      T_agr2(knonv)                 ! 2nd     Layer Temperature
-      real      roagr1(knonv)                 ! 1st     Layer Density
-      real      roagr2(knonv)                 ! 2nd     Layer Density
-      real      etagr1(knonv)                 ! 1st     Layer Water Content
-      real      etagr2(knonv)                 ! 2nd     Layer Water Content
-      real      G1agr1(knonv)                 ! 1st     Layer Dendricity/Spher.
-      real      G1agr2(knonv)                 ! 2nd     Layer Dendricity/Spher.
-      real      G2agr1(knonv)                 ! 1st     Layer Sphericity/Size
-      real      G2agr2(knonv)                 ! 2nd     Layer Sphericity/Size
-      real      agagr1(knonv)                 ! 1st     Layer Age
-      real      agagr2(knonv)                 ! 2nd     Layer Age
-
- 
-C +--DATA
-C +  ====
- 
-      data      icemix /   0    /             ! 0 ====> Agregated Snow+Ice=Snow
-      data      dzepsi /   0.0020/            ! Min single Layer Thickness
-      data      dzxmin /   0.0025/            ! Min accept.Layer Thickness
-c #EU data      dz_min /   0.0050/            ! Min Local  Layer Thickness < SMn
-      data      dz_min /   0.0040/            ! Min Local  Layer Thickness < SMn
-      data      dz_max /   0.0300/            ! Min Gener. Layer Thickness
-C +   CAUTION:  dz_max > dz_min*2 is required ! Otherwise re-agregation is
-C +                                           ! activated  after splitting
- 
-
- 
-
- 
-C +--Constrains Agregation         of too thin  Layers
-C +  =================================================
- 
-C +--Search the thinest  non-zero Layer
-C +  ----------------------------------
- 
-        DO ikl=1,knonv
-          if(isnoSV(ikl)<=2)             dz_min=max(0.0050,dz_min)
- 
-                                          dzepsi=0.0015
-          if(ro__SV(ikl,isnoSV(ikl))>920) dzepsi=0.0020
- 
-          dzthin(ikl) = 0.                              ! Arbitrary unrealistic
-        END DO                                          !       Layer Thickness
-cXF
-      DO ikl=1,knonv
-      DO   isn=1,isnoSV(ikl)-3 ! no agregation of 3 first snowlayers
-                               ! XF 04/07/2019
- 
-          isno_n    =             isnoSV(ikl)-isn+1     ! Snow Normal.Profile
-          iice_n    =             iiceSV(ikl)-isn       ! Ice  Normal.Profile
-          iiceOK    = min(1,max(0,iice_n         +1))   ! Ice         Switch
-! #vz     dz_ref(isn) =                                 !
-! #vz.          dz_min *((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
-! #vz.                 +    iiceOK *    2**iice_n)      !
-! #vz.               /max(1,isnoSV(ikl))                !
-          dz_dif      = max(zero,                       ! Actual      Profile
-     .          dz_min                                  !
-     .                 *((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
-     .                 +    iiceOK *2.   **iice_n)      !
-     .        - dzsnSV(ikl, isn)                    )   ! Actual      Profile
-! #vz     dzwdif(isn) =     dz_dif                      !
-          OKthin      = max(zero,                       !
-     .                      sign(unun,                  !
-     .                           dz_dif-dzthin(ikl)))   ! 1.=> New thinest Lay.
-     .                * max(0,                          ! 1 => .le. isnoSV
-     .                  min(1,                          ! 1 => isn is in the
-     .                      isnoSV(ikl)-isn +1 ))       !          Snow Pack
-     .                * min(unun,                                !
-
-!                       1st additional Condition to accept OKthin
-     .                  max(zero,                                ! combination
-     .                      sign(unun,G1snSV(ikl,      isn  )    ! G1 with same
-     .                               *G1snSV(ikl,max(1,isn-1)))) !  sign => OK
-
-!                       2nd additional Condition to accept OKthin
-     .                + max(zero,                                ! G1>0
-     .                      sign(unun,G1snSV(ikl,      isn   ))) !  =>OK
-
-!                       3rd additional Condition to accept OKthin
-     .                + max(zero,                                ! dz too small
-     .                      sign(unun,dzxmin                     !  =>OK
-     .                               -dzsnSV(ikl,      isn   ))))!
- 
-          i_thin(ikl) =    (1. - OKthin)  * i_thin(ikl) ! Update   thinest Lay.
-     .                         + OKthin   * isn         !                Index
-          dzthin(ikl) =    (1. - OKthin)  * dzthin(ikl) !
-     .                         + OKthin   * dz_dif      !
-        END DO
-      END DO
- 
-
- 
-      DO ikl=1,knonv
-      DO   isn=1,isnoSV(ikl)
-          OKthin =      max(zero,                       !
-     .                      sign(unun,                  !
-     .                           dz_min                 !
-     .                          -dzsnSV(ikl,isn)))      !
-     .                * max(zero,                       ! ON if dz > 0
-     .                      sign(unun,                  !
-     .                           dzsnSV(ikl,isn)-epsi)) !
-     .           *min(1,max(0,                          ! Multiple Snow    Lay.
-     .                      min (1,                     ! Switch = 1
-     .                           isnoSV(ikl)            !   if isno > iice + 1
-     .                          -iiceSV(ikl)-1))        !
-C +                                                     !
-     .             +int(max(zero,                       !
-     .                      sign(unun,                  !
-     .                           dzepsi                 ! Minimum accepted for
-     .                          -dzsnSV(ikl,isn))))     ! 1 Snow Layer over Ice
-     .             *int(max(zero,                       ! ON if dz > 0
-     .                      sign(unun,                  !
-     .                           dzsnSV(ikl,isn)-epsi)))!
-     .                 *(1 -min (abs(isnoSV(ikl)        ! Switch = 1
-     .                              -iiceSV(ikl)-1),1)) !   if isno = iice + 1
-C +                                                     !
-     .                 +max(0,                          ! Ice
-     .                      min (1,                     ! Switch
-     .                           iiceSV(ikl)+1-isn)))   !
-     .             *min(unun,                                    !
-     .                  max(zero,                                ! combination
-     .                      sign(unun,G1snSV(ikl,      isn  )    ! G1>0 + G1<0
-     .                               *G1snSV(ikl,max(1,isn-1)))) ! NO
-     .                + max(zero,                                !
-     .                      sign(unun,G1snSV(ikl,      isn   ))) !
-     .                + max(zero,                                !
-     .                      sign(unun,dzxmin                     !
-     .                               -dzsnSV(ikl,      isn   ))))!
-          i_thin(ikl) =    (1. - OKthin)  * i_thin(ikl) ! Update   thinest Lay.
-     .                         + OKthin   * isn         !                Index
-        END DO
-      END DO
- 
-
-
- 
-C +   ***************
-      CALL SISVAT_zCr
-C +   ***************
- 
- 
-C +--Assign the 2 Layers to agregate
-C +  -------------------------------
- 
-        DO ikl=1,knonv
-          isn         =    i_thin(ikl)
-          if(LIndsv(ikl)>0) isn=min(nsno-1,isn) ! cXF
-          isagr1(ikl) =    istoSV(ikl,isn)
-          isagr2(ikl) =    istoSV(ikl,isn+LIndsv(ikl))
-          dzagr1(ikl) =    dzsnSV(ikl,isn)
-          dzagr2(ikl) =    dzsnSV(ikl,isn+LIndsv(ikl))
-          T_agr1(ikl) =    TsisSV(ikl,isn)
-          T_agr2(ikl) =    TsisSV(ikl,isn+LIndsv(ikl))
-          roagr1(ikl) =    ro__SV(ikl,isn)
-          roagr2(ikl) =    ro__SV(ikl,isn+LIndsv(ikl))
-          etagr1(ikl) =    eta_SV(ikl,isn)
-          etagr2(ikl) =    eta_SV(ikl,isn+LIndsv(ikl))
-          G1agr1(ikl) =    G1snSV(ikl,isn)
-          G1agr2(ikl) =    G1snSV(ikl,isn+LIndsv(ikl))
-          G2agr1(ikl) =    G2snSV(ikl,isn)
-          G2agr2(ikl) =    G2snSV(ikl,isn+LIndsv(ikl))
-          agagr1(ikl) =    agsnSV(ikl,isn)
-          agagr2(ikl) =    agsnSV(ikl,isn+LIndsv(ikl))
-          LstLay      = min(1,max(  0,isnoSV(ikl) -1))  ! 0  if single Layer
-          isnoSV(ikl) =               isnoSV(ikl)       ! decrement   isnoSV
-     .     -(1-LstLay)* max(zero,                       ! if downmost  Layer
-     .                      sign(unun,eps_21            ! <  1.e-21 m
-     .                               -dzsnSV(ikl,1)))   !
-          isnoSV(ikl) = max(   0,     isnoSV(ikl)   )   !
-          Agrege(ikl) = max(zero,                       !
-     .                      sign(unun,dz_min            ! No Agregation
-     .                               -dzagr1(ikl)  ))   ! if too thick Layer
-     .                               *LstLay            ! if  a single Layer
-     .                * min( max(0   ,isnoSV(ikl)+1     ! if Agregation
-     .                               -i_thin(ikl)       !    with    a Layer
-     .                               -LIndsv(ikl)  ),1) !    above the Pack
- 
-          WEagre(ikl) = 0.
-        END DO
- 
- 
-        DO ikl=1,knonv
-        DO   isn=1,isnoSV(ikl)
-          WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn)
-     .                                *min(1,max(0,i_thin(ikl)+1-isn))
-        ENDDO
-        ENDDO
- 
- 
-C +--Agregates
-C +  ---------
- 
-C +     ***************
-        CALL SISVAT_zAg
-     .                 (isagr1,isagr2,WEagre
-     .                 ,dzagr1,dzagr2,T_agr1,T_agr2
-     .                 ,roagr1,roagr2,etagr1,etagr2
-     .                 ,G1agr1,G1agr2,G2agr1,G2agr2
-     .                 ,agagr1,agagr2,Agrege
-     .                 )
-C +     ***************
- 
- 
-C +--Rearranges the Layers
-C +  ---------------------
- 
-C +--New (agregated) Snow layer
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=1,knonv
-          isn     =             i_thin(ikl)
-          isn     = min(isn,isn+LIndsv(ikl))
-          isnoSV(ikl) =  max(0.,isnoSV(ikl) -Agrege(ikl))
-          iiceSV(ikl) =         iiceSV(ikl)
-     .            -max(0,sign(1,iiceSV(ikl) -isn +icemix))
-     .                                      *Agrege(ikl)
-     .            *max(0,sign(1,iiceSV(ikl) -1          ))
-          istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)
-     .                      +   Agrege(ikl) *isagr1(ikl)
-          dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)
-     .                      +   Agrege(ikl) *dzagr1(ikl)
-          TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)
-     .                      +   Agrege(ikl) *T_agr1(ikl)
-          ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)
-     .                      +   Agrege(ikl) *roagr1(ikl)
-          eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)
-     .                      +   Agrege(ikl) *etagr1(ikl)
-          G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)
-     .                      +   Agrege(ikl) *G1agr1(ikl)
-          G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)
-     .                      +   Agrege(ikl) *G2agr1(ikl)
-          agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)
-     .                      +   Agrege(ikl) *agagr1(ikl)
-        END DO
- 
-C +--Above
-C +  ^^^^^
-        DO ikl=1,knonv
-          isn1(ikl)=max(i_thin(ikl),i_thin(ikl)+LIndsv(ikl))
-        END DO
-        DO i=  1,nsno-1
-        DO ikl=1,knonv
-            staggr        =  min(1,max(0,i +1 -isn1(ikl)   ))
-            istoSV(ikl,i) = (1.-staggr     )*istoSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*istoSV(ikl,i  )
-     .                      +   Agrege(ikl) *istoSV(ikl,i+1))
-            dzsnSV(ikl,i) = (1.-staggr     )*dzsnSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i  )
-     .                      +   Agrege(ikl) *dzsnSV(ikl,i+1))
-            TsisSV(ikl,i) = (1.-staggr     )*TsisSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i  )
-     .                      +   Agrege(ikl) *TsisSV(ikl,i+1))
-            ro__SV(ikl,i) = (1.-staggr     )*ro__SV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i  )
-     .                      +   Agrege(ikl) *ro__SV(ikl,i+1))
-            eta_SV(ikl,i) = (1.-staggr     )*eta_SV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i  )
-     .                      +   Agrege(ikl) *eta_SV(ikl,i+1))
-            G1snSV(ikl,i) = (1.-staggr     )*G1snSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i  )
-     .                      +   Agrege(ikl) *G1snSV(ikl,i+1))
-            G2snSV(ikl,i) = (1.-staggr     )*G2snSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i  )
-     .                      +   Agrege(ikl) *G2snSV(ikl,i+1))
-            agsnSV(ikl,i) = (1.-staggr     )*agsnSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i  )
-     .                      +   Agrege(ikl) *agsnSV(ikl,i+1))
-        END DO
-        END DO
- 
-        DO ikl=1,knonv
-          isn             = min(isnoSV(ikl) +1,nsno)
-          istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)
-          dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)
-          TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)
-          ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)
-          eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)
-          G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)
-          G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)
-          agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)
-        END DO
- 
-
- 
- 
-C +--Constrains Splitting          of too thick Layers
-C +  =================================================
- 
- 
-C +--Search the thickest non-zero Layer
-C +  ----------------------------------
- 
-        DO ikl=1,knonv
-          dzthin(ikl) =   0.                            ! Arbitrary unrealistic
-        END DO
-      DO ikl=1,knonv
-        DO   isn=1,isnoSV(ikl)
-          isno_n    =             isnoSV(ikl)-isn+1     ! Snow Normal.Profile
-          iice_n    =             iiceSV(ikl)-isn       ! Ice  Normal.Profile
-          iiceOK    = min(1,max(0,iice_n         +1))   ! Ice         Switch
-          dz_dif    =(      dzsnSV(ikl,isn)             ! Actual      Profile
-     .        - dz_max *((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
-     .                 +    iiceOK *2.   **iice_n)  )   !
-     .                 /max(dzsnSV(ikl,isn),epsi)       !
-          OKthin      = max(zero,                       !
-     .                      sign(unun,                  !
-     .                           dz_dif-dzthin(ikl)))   ! 1.=>New thickest Lay.
-     .                * max(0,                          ! 1 =>.le. isnoSV
-     .                  min(1,                          !
-     .                      isnoSV(ikl)-isn +1 ))       !
-          i_thin(ikl) =    (1. - OKthin)  * i_thin(ikl) !  Update thickest Lay.
-     .                         + OKthin   * isn         !                Index
-          dzthin(ikl) =    (1. - OKthin)  * dzthin(ikl) !
-     .                         + OKthin   * dz_dif      !
-        END DO
- 
-        isn=max(1,isnoSV(ikl)-3)
-        if(dzsnSV(ikl,isn)>0.30) then   ! surface layer > 30cm
-         i_thin(ikl) = isn              ! XF 04/07/2019
-         dzthin(ikl) = dzsnSV(ikl,isn)
-        endif
- 
-        isn=max(1,isnoSV(ikl)-2)
-        if(dzsnSV(ikl,isn)>0.10) then   ! surface layer > 10cm
-         i_thin(ikl) = isn              ! XF 04/07/2019
-         dzthin(ikl) = dzsnSV(ikl,isn)
-        endif
- 
-        isn=max(1,isnoSV(ikl)-1)
-        if(dzsnSV(ikl,isn)>0.05) then   ! surface layer > 5cm
-         i_thin(ikl) = isn              ! XF 04/07/2019
-         dzthin(ikl) = dzsnSV(ikl,isn)
-        endif
- 
-        isn=max(1,isnoSV(ikl))
-        if(dzsnSV(ikl,isn)>0.02) then   ! surface layer > 2cm
-         i_thin(ikl) = isn              ! XF 04/07/2019
-         dzthin(ikl) = dzsnSV(ikl,isn)
-        endif
- 
-      END DO
- 
-      DO   ikl=1,knonv
-          ThickL      = max(zero,                       ! 1. => a too   thick
-     .                      sign(unun,dzthin(ikl)       !         Layer exists
-     .                               -epsi       ))     !
-     .        * max(0,1-max(0   ,     isnoSV(ikl)       ! No spliting allowed
-     .                               -nsno+1     ))     ! if isno > nsno - 1
-          Agrege(ikl) =               ThickL            ! 1. => effective split
-     .        * max(0,1-max(0   ,     NLaysv(ikl)       !
-     .                               +isnoSV(ikl)       !
-     .                               -nsno+1     ))     !
-          NLay_s(ikl) =               ThickL            ! Agregation
-     .        * max(0,1-max(0   ,     NLaysv(ikl)       ! to allow  Splitting
-     .                               +isnoSV(ikl)       !   at next Time Step
-     .                               -nsno       ))     !
-     .                               -Agrege(ikl)       !
-          NLay_s(ikl) = max(0   ,     NLay_s(ikl))      ! Agregation effective
-      END DO
- 
-
-C +--Rearranges the Layers
-C +  ---------------------
- 
-      DO isn=nsno,2,-1
-      DO ikl=1,knonv
-        IF (Agrege(ikl)>0..AND.i_thin(ikl)<isnoSV(ikl))       THEN
-          staggr          =  min(1,max(0,isn-i_thin(ikl)    -1))
-     .                    *  min(1,max(0,    isnoSV(ikl)-isn+2))
-          istoSV(ikl,isn) =        staggr  * istoSV(ikl ,isn-1)
-     .                    + (1. -  staggr) * istoSV(ikl ,isn  )
-          dzsnSV(ikl,isn) =        staggr  * dzsnSV(ikl ,isn-1)
-     .                    + (1. -  staggr) * dzsnSV(ikl ,isn  )
-          TsisSV(ikl,isn) =        staggr  * TsisSV(ikl ,isn-1)
-     .                    + (1. -  staggr) * TsisSV(ikl ,isn  )
-          ro__SV(ikl,isn) =        staggr  * ro__SV(ikl ,isn-1)
-     .                    + (1. -  staggr) * ro__SV(ikl ,isn  )
-          eta_SV(ikl,isn) =        staggr  * eta_SV(ikl ,isn-1)
-     .                    + (1. -  staggr) * eta_SV(ikl ,isn  )
-          G1snSV(ikl,isn) =        staggr  * G1snSV(ikl ,isn-1)
-     .                    + (1. -  staggr) * G1snSV(ikl ,isn  )
-          G2snSV(ikl,isn) =        staggr  * G2snSV(ikl ,isn-1)
-     .                    + (1. -  staggr) * G2snSV(ikl ,isn  )
-          agsnSV(ikl,isn) =        staggr  * agsnSV(ikl ,isn-1)
-     .                    + (1. -  staggr) * agsnSV(ikl ,isn  )
-        END IF
-      END DO
-      END DO
- 
-      DO  ikl=1,knonv
-          isn             =     i_thin(ikl)
-          dzsnSV(ikl,isn) = 0.5*Agrege(ikl) *dzsnSV(ikl,isn)
-     .                    + (1.-Agrege(ikl))*dzsnSV(ikl,isn)
- 
-          isn             = min(i_thin(ikl) +1,nsno)
-          istoSV(ikl,isn) =     Agrege(ikl) *istoSV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*istoSV(ikl,isn)
-          dzsnSV(ikl,isn) =     Agrege(ikl) *dzsnSV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*dzsnSV(ikl,isn)
-          TsisSV(ikl,isn) =     Agrege(ikl) *TsisSV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*TsisSV(ikl,isn)
-          ro__SV(ikl,isn) =     Agrege(ikl) *ro__SV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*ro__SV(ikl,isn)
-          eta_SV(ikl,isn) =     Agrege(ikl) *eta_SV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*eta_SV(ikl,isn)
-          G1snSV(ikl,isn) =     Agrege(ikl) *G1snSV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*G1snSV(ikl,isn)
-          G2snSV(ikl,isn) =     Agrege(ikl) *G2snSV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*G2snSV(ikl,isn)
-          agsnSV(ikl,isn) =     Agrege(ikl) *agsnSV(ikl,isn-1)
-     .                    + (1.-Agrege(ikl))*agsnSV(ikl,isn)
-          isnoSV(ikl)     = min(Agrege(ikl) +isnoSV(ikl),real(nsno))
-          iiceSV(ikl)     =                  iiceSV(ikl)
-     .                    +     Agrege(ikl) *max(0,sign(1,iiceSV(ikl)
-     .                                                   -isn +icemix))
-     .                                      *max(0,sign(1,iiceSV(ikl)
-     .                                                   -1          ))
-      END DO
- 
- 
-C +--Constrains Agregation in case of too much  Layers
-C +  =================================================
- 
-C +--Search the thinest   non-zero Layer
-C +  -----------------------------------
-
-
- 
-        DO ikl=1,knonv
-          dzthin(ikl) =   0.                            ! Arbitrary unrealistic
-        END DO                                          !       Layer Thickness
-      DO ikl=1,knonv
-        DO isn=1,isnoSV(ikl)-3 ! no agregation of 3 first snowlayers
-                               ! XF 04/07/2019
- 
-          isno_n    =             isnoSV(ikl)-isn+1     ! Snow Normal.Profile
-          iice_n    =             iiceSV(ikl)-isn       ! Ice  Normal.Profile
-          iiceOK    = min(1,max(0,iice_n         +1))   ! Ice         Switch
-! #vz     dz_ref(isn) =                                 !
-! #vz.          dz_min *((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
-! #vz.                 +    iiceOK *    2**iice_n)      !
-! #vz.               /max(1,isnoSV(ikl))                !
-          dz_dif      =     dz_min                      ! Actual      Profile
-     .                    - dzsnSV(ikl    ,isn)         !
-     .        /max(epsi,((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
-     .                 +    iiceOK *2.   **iice_n))     !
-! #vz     dzwdif(isn) =     dz_dif                      !
-          OKthin      = max(zero,                       !
-     .                      sign(unun,                  !
-     .                           dz_dif  - dzthin(ikl)))! 1.=> New thinest Lay.
-     .                * max(0,                          ! 1 => .le. isnoSV
-     .                  min(1,                          !
-     .                      isnoSV(ikl)-isn +1 ))       !
-          i_thin(ikl) =    (1. - OKthin) * i_thin(ikl)  ! Update   thinest Lay.
-     .                         + OKthin  * isn          !                Index
-          dzthin(ikl) =    (1. - OKthin) * dzthin(ikl)  !
-     .                         + OKthin  * dz_dif       !
-
-
-        END DO
-      END DO
- 
- 
-
-
-
-C +--Index of the contiguous Layer to agregate
-C +  -----------------------------------------
- 
-C +   ***************
-      CALL SISVAT_zCr
-C +   ***************
- 
- 
-C +--Assign the 2 Layers to agregate
-C +  -------------------------------
- 
-        DO ikl=1,knonv
-          isn         =    i_thin(ikl)
-          if(LIndsv(ikl)>0) isn=min(isn, nsno-1) !cXF
-          isagr1(ikl) =    istoSV(ikl,isn)
-          isagr2(ikl) =    istoSV(ikl,isn+LIndsv(ikl))
-          dzagr1(ikl) =    dzsnSV(ikl,isn)
-          dzagr2(ikl) =    dzsnSV(ikl,isn+LIndsv(ikl))
-          T_agr1(ikl) =    TsisSV(ikl,isn)
-          T_agr2(ikl) =    TsisSV(ikl,isn+LIndsv(ikl))
-          roagr1(ikl) =    ro__SV(ikl,isn)
-          roagr2(ikl) =    ro__SV(ikl,isn+LIndsv(ikl))
-          etagr1(ikl) =    eta_SV(ikl,isn)
-          etagr2(ikl) =    eta_SV(ikl,isn+LIndsv(ikl))
-          G1agr1(ikl) =    G1snSV(ikl,isn)
-          G1agr2(ikl) =    G1snSV(ikl,isn+LIndsv(ikl))
-          G2agr1(ikl) =    G2snSV(ikl,isn)
-          G2agr2(ikl) =    G2snSV(ikl,isn+LIndsv(ikl))
-          agagr1(ikl) =    agsnSV(ikl,isn)
-          agagr2(ikl) =    agsnSV(ikl,isn+LIndsv(ikl))
-          LstLay      = min(1,max(  0,    isnoSV(ikl)-1   ))
-          Agrege(ikl) = min(1,
-     .                  max(0,
-     .                      NLaysv(ikl)   +isnoSV(ikl)-nsno
-     .                     +NLay_s(ikl)                    )
-     .                                    *LstLay           )
- 
-C + minimum uppermost layer thickness to guarantee a correct reproduction of the snow
-C + atmosphere coupling
-        if(dzsnSV(ikl,max(1,isnoSV(ikl)-0))>0.02 .or.   ! surface layers> 2-5-10
-     .     dzsnSV(ikl,max(1,isnoSV(ikl)-1))>0.05 .or.   ! XF 04/07/2019
-     .     dzsnSV(ikl,max(1,isnoSV(ikl)-2))>0.10 .or.
-     .     dzsnSV(ikl,max(1,isnoSV(ikl)-3))>0.30 )then
-          Agrege(ikl) = min(1,
-     .                  max(0,
-     .                      NLaysv(ikl)   +isnoSV(ikl)+1-nsno ! nsno-1 layers ma
-     .                     +NLay_s(ikl)                    )
-     .                                    *LstLay           )
-        endif
- 
-          isnoSV(ikl) =                    isnoSV(ikl)
-     .     -(1-LstLay)*max(zero,
-     .                     sign(unun,      eps_21
-     .                                    -dzsnSV(ikl,1)   ))
-          isnoSV(ikl) =max(   0,           isnoSV(ikl)      )
- 
-          WEagre(ikl) = 0.
-        END DO
- 
-        DO isn=1,nsno
-        DO ikl=1,knonv
-          WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn)
-     .                                *min(1,max(0,i_thin(ikl)+1-isn))
-        ENDDO
-        ENDDO
-
-C +--Agregates
-C +  ---------
- 
-C +     ***************
-        CALL SISVAT_zAg
-     .                 (isagr1,isagr2,WEagre
-     .                 ,dzagr1,dzagr2,T_agr1,T_agr2
-     .                 ,roagr1,roagr2,etagr1,etagr2
-     .                 ,G1agr1,G1agr2,G2agr1,G2agr2
-     .                 ,agagr1,agagr2,Agrege
-     .                 )
-C +     ***************
- 
- 
-C +--Rearranges the Layers
-C +  ---------------------
- 
-C +--New (agregated) Snow layer
-C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO ikl=1,knonv
-          isn     =             i_thin(ikl)
-          isn     = min(isn,isn+LIndsv(ikl))
-          isnoSV(ikl) =  max(0.,isnoSV(ikl) -Agrege(ikl))
-          iiceSV(ikl) =         iiceSV(ikl)
-     .            -max(0,sign(1,iiceSV(ikl) -isn +icemix))
-     .                                      *Agrege(ikl)
-     .            *max(0,sign(1,iiceSV(ikl) -1          ))
-          istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)
-     .                      +   Agrege(ikl) *isagr1(ikl)
-          dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)
-     .                      +   Agrege(ikl) *dzagr1(ikl)
-          TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)
-     .                      +   Agrege(ikl) *T_agr1(ikl)
-          ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)
-     .                      +   Agrege(ikl) *roagr1(ikl)
-          eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)
-     .                      +   Agrege(ikl) *etagr1(ikl)
-          G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)
-     .                      +   Agrege(ikl) *G1agr1(ikl)
-          G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)
-     .                      +   Agrege(ikl) *G2agr1(ikl)
-          agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)
-     .                      +   Agrege(ikl) *agagr1(ikl)
-        END DO
- 
-C +--Above
-C +  ^^^^^
-        DO ikl=1,knonv
-          isn1(ikl)=max(i_thin(ikl),i_thin(ikl)+LIndsv(ikl))
-        END DO
-        DO i=  1,nsno-1
-        DO ikl=1,knonv
-            staggr        =  min(1,max(0,i +1 -isn1(ikl)   ))
-            istoSV(ikl,i) = (1.-staggr     )*istoSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*istoSV(ikl,i  )
-     .                      +   Agrege(ikl) *istoSV(ikl,i+1))
-            dzsnSV(ikl,i) = (1.-staggr     )*dzsnSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i  )
-     .                      +   Agrege(ikl) *dzsnSV(ikl,i+1))
-            TsisSV(ikl,i) = (1.-staggr     )*TsisSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i  )
-     .                      +   Agrege(ikl) *TsisSV(ikl,i+1))
-            ro__SV(ikl,i) = (1.-staggr     )*ro__SV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i  )
-     .                      +   Agrege(ikl) *ro__SV(ikl,i+1))
-            eta_SV(ikl,i) = (1.-staggr     )*eta_SV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i  )
-     .                      +   Agrege(ikl) *eta_SV(ikl,i+1))
-            G1snSV(ikl,i) = (1.-staggr     )*G1snSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i  )
-     .                      +   Agrege(ikl) *G1snSV(ikl,i+1))
-            G2snSV(ikl,i) = (1.-staggr     )*G2snSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i  )
-     .                      +   Agrege(ikl) *G2snSV(ikl,i+1))
-            agsnSV(ikl,i) = (1.-staggr     )*agsnSV(ikl,i  )
-     .            + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i  )
-     .                      +   Agrege(ikl) *agsnSV(ikl,i+1))
-        END DO
-        END DO
- 
-        DO ikl=1,knonv
-          isn             = min(isnoSV(ikl) +1,nsno)
-          istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)
-          dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)
-          TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)
-          ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)
-          eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)
-          G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)
-          G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)
-          agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)
-        END DO
-
-
-C +--Search new Ice/Snow Interface (option II in MAR)
-C +  ===============================================
-
-        IF (ok_zsn_ii) THEN 
-        
-        DO ikl=1,knonv
-          iiceSV(ikl) =  0
-        END DO
- 
-        DO ikl=1,knonv
-        DO   isn=1,isnoSV(ikl)
-          OK_ICE      = max(zero,sign(unun,ro__SV(ikl,isn)-ro_ice+20.))
-     .                * max(zero,sign(unun,dzsnSV(ikl,isn)-epsi))
-          iiceSV(ikl) = (1.-OK_ICE)       *iiceSV(ikl)
-     .                +     OK_ICE        *isn
-        END DO
-        END DO
-
-        END IF
- 
-      return
-      end
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zsn.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zsn.f90	(revision 5105)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zsn.f90	(revision 5105)
@@ -0,0 +1,741 @@
+
+
+SUBROUTINE SISVAT_zSn
+
+  ! +------------------------------------------------------------------------+
+  ! | MAR          SISVAT_zSn                                12-07-2019  MAR |
+  ! |   SubRoutine SISVAT_zSn manages the Snow Pack vertical Discretization  |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+  ! |                                                                        |
+  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
+  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+  ! |                     X       Number of Mosaic Cell per grid box         |
+  ! |                                                                        |
+  ! |   INPUT /  NLaysv   = New             Snow Layer  Switch               |
+  ! |   OUTPUT:  isnoSV   = total Nb of Ice/Snow Layers                      |
+  ! |   ^^^^^^   ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
+  ! |            iiceSV   = total Nb of Ice      Layers                      |
+  ! |            istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
+  ! |                                                                        |
+  ! |   INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+  ! |   OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
+  ! |   ^^^^^^   ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
+  ! |            eta_SV   : Soil/Snow Water   Content                [m3/m3] |
+  ! |            dzsnSV   : Snow Layer        Thickness                  [m] |
+  ! |            G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+  ! |            G2snSV   : Sphericity (>0) or Size            of Snow Layer |
+  ! |            agsnSV   : Snow       Age                             [day] |
+  ! |                                                                        |
+  ! |   METHOD:  1) Agregate the thinest Snow Layer                          |
+  ! |   ^^^^^^      if a new Snow Layer has been precipitated   (NLaysv = 1) |
+  ! |            2) Divide   a too thick Snow Layer except                   |
+  ! |               if the maximum Number of Layer is reached                |
+  ! |               in this case forces                          NLay_s = 1  |
+  ! |            3) Agregate the thinest Snow Layer                          |
+  ! |               in order to divide a too thick Snow Layer                |
+  ! |               at next Time Step when                       NLay_s = 1  |
+  ! |                                                                        |
+  ! +------------------------------------------------------------------------+
+
+
+
+
+  ! +--Global Variables
+  ! +  ================
+
+
+  use VARphy
+  use VAR_SV
+  use VARdSV
+  use VAR0SV
+  use VARxSV
+  use VARySV
+  use surface_data, only: ok_zsn_ii
+
+  IMPLICIT NONE
+
+
+  ! +--Internal Variables
+  ! +  ==================
+
+  integer :: ikl   ,isn   ,i               !
+
+
+
+
+
+
+  integer :: NLay_s(knonv)                 ! Split Snow Layer         Switch
+  integer :: isagr1(knonv)                 ! 1st     Layer History
+  integer :: isagr2(knonv)                 ! 2nd     Layer History
+  integer :: LstLay                        ! 0 ====> isnoSV = 1
+  integer :: isno_n                        ! Snow Normal.Profile
+  integer :: iice_n                        ! Ice  Normal.Profile
+  integer :: iiceOK                        ! Ice         Switch
+  integer :: icemix                        ! 0 ====> Agregated Snow+Ice=Snow
+  ! +                                           ! 1                          Ice
+  integer :: isn1  (knonv)                 ! 1st layer to stagger
+  real :: staggr                        !              stagger  Switch
+
+  real :: WEagre(knonv)                 ! Snow Water Equivalent Thickness
+  real :: dzthin(knonv)                 ! Thickness of the thinest layer
+  real :: OKthin                        ! Swich ON  a  new thinest layer
+  real :: dz_dif                        ! difference from ideal discret.
+  real :: thickL                        ! Thick Layer          Indicator
+  real :: OK_ICE                        ! Swich ON   uppermost Ice Layer
+
+  real :: Agrege(knonv)                 ! 1. when Agregation constrained
+  real :: dzepsi                        ! Min Single Snw Layer Thickness
+  real :: dzxmin                        ! Min Acceptable Layer Thickness
+  real :: dz_min                        ! Min            Layer Thickness
+  real :: dz_max                        ! Max            Layer Thickness
+  real :: dzagr1(knonv)                 ! 1st     Layer Thickness
+  real :: dzagr2(knonv)                 ! 2nd     Layer Thickness
+  real :: T_agr1(knonv)                 ! 1st     Layer Temperature
+  real :: T_agr2(knonv)                 ! 2nd     Layer Temperature
+  real :: roagr1(knonv)                 ! 1st     Layer Density
+  real :: roagr2(knonv)                 ! 2nd     Layer Density
+  real :: etagr1(knonv)                 ! 1st     Layer Water Content
+  real :: etagr2(knonv)                 ! 2nd     Layer Water Content
+  real :: G1agr1(knonv)                 ! 1st     Layer Dendricity/Spher.
+  real :: G1agr2(knonv)                 ! 2nd     Layer Dendricity/Spher.
+  real :: G2agr1(knonv)                 ! 1st     Layer Sphericity/Size
+  real :: G2agr2(knonv)                 ! 2nd     Layer Sphericity/Size
+  real :: agagr1(knonv)                 ! 1st     Layer Age
+  real :: agagr2(knonv)                 ! 2nd     Layer Age
+
+
+  ! +--DATA
+  ! +  ====
+
+  data      icemix /   0    /             ! 0 ====> Agregated Snow+Ice=Snow
+  data      dzepsi /   0.0020/            ! Min single Layer Thickness
+  data      dzxmin /   0.0025/            ! Min accept.Layer Thickness
+  ! #EU data      dz_min /   0.0050/            ! Min Local  Layer Thickness < SMn
+  data      dz_min /   0.0040/            ! Min Local  Layer Thickness < SMn
+  data      dz_max /   0.0300/            ! Min Gener. Layer Thickness
+  ! +   CAUTION:  dz_max > dz_min*2 is required ! Otherwise re-agregation is
+  ! +                                           ! activated  after splitting
+
+
+
+
+
+  ! +--Constrains Agregation         of too thin  Layers
+  ! +  =================================================
+
+  ! +--Search the thinest  non-zero Layer
+  ! +  ----------------------------------
+
+    DO ikl=1,knonv
+      if(isnoSV(ikl)<=2)             dz_min=max(0.0050,dz_min)
+
+                                      dzepsi=0.0015
+      if(ro__SV(ikl,isnoSV(ikl))>920) dzepsi=0.0020
+
+      dzthin(ikl) = 0.                              ! Arbitrary unrealistic
+    END DO                                          !       Layer Thickness
+  !XF
+  DO ikl=1,knonv
+  DO   isn=1,isnoSV(ikl)-3 ! no agregation of 3 first snowlayers
+                           ! ! XF 04/07/2019
+
+      isno_n    =             isnoSV(ikl)-isn+1     ! Snow Normal.Profile
+      iice_n    =             iiceSV(ikl)-isn       ! Ice  Normal.Profile
+      iiceOK    = min(1,max(0,iice_n         +1))   ! Ice         Switch
+  ! #vz     dz_ref(isn) =                                 !
+  ! #vz.          dz_min *((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
+  ! #vz.                 +    iiceOK *    2**iice_n)      !
+  ! #vz.               /max(1,isnoSV(ikl))                !
+      dz_dif      = max(zero, & ! Actual      Profile
+            dz_min & !
+            *((1-iiceOK)*isno_n*isno_n & ! Theoretical Profile
+            +    iiceOK *2.   **iice_n) & !
+            - dzsnSV(ikl, isn)                    )   ! Actual      Profile
+  ! #vz     dzwdif(isn) =     dz_dif                      !
+      OKthin      = max(zero, & !
+            sign(unun, & !
+            dz_dif-dzthin(ikl))) & ! 1.=> New thinest Lay.
+            * max(0, & ! 1 => .le. isnoSV
+            min(1, & ! 1 => isn is in the
+            isnoSV(ikl)-isn +1 )) & !          Snow Pack
+            * min(unun, & !
+
+                    ! 1st additional Condition to accept OKthin
+            max(zero, & ! combination
+            sign(unun,G1snSV(ikl,      isn  ) & ! G1 with same
+            *G1snSV(ikl,max(1,isn-1)))) & !  sign => OK
+
+                    ! 2nd additional Condition to accept OKthin
+            + max(zero, & ! G1>0
+            sign(unun,G1snSV(ikl,      isn   ))) & !  =>OK
+
+                    ! 3rd additional Condition to accept OKthin
+            + max(zero, & ! dz too small
+            sign(unun,dzxmin & !  =>OK
+            -dzsnSV(ikl,      isn   ))))!
+
+      i_thin(ikl) =    (1. - OKthin)  * i_thin(ikl) & ! Update   thinest Lay.
+            + OKthin   * isn         !                Index
+      dzthin(ikl) =    (1. - OKthin)  * dzthin(ikl) & !
+            + OKthin   * dz_dif      !
+    END DO
+  END DO
+
+
+
+  DO ikl=1,knonv
+  DO   isn=1,isnoSV(ikl)
+      OKthin =      max(zero, & !
+            sign(unun, & !
+            dz_min & !
+            -dzsnSV(ikl,isn))) & !
+            * max(zero, & ! ON if dz > 0
+            sign(unun, & !
+            dzsnSV(ikl,isn)-epsi)) & !
+            *min(1,max(0, & ! Multiple Snow    Lay.
+            min (1, & ! Switch = 1
+            isnoSV(ikl) & !   if isno > iice + 1
+            -iiceSV(ikl)-1)) & !
+  ! +                                                     !
+            +int(max(zero, & !
+            sign(unun, & !
+            dzepsi & ! Minimum accepted for
+            -dzsnSV(ikl,isn)))) & ! 1 Snow Layer over Ice
+            *int(max(zero, & ! ON if dz > 0
+            sign(unun, & !
+            dzsnSV(ikl,isn)-epsi))) & !
+            *(1 -min (abs(isnoSV(ikl) & ! Switch = 1
+            -iiceSV(ikl)-1),1)) & !   if isno = iice + 1
+  ! +                                                     !
+            +max(0, & ! Ice
+            min (1, & ! Switch
+            iiceSV(ikl)+1-isn))) & !
+            *min(unun, & !
+            max(zero, & ! combination
+            sign(unun,G1snSV(ikl,      isn  ) & ! G1>0 + G1<0
+            *G1snSV(ikl,max(1,isn-1)))) & ! NO
+            + max(zero, & !
+            sign(unun,G1snSV(ikl,      isn   ))) & !
+            + max(zero, & !
+            sign(unun,dzxmin & !
+            -dzsnSV(ikl,      isn   ))))!
+      i_thin(ikl) =    (1. - OKthin)  * i_thin(ikl) & ! Update   thinest Lay.
+            + OKthin   * isn         !                Index
+    END DO
+  END DO
+
+
+
+
+  ! +   ***************
+  CALL SISVAT_zCr
+  ! +   ***************
+
+
+  ! +--Assign the 2 Layers to agregate
+  ! +  -------------------------------
+
+    DO ikl=1,knonv
+      isn         =    i_thin(ikl)
+      if(LIndsv(ikl)>0) isn=min(nsno-1,isn) ! cXF
+      isagr1(ikl) =    istoSV(ikl,isn)
+      isagr2(ikl) =    istoSV(ikl,isn+LIndsv(ikl))
+      dzagr1(ikl) =    dzsnSV(ikl,isn)
+      dzagr2(ikl) =    dzsnSV(ikl,isn+LIndsv(ikl))
+      T_agr1(ikl) =    TsisSV(ikl,isn)
+      T_agr2(ikl) =    TsisSV(ikl,isn+LIndsv(ikl))
+      roagr1(ikl) =    ro__SV(ikl,isn)
+      roagr2(ikl) =    ro__SV(ikl,isn+LIndsv(ikl))
+      etagr1(ikl) =    eta_SV(ikl,isn)
+      etagr2(ikl) =    eta_SV(ikl,isn+LIndsv(ikl))
+      G1agr1(ikl) =    G1snSV(ikl,isn)
+      G1agr2(ikl) =    G1snSV(ikl,isn+LIndsv(ikl))
+      G2agr1(ikl) =    G2snSV(ikl,isn)
+      G2agr2(ikl) =    G2snSV(ikl,isn+LIndsv(ikl))
+      agagr1(ikl) =    agsnSV(ikl,isn)
+      agagr2(ikl) =    agsnSV(ikl,isn+LIndsv(ikl))
+      LstLay      = min(1,max(  0,isnoSV(ikl) -1))  ! 0  if single Layer
+      isnoSV(ikl) =               isnoSV(ikl) & ! decrement   isnoSV
+            -(1-LstLay)* max(zero, & ! if downmost  Layer
+            sign(unun,eps_21 & ! <  1.e-21 m
+            -dzsnSV(ikl,1)))   !
+      isnoSV(ikl) = max(   0,     isnoSV(ikl)   )   !
+      Agrege(ikl) = max(zero, & !
+            sign(unun,dz_min & ! No Agregation
+            -dzagr1(ikl)  )) & ! if too thick Layer
+            *LstLay & ! if  a single Layer
+            * min( max(0   ,isnoSV(ikl)+1 & ! if Agregation
+            -i_thin(ikl) & !    with    a Layer
+            -LIndsv(ikl)  ),1) !    above the Pack
+
+      WEagre(ikl) = 0.
+    END DO
+
+
+    DO ikl=1,knonv
+    DO   isn=1,isnoSV(ikl)
+      WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn) &
+            *min(1,max(0,i_thin(ikl)+1-isn))
+    ENDDO
+    ENDDO
+
+
+  ! +--Agregates
+  ! +  ---------
+
+  ! +     ***************
+    CALL SISVAT_zAg &
+          (isagr1,isagr2,WEagre &
+          ,dzagr1,dzagr2,T_agr1,T_agr2 &
+          ,roagr1,roagr2,etagr1,etagr2 &
+          ,G1agr1,G1agr2,G2agr1,G2agr2 &
+          ,agagr1,agagr2,Agrege &
+          )
+  ! +     ***************
+
+
+  ! +--Rearranges the Layers
+  ! +  ---------------------
+
+  ! +--New (agregated) Snow layer
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=1,knonv
+      isn     =             i_thin(ikl)
+      isn     = min(isn,isn+LIndsv(ikl))
+      isnoSV(ikl) =  max(0.,isnoSV(ikl) -Agrege(ikl))
+      iiceSV(ikl) =         iiceSV(ikl) &
+            -max(0,sign(1,iiceSV(ikl) -isn +icemix)) &
+            *Agrege(ikl) &
+            *max(0,sign(1,iiceSV(ikl) -1          ))
+      istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn) &
+            +   Agrege(ikl) *isagr1(ikl)
+      dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn) &
+            +   Agrege(ikl) *dzagr1(ikl)
+      TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn) &
+            +   Agrege(ikl) *T_agr1(ikl)
+      ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn) &
+            +   Agrege(ikl) *roagr1(ikl)
+      eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn) &
+            +   Agrege(ikl) *etagr1(ikl)
+      G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn) &
+            +   Agrege(ikl) *G1agr1(ikl)
+      G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn) &
+            +   Agrege(ikl) *G2agr1(ikl)
+      agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn) &
+            +   Agrege(ikl) *agagr1(ikl)
+    END DO
+
+  ! +--Above
+  ! +  ^^^^^
+    DO ikl=1,knonv
+      isn1(ikl)=max(i_thin(ikl),i_thin(ikl)+LIndsv(ikl))
+    END DO
+    DO i=  1,nsno-1
+    DO ikl=1,knonv
+        staggr        =  min(1,max(0,i +1 -isn1(ikl)   ))
+        istoSV(ikl,i) = (1.-staggr     )*istoSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*istoSV(ikl,i  ) &
+              +   Agrege(ikl) *istoSV(ikl,i+1))
+        dzsnSV(ikl,i) = (1.-staggr     )*dzsnSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i  ) &
+              +   Agrege(ikl) *dzsnSV(ikl,i+1))
+        TsisSV(ikl,i) = (1.-staggr     )*TsisSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i  ) &
+              +   Agrege(ikl) *TsisSV(ikl,i+1))
+        ro__SV(ikl,i) = (1.-staggr     )*ro__SV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i  ) &
+              +   Agrege(ikl) *ro__SV(ikl,i+1))
+        eta_SV(ikl,i) = (1.-staggr     )*eta_SV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i  ) &
+              +   Agrege(ikl) *eta_SV(ikl,i+1))
+        G1snSV(ikl,i) = (1.-staggr     )*G1snSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i  ) &
+              +   Agrege(ikl) *G1snSV(ikl,i+1))
+        G2snSV(ikl,i) = (1.-staggr     )*G2snSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i  ) &
+              +   Agrege(ikl) *G2snSV(ikl,i+1))
+        agsnSV(ikl,i) = (1.-staggr     )*agsnSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i  ) &
+              +   Agrege(ikl) *agsnSV(ikl,i+1))
+    END DO
+    END DO
+
+    DO ikl=1,knonv
+      isn             = min(isnoSV(ikl) +1,nsno)
+      istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)
+      dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)
+      TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)
+      ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)
+      eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)
+      G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)
+      G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)
+      agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)
+    END DO
+
+
+
+
+  ! +--Constrains Splitting          of too thick Layers
+  ! +  =================================================
+
+
+  ! +--Search the thickest non-zero Layer
+  ! +  ----------------------------------
+
+    DO ikl=1,knonv
+      dzthin(ikl) =   0.                            ! Arbitrary unrealistic
+    END DO
+  DO ikl=1,knonv
+    DO   isn=1,isnoSV(ikl)
+      isno_n    =             isnoSV(ikl)-isn+1     ! Snow Normal.Profile
+      iice_n    =             iiceSV(ikl)-isn       ! Ice  Normal.Profile
+      iiceOK    = min(1,max(0,iice_n         +1))   ! Ice         Switch
+      dz_dif    =(      dzsnSV(ikl,isn) & ! Actual      Profile
+            - dz_max *((1-iiceOK)*isno_n*isno_n & ! Theoretical Profile
+            +    iiceOK *2.   **iice_n)  ) & !
+            /max(dzsnSV(ikl,isn),epsi)       !
+      OKthin      = max(zero, & !
+            sign(unun, & !
+            dz_dif-dzthin(ikl))) & ! 1.=>New thickest Lay.
+            * max(0, & ! 1 =>.le. isnoSV
+            min(1, & !
+            isnoSV(ikl)-isn +1 ))       !
+      i_thin(ikl) =    (1. - OKthin)  * i_thin(ikl) & !  Update thickest Lay.
+            + OKthin   * isn         !                Index
+      dzthin(ikl) =    (1. - OKthin)  * dzthin(ikl) & !
+            + OKthin   * dz_dif      !
+    END DO
+
+    isn=max(1,isnoSV(ikl)-3)
+    if(dzsnSV(ikl,isn)>0.30) then   ! surface layer > 30cm
+     i_thin(ikl) = isn              ! XF 04/07/2019
+     dzthin(ikl) = dzsnSV(ikl,isn)
+    endif
+
+    isn=max(1,isnoSV(ikl)-2)
+    if(dzsnSV(ikl,isn)>0.10) then   ! surface layer > 10cm
+     i_thin(ikl) = isn              ! XF 04/07/2019
+     dzthin(ikl) = dzsnSV(ikl,isn)
+    endif
+
+    isn=max(1,isnoSV(ikl)-1)
+    if(dzsnSV(ikl,isn)>0.05) then   ! surface layer > 5cm
+     i_thin(ikl) = isn              ! XF 04/07/2019
+     dzthin(ikl) = dzsnSV(ikl,isn)
+    endif
+
+    isn=max(1,isnoSV(ikl))
+    if(dzsnSV(ikl,isn)>0.02) then   ! surface layer > 2cm
+     i_thin(ikl) = isn              ! XF 04/07/2019
+     dzthin(ikl) = dzsnSV(ikl,isn)
+    endif
+
+  END DO
+
+  DO   ikl=1,knonv
+      ThickL      = max(zero, & ! 1. => a too   thick
+            sign(unun,dzthin(ikl) & !         Layer exists
+            -epsi       )) & !
+            * max(0,1-max(0   ,     isnoSV(ikl) & ! No spliting allowed
+            -nsno+1     ))     ! if isno > nsno - 1
+      Agrege(ikl) =               ThickL & ! 1. => effective split
+            * max(0,1-max(0   ,     NLaysv(ikl) & !
+            +isnoSV(ikl) & !
+            -nsno+1     ))     !
+      NLay_s(ikl) =               ThickL & ! Agregation
+            * max(0,1-max(0   ,     NLaysv(ikl) & ! to allow  Splitting
+            +isnoSV(ikl) & !   at next Time Step
+            -nsno       )) & !
+            -Agrege(ikl)       !
+      NLay_s(ikl) = max(0   ,     NLay_s(ikl))      ! Agregation effective
+  END DO
+
+
+  ! +--Rearranges the Layers
+  ! +  ---------------------
+
+  DO isn=nsno,2,-1
+  DO ikl=1,knonv
+    IF (Agrege(ikl)>0..AND.i_thin(ikl)<isnoSV(ikl))       THEN
+      staggr          =  min(1,max(0,isn-i_thin(ikl)    -1)) &
+            *  min(1,max(0,    isnoSV(ikl)-isn+2))
+      istoSV(ikl,isn) =        staggr  * istoSV(ikl ,isn-1) &
+            + (1. -  staggr) * istoSV(ikl ,isn  )
+      dzsnSV(ikl,isn) =        staggr  * dzsnSV(ikl ,isn-1) &
+            + (1. -  staggr) * dzsnSV(ikl ,isn  )
+      TsisSV(ikl,isn) =        staggr  * TsisSV(ikl ,isn-1) &
+            + (1. -  staggr) * TsisSV(ikl ,isn  )
+      ro__SV(ikl,isn) =        staggr  * ro__SV(ikl ,isn-1) &
+            + (1. -  staggr) * ro__SV(ikl ,isn  )
+      eta_SV(ikl,isn) =        staggr  * eta_SV(ikl ,isn-1) &
+            + (1. -  staggr) * eta_SV(ikl ,isn  )
+      G1snSV(ikl,isn) =        staggr  * G1snSV(ikl ,isn-1) &
+            + (1. -  staggr) * G1snSV(ikl ,isn  )
+      G2snSV(ikl,isn) =        staggr  * G2snSV(ikl ,isn-1) &
+            + (1. -  staggr) * G2snSV(ikl ,isn  )
+      agsnSV(ikl,isn) =        staggr  * agsnSV(ikl ,isn-1) &
+            + (1. -  staggr) * agsnSV(ikl ,isn  )
+    END IF
+  END DO
+  END DO
+
+  DO  ikl=1,knonv
+      isn             =     i_thin(ikl)
+      dzsnSV(ikl,isn) = 0.5*Agrege(ikl) *dzsnSV(ikl,isn) &
+            + (1.-Agrege(ikl))*dzsnSV(ikl,isn)
+
+      isn             = min(i_thin(ikl) +1,nsno)
+      istoSV(ikl,isn) =     Agrege(ikl) *istoSV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*istoSV(ikl,isn)
+      dzsnSV(ikl,isn) =     Agrege(ikl) *dzsnSV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*dzsnSV(ikl,isn)
+      TsisSV(ikl,isn) =     Agrege(ikl) *TsisSV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*TsisSV(ikl,isn)
+      ro__SV(ikl,isn) =     Agrege(ikl) *ro__SV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*ro__SV(ikl,isn)
+      eta_SV(ikl,isn) =     Agrege(ikl) *eta_SV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*eta_SV(ikl,isn)
+      G1snSV(ikl,isn) =     Agrege(ikl) *G1snSV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*G1snSV(ikl,isn)
+      G2snSV(ikl,isn) =     Agrege(ikl) *G2snSV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*G2snSV(ikl,isn)
+      agsnSV(ikl,isn) =     Agrege(ikl) *agsnSV(ikl,isn-1) &
+            + (1.-Agrege(ikl))*agsnSV(ikl,isn)
+      isnoSV(ikl)     = min(Agrege(ikl) +isnoSV(ikl),real(nsno))
+      iiceSV(ikl)     =                  iiceSV(ikl) &
+            +     Agrege(ikl) *max(0,sign(1,iiceSV(ikl) &
+            -isn +icemix)) &
+            *max(0,sign(1,iiceSV(ikl) &
+            -1          ))
+  END DO
+
+
+  ! +--Constrains Agregation in case of too much  Layers
+  ! +  =================================================
+
+  ! +--Search the thinest   non-zero Layer
+  ! +  -----------------------------------
+
+
+
+    DO ikl=1,knonv
+      dzthin(ikl) =   0.                            ! Arbitrary unrealistic
+    END DO                                          !       Layer Thickness
+  DO ikl=1,knonv
+    DO isn=1,isnoSV(ikl)-3 ! no agregation of 3 first snowlayers
+                           ! ! XF 04/07/2019
+
+      isno_n    =             isnoSV(ikl)-isn+1     ! Snow Normal.Profile
+      iice_n    =             iiceSV(ikl)-isn       ! Ice  Normal.Profile
+      iiceOK    = min(1,max(0,iice_n         +1))   ! Ice         Switch
+  ! #vz     dz_ref(isn) =                                 !
+  ! #vz.          dz_min *((1-iiceOK)*isno_n*isno_n       ! Theoretical Profile
+  ! #vz.                 +    iiceOK *    2**iice_n)      !
+  ! #vz.               /max(1,isnoSV(ikl))                !
+      dz_dif      =     dz_min & ! Actual      Profile
+            - dzsnSV(ikl    ,isn) & !
+            /max(epsi,((1-iiceOK)*isno_n*isno_n & ! Theoretical Profile
+            +    iiceOK *2.   **iice_n))     !
+  ! #vz     dzwdif(isn) =     dz_dif                      !
+      OKthin      = max(zero, & !
+            sign(unun, & !
+            dz_dif  - dzthin(ikl))) & ! 1.=> New thinest Lay.
+            * max(0, & ! 1 => .le. isnoSV
+            min(1, & !
+            isnoSV(ikl)-isn +1 ))       !
+      i_thin(ikl) =    (1. - OKthin) * i_thin(ikl) & ! Update   thinest Lay.
+            + OKthin  * isn          !                Index
+      dzthin(ikl) =    (1. - OKthin) * dzthin(ikl) & !
+            + OKthin  * dz_dif       !
+
+
+    END DO
+  END DO
+
+
+
+
+
+  ! +--Index of the contiguous Layer to agregate
+  ! +  -----------------------------------------
+
+  ! +   ***************
+  CALL SISVAT_zCr
+  ! +   ***************
+
+
+  ! +--Assign the 2 Layers to agregate
+  ! +  -------------------------------
+
+    DO ikl=1,knonv
+      isn         =    i_thin(ikl)
+      if(LIndsv(ikl)>0) isn=min(isn, nsno-1) !cXF
+      isagr1(ikl) =    istoSV(ikl,isn)
+      isagr2(ikl) =    istoSV(ikl,isn+LIndsv(ikl))
+      dzagr1(ikl) =    dzsnSV(ikl,isn)
+      dzagr2(ikl) =    dzsnSV(ikl,isn+LIndsv(ikl))
+      T_agr1(ikl) =    TsisSV(ikl,isn)
+      T_agr2(ikl) =    TsisSV(ikl,isn+LIndsv(ikl))
+      roagr1(ikl) =    ro__SV(ikl,isn)
+      roagr2(ikl) =    ro__SV(ikl,isn+LIndsv(ikl))
+      etagr1(ikl) =    eta_SV(ikl,isn)
+      etagr2(ikl) =    eta_SV(ikl,isn+LIndsv(ikl))
+      G1agr1(ikl) =    G1snSV(ikl,isn)
+      G1agr2(ikl) =    G1snSV(ikl,isn+LIndsv(ikl))
+      G2agr1(ikl) =    G2snSV(ikl,isn)
+      G2agr2(ikl) =    G2snSV(ikl,isn+LIndsv(ikl))
+      agagr1(ikl) =    agsnSV(ikl,isn)
+      agagr2(ikl) =    agsnSV(ikl,isn+LIndsv(ikl))
+      LstLay      = min(1,max(  0,    isnoSV(ikl)-1   ))
+      Agrege(ikl) = min(1, &
+            max(0, &
+            NLaysv(ikl)   +isnoSV(ikl)-nsno &
+            +NLay_s(ikl)                    ) &
+            *LstLay           )
+
+  ! + minimum uppermost layer thickness to guarantee a correct reproduction of the snow
+  ! + atmosphere coupling
+    if(dzsnSV(ikl,max(1,isnoSV(ikl)-0))>0.02 .or. & ! surface layers> 2-5-10
+          dzsnSV(ikl,max(1,isnoSV(ikl)-1))>0.05 .or. & ! XF 04/07/2019
+          dzsnSV(ikl,max(1,isnoSV(ikl)-2))>0.10 .or. &
+          dzsnSV(ikl,max(1,isnoSV(ikl)-3))>0.30 )then
+      Agrege(ikl) = min(1, &
+            max(0, &
+            NLaysv(ikl)   +isnoSV(ikl)+1-nsno & ! nsno-1 layers ma
+            +NLay_s(ikl)                    ) &
+            *LstLay           )
+    endif
+
+      isnoSV(ikl) =                    isnoSV(ikl) &
+            -(1-LstLay)*max(zero, &
+            sign(unun,      eps_21 &
+            -dzsnSV(ikl,1)   ))
+      isnoSV(ikl) =max(   0,           isnoSV(ikl)      )
+
+      WEagre(ikl) = 0.
+    END DO
+
+    DO isn=1,nsno
+    DO ikl=1,knonv
+      WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn) &
+            *min(1,max(0,i_thin(ikl)+1-isn))
+    ENDDO
+    ENDDO
+
+  ! +--Agregates
+  ! +  ---------
+
+  ! +     ***************
+    CALL SISVAT_zAg &
+          (isagr1,isagr2,WEagre &
+          ,dzagr1,dzagr2,T_agr1,T_agr2 &
+          ,roagr1,roagr2,etagr1,etagr2 &
+          ,G1agr1,G1agr2,G2agr1,G2agr2 &
+          ,agagr1,agagr2,Agrege &
+          )
+  ! +     ***************
+
+
+  ! +--Rearranges the Layers
+  ! +  ---------------------
+
+  ! +--New (agregated) Snow layer
+  ! +  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+    DO ikl=1,knonv
+      isn     =             i_thin(ikl)
+      isn     = min(isn,isn+LIndsv(ikl))
+      isnoSV(ikl) =  max(0.,isnoSV(ikl) -Agrege(ikl))
+      iiceSV(ikl) =         iiceSV(ikl) &
+            -max(0,sign(1,iiceSV(ikl) -isn +icemix)) &
+            *Agrege(ikl) &
+            *max(0,sign(1,iiceSV(ikl) -1          ))
+      istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn) &
+            +   Agrege(ikl) *isagr1(ikl)
+      dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn) &
+            +   Agrege(ikl) *dzagr1(ikl)
+      TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn) &
+            +   Agrege(ikl) *T_agr1(ikl)
+      ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn) &
+            +   Agrege(ikl) *roagr1(ikl)
+      eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn) &
+            +   Agrege(ikl) *etagr1(ikl)
+      G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn) &
+            +   Agrege(ikl) *G1agr1(ikl)
+      G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn) &
+            +   Agrege(ikl) *G2agr1(ikl)
+      agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn) &
+            +   Agrege(ikl) *agagr1(ikl)
+    END DO
+
+  ! +--Above
+  ! +  ^^^^^
+    DO ikl=1,knonv
+      isn1(ikl)=max(i_thin(ikl),i_thin(ikl)+LIndsv(ikl))
+    END DO
+    DO i=  1,nsno-1
+    DO ikl=1,knonv
+        staggr        =  min(1,max(0,i +1 -isn1(ikl)   ))
+        istoSV(ikl,i) = (1.-staggr     )*istoSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*istoSV(ikl,i  ) &
+              +   Agrege(ikl) *istoSV(ikl,i+1))
+        dzsnSV(ikl,i) = (1.-staggr     )*dzsnSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i  ) &
+              +   Agrege(ikl) *dzsnSV(ikl,i+1))
+        TsisSV(ikl,i) = (1.-staggr     )*TsisSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i  ) &
+              +   Agrege(ikl) *TsisSV(ikl,i+1))
+        ro__SV(ikl,i) = (1.-staggr     )*ro__SV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i  ) &
+              +   Agrege(ikl) *ro__SV(ikl,i+1))
+        eta_SV(ikl,i) = (1.-staggr     )*eta_SV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i  ) &
+              +   Agrege(ikl) *eta_SV(ikl,i+1))
+        G1snSV(ikl,i) = (1.-staggr     )*G1snSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i  ) &
+              +   Agrege(ikl) *G1snSV(ikl,i+1))
+        G2snSV(ikl,i) = (1.-staggr     )*G2snSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i  ) &
+              +   Agrege(ikl) *G2snSV(ikl,i+1))
+        agsnSV(ikl,i) = (1.-staggr     )*agsnSV(ikl,i  ) &
+              + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i  ) &
+              +   Agrege(ikl) *agsnSV(ikl,i+1))
+    END DO
+    END DO
+
+    DO ikl=1,knonv
+      isn             = min(isnoSV(ikl) +1,nsno)
+      istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)
+      dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)
+      TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)
+      ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)
+      eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)
+      G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)
+      G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)
+      agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)
+    END DO
+
+
+  ! +--Search new Ice/Snow Interface (option II in MAR)
+  ! +  ===============================================
+
+    IF (ok_zsn_ii) THEN
+
+    DO ikl=1,knonv
+      iiceSV(ikl) =  0
+    END DO
+
+    DO ikl=1,knonv
+    DO   isn=1,isnoSV(ikl)
+      OK_ICE      = max(zero,sign(unun,ro__SV(ikl,isn)-ro_ice+20.)) &
+            * max(zero,sign(unun,dzsnSV(ikl,isn)-epsi))
+      iiceSV(ikl) = (1.-OK_ICE)       *iiceSV(ikl) &
+            +     OK_ICE        *isn
+    END DO
+    END DO
+
+    END IF
+
+
+end subroutine sisvat_zsn
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/surf_inlandsis_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/surf_inlandsis_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/surf_inlandsis_mod.F90	(revision 5105)
@@ -1022,5 +1022,5 @@
         END DO
 
-        return
+
 
     END SUBROUTINE SISVAT_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/isccp_cloud_types.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/isccp_cloud_types.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/isccp_cloud_types.F90	(revision 5105)
@@ -1606,4 +1606,4 @@
   ! end if
 
-  RETURN
+
 END SUBROUTINE isccp_cloud_types
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_atke_turbulence_ini.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_atke_turbulence_ini.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_atke_turbulence_ini.F90	(revision 5105)
@@ -174,5 +174,5 @@
       ri1 = -2./rpi * (pr_asym - pr_neut)
 
-RETURN
+
 
 END SUBROUTINE atke_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_blowing_snow_sublim_sedim.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_blowing_snow_sublim_sedim.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_blowing_snow_sublim_sedim.F90	(revision 5105)
@@ -290,5 +290,5 @@
 
 
-return
+
 
 END SUBROUTINE  blowing_snow_sublim_sedim
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_call_cloud_optics_prop.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_call_cloud_optics_prop.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_call_cloud_optics_prop.F90	(revision 5105)
@@ -126,5 +126,5 @@
                pcldtaupi, re, fl)
   ENDIF
-  RETURN
+
 
 END SUBROUTINE call_cloud_optics_prop
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cloud_optics_prop.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cloud_optics_prop.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cloud_optics_prop.F90	(revision 5105)
@@ -730,5 +730,5 @@
   first=.FALSE. !to be sure
 
-  RETURN
+
 
 END SUBROUTINE cloud_optics_prop
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cloudth.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cloudth.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cloudth.F90	(revision 5105)
@@ -1477,5 +1477,5 @@
 
       END DO  ! From the loop on ngrid
-      return
+
 
 END SUBROUTINE cloudth_v6
@@ -1823,5 +1823,5 @@
 
 
-RETURN
+
 
 
@@ -2239,5 +2239,5 @@
     qith(ind2)=MAX(0.,qi)
 
-    RETURN
+
 
 END SUBROUTINE ICE_MPC_BL_CLOUDS
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp.F90	(revision 5105)
@@ -1495,5 +1495,5 @@
 
 
-RETURN
+
 
 END SUBROUTINE lscp
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_ini.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_ini.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_ini.F90	(revision 5105)
@@ -435,5 +435,5 @@
     CALL cloudth_ini(iflag_cloudth_vert,iflag_ratqs)
 
-RETURN
+
 
 END SUBROUTINE lscp_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_old.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_old.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_old.F90	(revision 5105)
@@ -1671,5 +1671,5 @@
   endif
 
-RETURN
+
 END SUBROUTINE fisrtilp
 END MODULE lmdz_lscp_old
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_tools.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_tools.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_lscp_tools.F90	(revision 5105)
@@ -235,5 +235,5 @@
 
      ENDDO ! klon
-     RETURN
+
  
 END SUBROUTINE ICEFRAC_LSCP
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_ratqs_ini.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_ratqs_ini.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_ratqs_ini.F90	(revision 5105)
@@ -88,5 +88,5 @@
 !--------------------------------------------------------
 
- RETURN
+
 
 END SUBROUTINE ratqs_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_ratqs_main.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_ratqs_main.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_ratqs_main.F90	(revision 5105)
@@ -280,5 +280,5 @@
 
 
-return
+
 END SUBROUTINE ratqs_main
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_dry.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_dry.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_dry.F90	(revision 5105)
@@ -105,5 +105,5 @@
 
             if (zw2(ig,l+1)>0. .and. zw2(ig,l+1)<1.e-10) then
-!               stop'On tombe sur le cas particulier de thermcell_dry'
+!               stop 'On tombe sur le cas particulier de thermcell_dry'
 !               PRINT*,'On tombe sur le cas particulier de thermcell_dry'
                 zw2(ig,l+1)=0.
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_ini.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_ini.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_ini.F90	(revision 5105)
@@ -132,5 +132,5 @@
 write(lunout,*) 'thermcell_ini ,iflag_thermals_tenv      =',  iflag_thermals_tenv
 
- RETURN
+
 
 END SUBROUTINE thermcell_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_main.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_main.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_main.F90	(revision 5105)
@@ -819,5 +819,5 @@
 
 !PRINT*,'thermcell_main fin'
- RETURN
+
       END SUBROUTINE  thermcell_main
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_old.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_old.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_old.F90	(revision 5105)
@@ -710,5 +710,5 @@
 
   ! PRINT*,'19 OK convect8'
-  RETURN
+
 END SUBROUTINE thermcell_2002
 
@@ -2312,5 +2312,5 @@
 
   ! PRINT*,'19 OK convect8'
-  RETURN
+
 END SUBROUTINE thermcell_cld
 
@@ -3243,5 +3243,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE thermcell_eau
 
@@ -4122,5 +4122,5 @@
 
   ! PRINT*,'19 OK convect8'
-  RETURN
+
 END SUBROUTINE thermcell
 
@@ -4216,5 +4216,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE dqthermcell
 SUBROUTINE dvthermcell(ngrid, nlay, ptimestep, fm, entr, masse, fraca, larga, &
@@ -4319,5 +4319,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE dvthermcell
 SUBROUTINE dqthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, frac, q, dq, &
@@ -4394,5 +4394,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE dqthermcell2
 SUBROUTINE dvthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, fraca, &
@@ -4513,5 +4513,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE dvthermcell2
 SUBROUTINE thermcell_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, &
@@ -5342,5 +5342,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE thermcell_sec
 
@@ -6329,5 +6329,5 @@
 
   ! PRINT*,'19 OK convect8'
-  RETURN
+
 END SUBROUTINE calcul_sec
 
@@ -6508,5 +6508,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE fermeture_seche
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_plume.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_plume.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_plume.f90	(revision 5105)
@@ -379,5 +379,5 @@
       do ig = 1, ngrid
         if (zw2(ig, l + 1)>0. .and. zw2(ig, l + 1)<1.e-10) then
-          !               stop'On tombe sur le cas particulier de thermcell_dry'
+          !               stop 'On tombe sur le cas particulier de thermcell_dry'
           !               PRINT*,'On tombe sur le cas particulier de thermcell_plume'
           nbpb = nbpb + 1
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_plume_6A.f90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_plume_6A.f90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_thermcell_plume_6A.f90	(revision 5105)
@@ -621,5 +621,5 @@
       do ig = 1, ngrid
         if (zw2(ig, l + 1)>0. .and. zw2(ig, l + 1)<1.e-10) then
-          !               stop'On tombe sur le cas particulier de thermcell_dry'
+          !               stop 'On tombe sur le cas particulier de thermcell_dry'
           !               PRINT*,'On tombe sur le cas particulier de thermcell_plume'
           nbpb = nbpb + 1
@@ -1011,5 +1011,5 @@
       do ig = 1, ngrid
         if (zw2(ig, l + 1)>0. .and. zw2(ig, l + 1)<1.e-10) then
-          !               stop'On tombe sur le cas particulier de thermcell_dry'
+          !               stop 'On tombe sur le cas particulier de thermcell_dry'
           !               PRINT*,'On tombe sur le cas particulier de thermcell_plume'
           nbpb = nbpb + 1
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake.F90	(revision 5105)
@@ -2334,5 +2334,5 @@
 !>jyg
 
- RETURN
+
 END SUBROUTINE wake
 
@@ -2405,5 +2405,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE wake_vec_modulation
 
@@ -2802,5 +2802,5 @@
 zk_ptop_provis=k_ptop_provis
 
-    RETURN
+
 END SUBROUTINE pkupper
 
@@ -2966,5 +2966,5 @@
       ENDIF
     
-    RETURN 
+
     END SUBROUTINE wake_popdyn_1
     
@@ -3116,5 +3116,5 @@
 awdens=awdens+d_awdens
 
-    RETURN 
+
     END SUBROUTINE wake_popdyn_2  
   
@@ -3363,5 +3363,5 @@
 awdens=awdens+d_awdens
 
-    RETURN 
+
     END SUBROUTINE wake_popdyn_3  
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake_ini.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake_ini.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake_ini.F90	(revision 5105)
@@ -278,5 +278,5 @@
   WRITE(*,*) 'wk_nsub=', wk_nsub
 
- RETURN
+
 
 END SUBROUTINE wake_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/mo_simple_plumes.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/mo_simple_plumes.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/mo_simple_plumes.F90	(revision 5105)
@@ -269,5 +269,5 @@
     sp_initialized = .TRUE.
 
-    RETURN
+
 
   END SUBROUTINE sp_setup
@@ -307,5 +307,5 @@
     ENDDO
     
-    RETURN
+
   END SUBROUTINE set_time_weight
 
@@ -494,5 +494,5 @@
     ENDDO
 
-    RETURN
+
   END SUBROUTINE sp_aop_profile
   
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/moy_undefSTD.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/moy_undefSTD.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/moy_undefSTD.F90	(revision 5105)
@@ -140,4 +140,4 @@
   END DO !n
 
-  RETURN
+
 END SUBROUTINE moy_undefstd
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/moyglo_aire.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/moyglo_aire.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/moyglo_aire.F90	(revision 5105)
@@ -57,5 +57,5 @@
   moyglo = moyglo/airetot
 
-  RETURN
+
 END SUBROUTINE moyglo_pondaire
 
@@ -100,5 +100,5 @@
   moyglo = moyglo/airetot
 
-  RETURN
+
 END SUBROUTINE moyglo_pondaima
 
@@ -145,5 +145,5 @@
   moyglo = moyglo/massetot
 
-  RETURN
+
 END SUBROUTINE moyglo_pondmass
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/nonlocal.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/nonlocal.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/nonlocal.F90	(revision 5105)
@@ -404,4 +404,4 @@
   END DO ! end of level loop
 
-  RETURN
+
 END SUBROUTINE nonlocal
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/nuage.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/nuage.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/nuage.F90	(revision 5105)
@@ -256,5 +256,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE nuage
 SUBROUTINE diagcld1(paprs, pplay, rain, snow, kbot, ktop, diafra, dialiq)
@@ -338,5 +338,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE diagcld1
 SUBROUTINE diagcld2(paprs, pplay, t, q, diafra, dialiq)
@@ -428,4 +428,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE diagcld2
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/o3cm.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/o3cm.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/o3cm.F90	(revision 5105)
@@ -50,5 +50,5 @@
     sortie = sortie + (ya+yb)/2.0*abs(xb-xa)
   END DO
-  RETURN
+
 END SUBROUTINE o3cm
 SUBROUTINE mbtozm(rmb, zm)
@@ -65,4 +65,4 @@
 
   zm = tzero/gama*(1.-(rmb/pzero)**(r*gama/g))
-  RETURN
+
 END SUBROUTINE mbtozm
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/orbite.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/orbite.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/orbite.F90	(revision 5105)
@@ -43,5 +43,5 @@
 
   dist = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pir*(longi-(r_peri+180.0))))
-  RETURN
+
 END SUBROUTINE orbite
 ! ======================================================================
@@ -99,5 +99,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE angle
 ! ====================================================================
@@ -291,4 +291,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE zenith
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/orografi.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/orografi.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/orografi.F90	(revision 5105)
@@ -112,5 +112,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE drag_noro
 SUBROUTINE orodrag(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, papm1, &
@@ -351,5 +351,5 @@
 
 
-  RETURN
+
 END SUBROUTINE orodrag
 SUBROUTINE orosetup(nlon, ktest, kkcrit, kkcrith, kcrit, kkenvh, kknu, kknu2, &
@@ -798,5 +798,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE orosetup
 SUBROUTINE gwstress(nlon, nlev, ktest, kcrit, kkenvh, kknu, prho, pstab, &
@@ -915,5 +915,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE gwstress
 SUBROUTINE gwprofil(nlon, nlev, kgwd, kdx, ktest, kkcrith, kcrit, paphm1, &
@@ -1176,5 +1176,5 @@
 
 
-  RETURN
+
 END SUBROUTINE gwprofil
 SUBROUTINE lift_noro(nlon, nlev, dtime, paprs, pplay, plat, pmea, pstd, ppic, &
@@ -1287,5 +1287,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE lift_noro
 SUBROUTINE orolift(nlon, nlev, ktest, ptsphy, paphm1, pgeom1, ptm1, pum1, &
@@ -1551,5 +1551,5 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE orolift
 
@@ -1678,4 +1678,4 @@
   ! ----------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE sugwd
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/orografi_strato.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/orografi_strato.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/orografi_strato.F90	(revision 5105)
@@ -151,5 +151,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE drag_noro_strato
 
@@ -450,5 +450,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE orodrag_strato
 SUBROUTINE orosetup_strato(nlon, nlev, ktest, kkcrit, kkcrith, kcrit, ksect, &
@@ -945,5 +945,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE orosetup_strato
 SUBROUTINE gwstress_strato(nlon, nlev, kkcrit, ksect, kkhlim, ktest, kkcrith, &
@@ -1076,5 +1076,5 @@
   ! write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
 
-  RETURN
+
 END SUBROUTINE gwstress_strato
 
@@ -1284,5 +1284,5 @@
 
 
-  RETURN
+
 END SUBROUTINE gwprofil_strato
 SUBROUTINE lift_noro_strato(nlon, nlev, dtime, paprs, pplay, plat, pmea, &
@@ -1441,5 +1441,5 @@
   ! print *,' out lift_noro'
 
-  RETURN
+
 END SUBROUTINE lift_noro_strato
 SUBROUTINE orolift_strato(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, &
@@ -1740,5 +1740,5 @@
   ! print *,' out orolift'
 
-  RETURN
+
 END SUBROUTINE orolift_strato
 SUBROUTINE sugwd_strato(nlon, nlev, paprs, pplay)
@@ -1935,4 +1935,4 @@
   gtsec = 0.00001
 
-  RETURN
+
 END SUBROUTINE sugwd_strato
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/phyaqua_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/phyaqua_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/phyaqua_mod.F90	(revision 5105)
@@ -388,5 +388,5 @@
     CALL phys_state_var_end
 
-    RETURN
+
   END SUBROUTINE iniaqua
 
@@ -504,5 +504,5 @@
     END IF
 
-    RETURN
+
   END SUBROUTINE zenang_an
 
@@ -987,5 +987,5 @@
     ! IM end : verif profil SST: phy_sst
 
-    RETURN
+
   END SUBROUTINE profil_sst
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/plevel.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/plevel.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/plevel.F90	(revision 5105)
@@ -131,4 +131,4 @@
 
 
-  RETURN
+
 END SUBROUTINE plevel
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/plevel_new.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/plevel_new.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/plevel_new.F90	(revision 5105)
@@ -137,4 +137,4 @@
 
 
-  RETURN
+
 END SUBROUTINE plevel_new
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/printflag.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/printflag.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/printflag.F90	(revision 5105)
@@ -187,4 +187,4 @@
 100 FORMAT (/)
 
-  RETURN
+
 END SUBROUTINE printflag
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/radiation_AR4.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/radiation_AR4.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/radiation_AR4.F90	(revision 5105)
@@ -303,5 +303,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE sw_lmdar4
 
@@ -472,5 +472,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE swu_lmdar4
 SUBROUTINE sw1s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
@@ -694,5 +694,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE sw1s_lmdar4
 SUBROUTINE sw2s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, &
@@ -1191,5 +1191,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE sw2s_lmdar4
 SUBROUTINE swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, &
@@ -1520,5 +1520,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE swclr_lmdar4
 SUBROUTINE swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, &
@@ -1849,5 +1849,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE swr_lmdar4
 SUBROUTINE swde_lmdar4(pgg, pref, prmuz, pto1, pw, pre1, pre2, ptr1, ptr2)
@@ -1972,5 +1972,5 @@
 
   END DO
-  RETURN
+
 END SUBROUTINE swde_lmdar4
 SUBROUTINE swtt_lmdar4(knu, ka, pu, ptr)
@@ -2041,5 +2041,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE swtt_lmdar4
 SUBROUTINE swtt1_lmdar4(knu, kabs, kind, pu, ptr)
@@ -2115,5 +2115,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE swtt1_lmdar4
 ! IM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
@@ -2307,5 +2307,5 @@
   END DO
   ! ------------------------------------------------------------------
-  RETURN
+
 END SUBROUTINE lw_lmdar4
 ! IM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
@@ -2676,5 +2676,5 @@
 
 
-  RETURN
+
 END SUBROUTINE lwu_lmdar4
 SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, &
@@ -2762,5 +2762,5 @@
     pcntrb, pcts, pfluc)
   ! ------------------------------------------------------------------
-  RETURN
+
 END SUBROUTINE lwbv_lmdar4
 SUBROUTINE lwc_lmdar4(klim, pcldld, pcldlu, pemis, pfluc, pbint, pbsuin, &
@@ -3138,5 +3138,5 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE lwc_lmdar4
 SUBROUTINE lwb_lmdar4(pdt0, ptave, ptl, pb, pbint, pbsuin, pbsur, pbtop, &
@@ -4537,5 +4537,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE lwb_lmdar4
 SUBROUTINE lwv_lmdar4(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, &
@@ -4642,5 +4642,5 @@
 
 
-  RETURN
+
 END SUBROUTINE lwv_lmdar4
 SUBROUTINE lwvb_lmdar4(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, &
@@ -4942,5 +4942,5 @@
   ! ------------------------------------------------------------------
 
-  RETURN
+
 END SUBROUTINE lwvb_lmdar4
 SUBROUTINE lwvd_lmdar4(kuaer, ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, &
@@ -5174,5 +5174,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE lwvd_lmdar4
 SUBROUTINE lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, padjd, padju, &
@@ -5367,5 +5367,5 @@
   END DO
 
-  RETURN
+
 
 END SUBROUTINE lwvn_lmdar4
@@ -5541,5 +5541,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE lwtt_lmdar4
 SUBROUTINE lwttm_lmdar4(pga, pgb, puu1, puu2, ptt)
@@ -5713,4 +5713,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE lwttm_lmdar4
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/read_pstoke.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/read_pstoke.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/read_pstoke.F90	(revision 5105)
@@ -412,5 +412,5 @@
   END IF
 
-  RETURN
+
 
 END SUBROUTINE read_pstoke
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/read_pstoke0.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/read_pstoke0.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/read_pstoke0.F90	(revision 5105)
@@ -434,5 +434,5 @@
   END IF
 
-  RETURN
+
 
 END SUBROUTINE read_pstoke0
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/reevap.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/reevap.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/reevap.F90	(revision 5105)
@@ -75,5 +75,5 @@
     ENDDO
 
-RETURN
+
 
 END SUBROUTINE reevap
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/screenc_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/screenc_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/screenc_mod.F90	(revision 5105)
@@ -113,5 +113,5 @@
       ENDDO 
 
-      RETURN 
+
       END SUBROUTINE screenc
 
@@ -202,5 +202,5 @@
       ENDDO 
 
-      RETURN 
+
       END SUBROUTINE screencn
 END MODULE screenc_mod
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/screenp_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/screenp_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/screenp_mod.F90	(revision 5105)
@@ -118,5 +118,5 @@
 
       ENDDO
-      RETURN
+
       END SUBROUTINE screenp
 
@@ -181,5 +181,5 @@
 
       ENDDO
-      RETURN
+
       END SUBROUTINE screenpn
 END MODULE screenp_mod 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/simu_airs.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/simu_airs.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/simu_airs.F90	(revision 5105)
@@ -76,5 +76,5 @@
         endif
 
-        return
+
         end function search_tropopause
 
@@ -596,5 +596,5 @@
           som_rad = som_rad/som_dz
         else
-          write(*,*) 'som_dez = 0 STOP'
+          write(*,*) 'som_dez = 0 stop '
           write(*,*) 'ibeg, iend =', ibeg, iend
           do i = ibeg, iend
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/slab_heat_transp_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/slab_heat_transp_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/slab_heat_transp_mod.F90	(revision 5105)
@@ -303,5 +303,5 @@
     CALL gr_dyn_fi(nlevs,iip1,jjp1,delta_2d,delta)
  
-    RETURN
+
   END SUBROUTINE divgrad_phy
 
@@ -464,5 +464,5 @@
       CALL gr_dyn_fi(1,iip1,jjp1,dt,dt_phy)
 
-      RETURN
+
   END SUBROUTINE slab_ekman1
 
@@ -755,5 +755,5 @@
       CALL gr_dyn_fi(2,iip1,jjp1,dt_gm,dt_phy_gm)
 
-      RETURN
+
   END SUBROUTINE slab_ekman2
 
@@ -887,5 +887,5 @@
       CALL gr_dyn_fi(2,iip1,jjp1,dt,dt_phy)
 
-      RETURN
+
   END SUBROUTINE slab_gmdiff
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/solarlong.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/solarlong.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/solarlong.F90	(revision 5105)
@@ -131,4 +131,4 @@
   ! ENDIF
 
-  RETURN
+
 END SUBROUTINE solarlong
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/stdlevvar_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/stdlevvar_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/stdlevvar_mod.F90	(revision 5105)
@@ -310,5 +310,5 @@
       ENDDO
 
-      RETURN
+
       END SUBROUTINE stdlevvar
 
@@ -751,5 +751,5 @@
       ENDDO
 
-      RETURN
+
       END SUBROUTINE stdlevvarn
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/stratosphere_mask.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/stratosphere_mask.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/stratosphere_mask.F90	(revision 5105)
@@ -100,5 +100,5 @@
 ENDIF
 
-RETURN
+
 END SUBROUTINE stratosphere_mask
 
@@ -249,4 +249,4 @@
 
 ! no tropopouse found
-return
+
 END SUBROUTINE  twmo
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/suphel.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/suphel.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/suphel.F90	(revision 5105)
@@ -228,4 +228,4 @@
   CALL SUMETHOX()
 
-  RETURN
+
 END SUBROUTINE suphel
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/tilft43.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/tilft43.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/tilft43.F90	(revision 5105)
@@ -95,5 +95,5 @@
   ! sb --
 
-  RETURN
+
 END SUBROUTINE tlift43
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/tlift.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/tlift.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/tlift.F90	(revision 5105)
@@ -233,5 +233,5 @@
 
 
-  RETURN
+
 END SUBROUTINE tlift
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/transp.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/transp.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/transp.F90	(revision 5105)
@@ -55,4 +55,4 @@
   ENDDO
 
-  RETURN
+
 END SUBROUTINE transp
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/transp_lay.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/transp_lay.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/transp_lay.F90	(revision 5105)
@@ -47,4 +47,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE transp_lay
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/undefSTD.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/undefSTD.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/undefSTD.F90	(revision 5105)
@@ -102,4 +102,4 @@
   END DO !n
 
-  RETURN
+
 END SUBROUTINE undefstd
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/ustarhb.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/ustarhb.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/ustarhb.F90	(revision 5105)
@@ -40,4 +40,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE ustarhb
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/vdif_kcay.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/vdif_kcay.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/vdif_kcay.F90	(revision 5105)
@@ -671,4 +671,4 @@
   END IF
 
-  RETURN
+
 END SUBROUTINE vdif_kcay
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/wx_pbl_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/wx_pbl_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/wx_pbl_mod.F90	(revision 5105)
@@ -149,5 +149,5 @@
         ENDDO
 
-        RETURN
+
 
 END SUBROUTINE wx_pbl0_merge
@@ -543,5 +543,5 @@
    ENDIF
 
-     RETURN
+
 
 END SUBROUTINE wx_pbl_dts_merge
@@ -700,5 +700,5 @@
 !!    ENDIF  ! (knon .NE. 0)
 
-        RETURN
+
 
 END SUBROUTINE wx_pbl_split
@@ -938,5 +938,5 @@
 !--------------------------------------------------------------------------------------------------
 
-        RETURN
+
 
 END SUBROUTINE wx_pbl_check
@@ -1194,5 +1194,5 @@
         ENDIF   ! (prt_level >=10 )
 !--------------------------------------------------------------------------------------------------
-        RETURN
+
 
 END SUBROUTINE wx_pbl_dts_check
@@ -1218,5 +1218,5 @@
  ENDDO
 
- RETURN
+
 END SUBROUTINE wx_evappot
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/wx_pbl_var_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/wx_pbl_var_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/wx_pbl_var_mod.F90	(revision 5105)
@@ -528,5 +528,5 @@
      ENDDO  ! j = 1, knon
 
-     RETURN
+
 
 END SUBROUTINE wx_pbl_prelim_0
@@ -568,5 +568,5 @@
   ENDDO ! j = 1, knon
 
-  RETURN
+
 
 END SUBROUTINE wx_pbl_prelim_beta
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada.F90	(revision 5105)
@@ -167,4 +167,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE yamada
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada4.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada4.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada4.F90	(revision 5105)
@@ -702,5 +702,5 @@
 !=============================================================================
 
-  RETURN
+
 
 
@@ -792,5 +792,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE vdif_q2
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
@@ -860,5 +860,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE vdif_q2e
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada_c.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada_c.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada_c.F90	(revision 5105)
@@ -369,10 +369,10 @@
 !##################################################################
 !#  IF (iflag_pbl==29) THEN
-!#     STOP'Ne pas utiliser iflag_pbl=29'
+!#     stop 'Ne pas utiliser iflag_pbl=29'
 !#     km2(:,:)=km(:,:)*m2(:,:)
 !#     kn2(:,:)=kn2(:,:)*rif(:,:)
 !#  ELSEIF (iflag_pbl==25) THEN
 ! VERSION AVEC LA TKE EN MILIEU DE COUCHE
-!#     STOP'Ne pas utiliser iflag_pbl=25'
+!#     stop 'Ne pas utiliser iflag_pbl=25'
 !#     DO k=1,klev
 !#        km2(:,k)=-0.5*(dddu(:,k)+dddv(:,k)+dddu(:,k+1)+dddv(:,k+1)) &
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada_ini_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada_ini_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/yamada_ini_mod.F90	(revision 5105)
@@ -88,5 +88,5 @@
 
    
- RETURN
+
 
 END SUBROUTINE yamada_ini
Index: /LMDZ6/branches/Amaury_dev/libf/phylmd/zilch.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmd/zilch.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmd/zilch.F90	(revision 5105)
@@ -14,4 +14,4 @@
     x(i) = 0.0
   END DO
-  RETURN
+
 END SUBROUTINE zilch
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/add_phys_tend_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/add_phys_tend_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/add_phys_tend_mod.F90	(revision 5105)
@@ -118,5 +118,5 @@
 
 
-  RETURN
+
 END SUBROUTINE add_pbl_tend
 
@@ -663,5 +663,5 @@
   ENDIF ! (mode == 1)
 
-  RETURN
+
 END SUBROUTINE add_phys_tend
 
@@ -828,5 +828,5 @@
   end if ! end if (fl_ebil .GT. 0)
 
-  RETURN
+
 END SUBROUTINE diag_phys_tend
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/ajsec.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/ajsec.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/ajsec.F90	(revision 5105)
@@ -293,5 +293,5 @@
 
 
-  RETURN
+
 END SUBROUTINE ajsec
 
@@ -575,5 +575,5 @@
 #endif
 
-  RETURN
+
 END SUBROUTINE ajsec_convv2
 SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
@@ -668,4 +668,4 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE ajsec_old
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/calwake.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/calwake.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/calwake.F90	(revision 5105)
@@ -433,5 +433,5 @@
 !>jyg
 
-  RETURN
+
 END SUBROUTINE calwake
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/clift.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/clift.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/clift.F90	(revision 5105)
@@ -71,4 +71,4 @@
 
 
-  RETURN
+
 END SUBROUTINE clift
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/concvl.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/concvl.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/concvl.F90	(revision 5105)
@@ -811,5 +811,5 @@
   END IF !(prt_level.EQ.20) THEN
 
-  RETURN
+
 END SUBROUTINE concvl
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv30_routines.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv30_routines.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv30_routines.F90	(revision 5105)
@@ -80,5 +80,5 @@
   betad = 10.0 ! original value (from convect 4.3)
 
-  RETURN
+
 END SUBROUTINE cv30_param
 
@@ -155,5 +155,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_prelim
 
@@ -359,5 +359,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_feed
 
@@ -828,5 +828,5 @@
 #endif
 
-  RETURN
+
 END SUBROUTINE cv30_undilute1
 
@@ -932,5 +932,5 @@
   ! fin oct3 --
 
-  RETURN
+
 END SUBROUTINE cv30_trigger
 
@@ -1121,5 +1121,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv30_compress
 
@@ -1610,5 +1610,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_undilute2
 
@@ -1815,5 +1815,5 @@
   ! !      sig(icb-1)=sig(icb)
 
-  RETURN
+
 END SUBROUTINE cv30_closure
 
@@ -2633,5 +2633,5 @@
 #endif
 
-  RETURN
+
 END SUBROUTINE cv30_mixing
 
@@ -3361,5 +3361,5 @@
 #endif
 #endif
-  RETURN
+
 END SUBROUTINE cv30_unsat
 
@@ -5981,5 +5981,5 @@
   END DO ! cld
 
-  RETURN
+
 END SUBROUTINE cv30_yield
 
@@ -6093,5 +6093,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_tracer
 ! RomP <<<
@@ -6347,5 +6347,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv30_uncompress
 
@@ -6434,5 +6434,5 @@
       endif !if (coef_epmax_cape.gt.1e-12) then
 
-      return
+
       END SUBROUTINE  cv30_epmax_fn_cape
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_enthalpmix.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_enthalpmix.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_enthalpmix.F90	(revision 5105)
@@ -235,5 +235,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_enthalpmix
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_estatmix.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_estatmix.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_estatmix.F90	(revision 5105)
@@ -218,5 +218,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3_estatmix
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_routines.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_routines.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3_routines.F90	(revision 5105)
@@ -106,7 +106,7 @@
      CALL getin_p('wbmax',wbmax)
      ok_convstop=.False.
-     CALL getin_p('ok_convstop',ok_convstop)
+     CALL getin_p('ok_convstop ',ok_convstop)
      tau_stop=15000.
-     CALL getin_p('tau_stop',tau_stop)
+     CALL getin_p('tau_stop ',tau_stop)
      ok_intermittent=.False.
      CALL getin_p('ok_intermittent',ok_intermittent)
@@ -179,5 +179,5 @@
   noconv_stop = max(2.,tau_stop/delt)
 
-  RETURN
+
 END SUBROUTINE cv3_param
 
@@ -219,5 +219,5 @@
 !    print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd)
 
-  RETURN
+
 END SUBROUTINE cv3_incrcount
 
@@ -301,5 +301,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_prelim
 
@@ -672,5 +672,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_feed
 
@@ -1141,5 +1141,5 @@
 #endif  
 #endif
-  RETURN
+
 END SUBROUTINE cv3_undilute1
 
@@ -1244,5 +1244,5 @@
 ! fin oct3 --
 
-  RETURN
+
 END SUBROUTINE cv3_trigger
 
@@ -1418,5 +1418,5 @@
 #endif
 #endif
-  RETURN
+
 END SUBROUTINE cv3_compress
 
@@ -1450,5 +1450,5 @@
   END DO
 
-  RETURN
+
 
 END SUBROUTINE icefrac
@@ -2503,5 +2503,5 @@
   END IF  ! (cvflag_ice)
 
-  RETURN
+
 END SUBROUTINE cv3_undilute2
 
@@ -2744,5 +2744,5 @@
 !!      sig(icb-1)=sig(icb)
 
-  RETURN
+
 END SUBROUTINE cv3_closure
 
@@ -3569,5 +3569,5 @@
 #endif
 #endif
-  RETURN
+
 END SUBROUTINE cv3_mixing
 
@@ -4662,5 +4662,5 @@
 
 
-  RETURN
+
 
 END SUBROUTINE cv3_unsat
@@ -7272,5 +7272,5 @@
 ! PRINT*,'cv3_yield fin'
 
-  RETURN
+
 END SUBROUTINE cv3_yield
 
@@ -7372,5 +7372,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv3_tracer
 !AC! et !RomP <<<
@@ -7592,5 +7592,5 @@
 !AC! 2100   continue
 
-  RETURN
+
 END SUBROUTINE cv3_uncompress
 
@@ -7735,5 +7735,5 @@
       !write(*,*) 'cv3_routines check 4367'
 
-      return
+
       END SUBROUTINE  cv3_epmax_fn_cape
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_compress.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_compress.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_compress.F90	(revision 5105)
@@ -297,4 +297,4 @@
 !>jyg
 
-  RETURN
+
 END SUBROUTINE cv3a_compress
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_uncompress.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_uncompress.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_uncompress.F90	(revision 5105)
@@ -504,5 +504,5 @@
 !>jyg
 
-  RETURN
+
 END SUBROUTINE cv3a_uncompress
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3p_mixing.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3p_mixing.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3p_mixing.F90	(revision 5105)
@@ -1371,5 +1371,5 @@
 
 
-  RETURN
+
 END SUBROUTINE cv3p_mixing
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_driver.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_driver.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_driver.F90	(revision 5105)
@@ -1223,5 +1223,5 @@
 
   ! print *, 'fin cv_driver ->'      !jyg
-  RETURN
+
 END SUBROUTINE cv_driver
 
@@ -1257,5 +1257,5 @@
   CALL getin_p('icvflag_Tpa', icvflag_Tpa)
 
-  RETURN
+
 END SUBROUTINE cv_flag
 
@@ -1318,4 +1318,4 @@
   hrd = 0.5*rrd
 
-  RETURN
+
 END SUBROUTINE cv_thermo
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_routines.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_routines.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_routines.F90	(revision 5105)
@@ -71,5 +71,5 @@
   delta = 0.01 ! cld
 
-  RETURN
+
 END SUBROUTINE cv_param
 
@@ -128,5 +128,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_prelim
 
@@ -249,5 +249,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_feed
 
@@ -359,5 +359,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_undilute1
 
@@ -389,5 +389,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_trigger
 
@@ -476,5 +476,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_compress
 
@@ -759,5 +759,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_undilute2
 
@@ -841,5 +841,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_closure
 
@@ -1093,5 +1093,5 @@
 789 END DO
 
-  RETURN
+
 END SUBROUTINE cv_mixing
 
@@ -1294,5 +1294,5 @@
 899 END DO
 
-  RETURN
+
 END SUBROUTINE cv_unsat
 
@@ -1663,5 +1663,5 @@
   END DO ! cld
 
-  RETURN
+
 END SUBROUTINE cv_yield
 
@@ -1709,5 +1709,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE cv_uncompress
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cva_driver.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cva_driver.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/cva_driver.F90	(revision 5105)
@@ -1791,4 +1791,4 @@
 
 
-  RETURN
+
 END SUBROUTINE cva_driver
Index: DZ6/branches/Amaury_dev/libf/phylmdiso/fcg_racmo.h
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/fcg_racmo.h	(revision 5104)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/fcg_racmo.h
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_routines_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_routines_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_routines_mod.F90	(revision 5105)
@@ -2229,5 +2229,5 @@
           ! end verif
 
- return
+
  END SUBROUTINE  calcul_Rsol
 
@@ -9548,5 +9548,5 @@
 
 #ifdef ISOVERIF 
-!      write(*,*) 'appel_stewart_np 335 nostop' 
+!      write(*,*) 'appel_stewart_np 335 nostop '
 !      il=1
 !      write(*,*) 'Pqisup=',Pqisup(il)
@@ -9748,5 +9748,5 @@
 !             if (iso_verif_positif_nostop((
 !     :            Pqisup(il)-Eqi_prime(il)),
-!     :            'appel_stewart_np 388 nostop').eq.1) then
+!     :            'appel_stewart_np 388 nostop ').eq.1) then
 !               write(*,*) 'il,Pqisup=',il,Pqisup(il)
 !               write(*,*) 'Eqi_prime=',Eqi_prime(il)
@@ -13837,5 +13837,5 @@
 
 
-        return
+
         END SUBROUTINE  calcul_iso_surf_oce_vectall
 
@@ -14089,5 +14089,5 @@
 
 
-      return
+
       END SUBROUTINE  calcul_iso_surf_sic_vectall
 
@@ -14419,5 +14419,5 @@
 
 
-        return
+
         END SUBROUTINE  calcul_iso_surf_lic_vectall
 
@@ -15842,5 +15842,5 @@
         enddo !do i=1,knon
 
-        return
+
         END SUBROUTINE  calcul_iso_surf_ter_vectall
 
@@ -16017,5 +16017,5 @@
         endif
 
-      RETURN
+
       END SUBROUTINE phyisoetat0
       
@@ -17925,5 +17925,5 @@
 
 
-      return
+
       END SUBROUTINE  iso_tritium
 
@@ -18040,5 +18040,5 @@
       endif ! if (ok_prod_nucl_tritium)
 
-      return
+
       END SUBROUTINE  table_tritium_nucl
 
@@ -18123,5 +18123,5 @@
              
 
-      return
+
       END SUBROUTINE  date_prod_nucl_HTO
 
@@ -18214,5 +18214,5 @@
       enddo
 
-      return
+
       END SUBROUTINE  lancer_bombes
 ! --------------------------------------------------------------------------------
@@ -18352,5 +18352,5 @@
 !#endif
       
-      return
+
       END SUBROUTINE  coord_prod_nucl_HTO
 
@@ -18492,5 +18492,5 @@
 !#endif
 
-      return
+
       END SUBROUTINE  calcul_prod_nucl_HTO
 
@@ -18631,5 +18631,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  condiso_liq_ice_vectiso_trac
 
@@ -18770,5 +18770,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  condiso_liq_ice_vectall_trac
 #endif
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_verif_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_verif_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_verif_mod.F90	(revision 5105)
@@ -160,5 +160,5 @@
 #endif           
 
-        return
+
         END SUBROUTINE  iso_verif_egalite
 
@@ -188,5 +188,5 @@
 #endif                  
 
-        return
+
         end function iso_verif_egalite_nostop
 
@@ -322,5 +322,5 @@
 #endif           
         
-        return
+
         end function iso_verif_aberrant_nostop
 
@@ -353,5 +353,5 @@
         stop
 #endif                   
-        return
+
         end function iso_verif_aberrant_enc_nostop
 
@@ -417,5 +417,5 @@
 #endif                   
         
-        return
+
         end function iso_verif_aberrant_choix_nostop
 
@@ -461,5 +461,5 @@
 #endif                   
         
-        return
+
         end function iso_verif_aberrant_enc_choix_nostop
 
@@ -493,5 +493,5 @@
 #endif                   
         
-        return
+
         END SUBROUTINE  iso_verif_aberrant_o17
 
@@ -534,5 +534,5 @@
 #endif                   
         
-        return
+
         end function iso_verif_aberrant_o17_nostop
 
@@ -592,5 +592,5 @@
 #endif           
 
-        return
+
         end function iso_verif_noNaN_nostop
 
@@ -750,5 +750,5 @@
 #endif           
         
-        return
+
         end function iso_verif_egalite_choix_nostop       
 
@@ -890,5 +890,5 @@
         endif    
         
-        return
+
         end function iso_verif_positif_strict_nostop
 
@@ -950,5 +950,5 @@
 #endif         
         
-        return
+
         end function iso_verif_positif_nostop
 
@@ -984,5 +984,5 @@
 #endif
         
-        return
+
         end function iso_verif_positif_choix_nostop
 
@@ -1053,5 +1053,5 @@
 #endif                   
 
-        return
+
         end function iso_verif_O18_aberrant_nostop
 
@@ -1070,5 +1070,5 @@
                  iso_HDO.gt.0
         endif
-        return
+
         end function deltaD
 
@@ -1085,5 +1085,5 @@
                  iso_O18.gt.0
         endif
-        return
+
         end function deltaO
 
@@ -1101,5 +1101,5 @@
             write(*,*) 'iso_verif_egalite 1109: iso_O18,iso_HDO=',iso_O18,iso_HDO
         endif
-        return
+
         end function dexcess
 
@@ -1113,5 +1113,5 @@
         
         delta_all=(R/tnat(ixt)-1)*1000.0
-        return
+
         end function delta_all
 
@@ -1124,5 +1124,5 @@
         
         delta_to_R=(delta/1000.0+1.0)*tnat(ixt)
-        return
+
         end function delta_to_R
 
@@ -1142,5 +1142,5 @@
                  iso_O17.gt.0,iso_O18.gt.0
         endif
-        return
+
         end function o17excess
 
@@ -1195,5 +1195,5 @@
 #endif         
 
-        return
+
         END SUBROUTINE  iso_verif_egalite_vect2D
 
@@ -1279,5 +1279,5 @@
         endif 
 
-        return
+
         END SUBROUTINE  iso_verif_egalite_std_vect
 
@@ -1555,5 +1555,5 @@
         enddo
 
-        return
+
         END SUBROUTINE  select_dim23_from4D
 
@@ -1576,5 +1576,5 @@
         enddo
 
-        return
+
         END SUBROUTINE  select_dim4_from4D
 
@@ -1742,5 +1742,5 @@
 #endif           
 
-        return
+
         END SUBROUTINE  iso_verif_noNaN_par2D
 
@@ -1936,5 +1936,5 @@
         endif ! if (iso_HDO.gt.0) then  
 
-        return
+
         end function iso_verif_tracnps_choix_nostop
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotrac_routines_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotrac_routines_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotrac_routines_mod.F90	(revision 5105)
@@ -1101,5 +1101,5 @@
 #endif      
 
-      return
+
       END SUBROUTINE  ajoute_revap
 
@@ -1311,5 +1311,5 @@
       endif
       
-      return
+
       end function is_in_bassin
 
@@ -1368,5 +1368,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  find_bassin
 
@@ -1394,5 +1394,5 @@
        endif
 
-        return
+
         END SUBROUTINE  initialise_bassins_boites
 
@@ -1420,5 +1420,5 @@
         enddo
 
-        return
+
         END SUBROUTINE  bassin_map_init
 
@@ -1447,5 +1447,5 @@
 !        write(*,*) 'is_in_rectangle=',is_in_rectangle
 !#endif        
-        return
+
         end function is_in_rectangle
 
@@ -1484,5 +1484,5 @@
 !     :         det1,det2,det3,is_in_triangle
 !#endif
-        return
+
         end function is_in_triangle
 
@@ -1569,5 +1569,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_tmin
 
@@ -1624,5 +1624,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_tmin_sfrev
 
@@ -1689,5 +1689,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_saturation
 
@@ -1741,5 +1741,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_boite
 
@@ -1788,5 +1788,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_extra
 
@@ -1857,5 +1857,5 @@
 #endif
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_conv
 
@@ -1910,5 +1910,5 @@
         enddo
 
-        return
+
         END SUBROUTINE  boite_AMMA_init
 
@@ -1948,5 +1948,5 @@
         enddo
 
-        return
+
         END SUBROUTINE  boite_UT_extra_init
 
@@ -1968,5 +1968,5 @@
         endif
 
-        return
+
         end function index_zone_lat
 
@@ -1988,5 +1988,5 @@
         write(*,*) 'zone_pres=',zone_pres(1:nzone_pres-1)
 
-        return
+
         end function index_zone_pres
 
@@ -2024,5 +2024,5 @@
         endif !if (nzone_pres.gt.1) then
 
-        return
+
         end function find_index
 
@@ -2045,5 +2045,5 @@
         index_zone_latpres=index_lat+(index_pres-1)*nzone_lat
 
-        return
+
         end function index_zone_latpres
 
@@ -2254,5 +2254,5 @@
 #endif
 
-            return
+
             END SUBROUTINE  iso_recolorise_condensation
 
@@ -2281,5 +2281,5 @@
         enddo !do i=1,klon
         
-        return
+
         END SUBROUTINE  bassin_map_init_opt20
 
@@ -2309,5 +2309,5 @@
       endif !if (option_traceurs.eq.4) then
 
-        return
+
         END SUBROUTINE  isotrac_recolorise_general
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_lscp_old.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_lscp_old.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_lscp_old.F90	(revision 5105)
@@ -549,5 +549,5 @@
                write(*,*) 'ilp 400: avant clmain 31janv: i,k,q=', &
                  i,k,q(i,k)
-               CALL abort_physic('ilp 484', 'on stop', 1)
+               CALL abort_physic('ilp 484', 'on stop ', 1)
         endif 
 #endif
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_wake.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_wake.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_wake.F90	(revision 5105)
@@ -2548,5 +2548,5 @@
 
 
-  RETURN
+
 END SUBROUTINE wake
 
@@ -2620,5 +2620,5 @@
   END DO
 
-  RETURN
+
 END SUBROUTINE wake_vec_modulation
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/phyaqua_mod.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/phyaqua_mod.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/phyaqua_mod.F90	(revision 5105)
@@ -410,5 +410,5 @@
     CALL phys_state_var_end
 
-    RETURN
+
   END SUBROUTINE iniaqua
 
@@ -526,5 +526,5 @@
     END IF
 
-    RETURN
+
   END SUBROUTINE zenang_an
 
@@ -1008,5 +1008,5 @@
     ! IM end : verif profil SST: phy_sst
 
-    RETURN
+
   END SUBROUTINE profil_sst
 
Index: /LMDZ6/branches/Amaury_dev/libf/phylmdiso/reevap.F90
===================================================================
--- /LMDZ6/branches/Amaury_dev/libf/phylmdiso/reevap.F90	(revision 5104)
+++ /LMDZ6/branches/Amaury_dev/libf/phylmdiso/reevap.F90	(revision 5105)
@@ -91,5 +91,5 @@
 
 
-RETURN
+
 
 END SUBROUTINE reevap
