Index: LMDZ5/trunk/libf/PVtheta.F
===================================================================
--- LMDZ5/trunk/libf/PVtheta.F	(revision 1630)
+++ LMDZ5/trunk/libf/PVtheta.F	(revision 1630)
@@ -0,0 +1,196 @@
+      SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta,
+     $           ztfi,zplay,zplev,
+     $           nbteta,theta,PVteta)
+      IMPLICIT none
+
+c=======================================================================
+c
+c   Auteur:  I. Musat
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    Calcul de la vorticite potentielle PVteta sur des iso-theta selon
+c    la methodologie du NCEP/NCAR :
+c    1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les
+c       niveaux du modele => N2
+c    2) on interpole les vents, la temperature et le N**2 sur des isentropes
+c       (en fait sur des iso-theta) lineairement en log(theta) =>
+c       ucovteta, vcovteta, N2teta
+c    3) on calcule la vorticite absolue sur des iso-theta => vorateta
+c    4) on calcule la densite rho sur des iso-theta => rhoteta 
+c
+c       rhoteta = (T/theta)**(cp/R)*p0/(R*T)
+c
+c    5) on calcule la vorticite potentielle sur des iso-theta => PVteta
+c
+c       PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU
+c
+c       NB: 1PVU=10**(-6) K*m**2/(s * kg)
+c
+c       PVteta =  vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s)
+c
+c
+c    *******************************************************************
+c
+c
+c     Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta
+c                       -> sur la grille dynamique
+c     Variable de sortie : PVteta
+c                       -> sur la grille physique 
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+c
+c variables Input
+c
+      INTEGER ilon, ilev
+      REAL pvcov(iip1,jjm,ilev)
+      REAL pucov(iip1,jjp1,ilev)
+      REAL pteta(iip1,jjp1,ilev)
+      REAL ztfi(ilon,ilev)
+      REAL zplay(ilon,ilev), zplev(ilon,ilev+1)
+      INTEGER nbteta
+      REAL theta(nbteta)
+c
+c variable Output
+c
+      REAL PVteta(ilon,nbteta)
+c
+c variables locales
+c
+      INTEGER i, j, l, ig0
+      REAL SSUM
+      REAL teta(ilon, ilev)
+      REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev)
+      REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev)
+      REAL N2(ilon,ilev-1), N2teta(ilon,nbteta)
+      REAL ztfiteta(ilon,nbteta)
+      REAL rhoteta(ilon,nbteta)
+      REAL vorateta(iip1,jjm,nbteta)
+      REAL voratetafi(ilon,nbteta), vorpol(iim)
+c
+#include "comgeom2.h"
+#include "comconst.h"
+#include "comvert.h"
+c
+c projection teta sur la grille physique
+c
+      DO l=1,llm
+       teta(1,l)   =  pteta(1,1,l)
+       ig0         = 2
+       DO j = 2, jjm
+        DO i = 1, iim
+         teta(ig0,l)    = pteta(i,j,l)
+         ig0            = ig0 + 1
+        ENDDO
+       ENDDO
+       teta(ig0,l)    = pteta(1,jjp1,l)
+      ENDDO
+c
+c calcul pteta sur les grilles U et V
+c
+      DO l=1, llm
+       DO j=1, jjp1
+        DO i=1, iip1
+         ig0=i+(j-1)*iip1
+         ptetau(ig0,l)=pteta(i,j,l)
+        ENDDO !i
+       ENDDO !j
+       DO j=1, jjm
+        DO i=1, iip1
+         ig0=i+(j-1)*iip1
+         ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l))
+        ENDDO !i
+       ENDDO !j
+      ENDDO !l
+c
+c projection pucov, pvcov sur une surface de theta constante
+c
+      DO l=1, nbteta
+cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l),
+       CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l),
+     .                pucov,ucovteta(:,l))
+cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l),
+       CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l),
+     .                pvcov,vcovteta(:,l))
+      ENDDO !l
+c
+c calcul vorticite absolue sur une iso-theta : vorateta
+c
+      CALL tourabs(nbteta,vcovteta,ucovteta,vorateta)
+c
+c projection vorateta sur la grille physique => voratetafi
+c
+      DO l=1,nbteta
+       DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+         voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) +
+     $                           vorateta(i+1,j-1,l) * alpha1(i+1,j) +
+     $                           vorateta(i  ,j  ,l) * alpha3(i+1,j) +
+     $                           vorateta(i+1,j  ,l) * alpha2(i+1,j)
+        ENDDO
+        voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l)
+       ENDDO
+      ENDDO
+c
+      DO l=1,nbteta
+       DO i=1,iim
+        vorpol(i)  = vorateta(i,1,l)*aire(i,1)
+       ENDDO
+       voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln
+      ENDDO
+c
+      DO l=1,nbteta
+       DO i=1,iim
+        vorpol(i)  = vorateta(i,jjm,l)* aire(i,jjm +1)
+       ENDDO
+       voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols
+      ENDDO
+c 
+c calcul N**2 sur la grille physique => N2
+c
+      DO l=1, llm-1 
+       DO i=1, ilon
+        N2(i,l) = (g**2 * zplay(i,l) * 
+     $            (ztfi(i,l+1)-ztfi(i,l)) )/
+     $            (R*ztfi(i,l)*ztfi(i,l)*
+     $            (zplev(i,l)-zplev(i,l+1)) )+
+     $            (g**2)/(ztfi(i,l)*CPP)
+       ENDDO !i
+      ENDDO !l
+c
+c calcul N2 sur une iso-theta => N2teta 
+c
+      DO l=1, nbteta
+       CALL tetalevel(ilon,llm-1,.true.,teta,theta(l),
+     $                N2,N2teta(:,l))
+       CALL tetalevel(ilon,llm,.true.,teta,theta(l),
+     $                ztfi,ztfiteta(:,l))
+      ENDDO !l=1, nbteta
+c
+c calcul rho et PV sur une iso-theta : rhoteta, PVteta
+c
+      DO l=1, nbteta
+       DO i=1, ilon
+        rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)*
+     $  (preff/(R*ztfiteta(i,l)))
+c
+c PVteta en PVU
+c
+        PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/
+     $              (g**2*rhoteta(i,l))
+c
+c PVteta en 1/(Pa*s)
+c
+        PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/
+     $              (g**2*rhoteta(i,l))
+       ENDDO !i
+      ENDDO !l
+c
+      RETURN
+      END 
Index: LMDZ5/trunk/libf/abort_gcm.F
===================================================================
--- LMDZ5/trunk/libf/abort_gcm.F	(revision 1630)
+++ LMDZ5/trunk/libf/abort_gcm.F	(revision 1630)
@@ -0,0 +1,51 @@
+!
+! $Id: abort_gcm.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+c
+c
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin_dump
+      USE ioipsl_getincom
+#endif
+      USE parallel
+#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=*) :: modname
+      integer ierr
+      character (len=*) :: message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+c$OMP MASTER
+      call histclo
+      call restclo
+      if (MPI_rank .eq. 0) then
+         call getin_dump
+      endif
+c$OMP END MASTER
+#endif
+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 .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+      STOP
+      endif
+      END
Index: LMDZ5/trunk/libf/academic.h
===================================================================
--- LMDZ5/trunk/libf/academic.h	(revision 1630)
+++ LMDZ5/trunk/libf/academic.h	(revision 1630)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      real tetarappel(ip1jmp1,llm),taurappel
+      common/academic/tetarappel,taurappel
Index: LMDZ5/trunk/libf/adaptdt.F
===================================================================
--- LMDZ5/trunk/libf/adaptdt.F	(revision 1630)
+++ LMDZ5/trunk/libf/adaptdt.F	(revision 1630)
@@ -0,0 +1,60 @@
+!
+! $Id: adaptdt.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      subroutine adaptdt(nadv,dtbon,n,pbaru,
+     c                   masse)
+
+      USE control_mod
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.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: LMDZ5/trunk/libf/addfi_loc.F
===================================================================
--- LMDZ5/trunk/libf/addfi_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/addfi_loc.F	(revision 1630)
@@ -0,0 +1,246 @@
+!
+! $Header$
+!
+      SUBROUTINE addfi_loc(pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      USE parallel
+      USE infotrac, ONLY : nqtot
+      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 "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      REAL pdt
+c
+      REAL pvcov(ijb_v:ije_v,llm),pucov(ijb_u:ije_u,llm)
+      REAL pteta(ijb_u:ije_u,llm),pq(ijb_u:ije_u,llm,nqtot)
+      REAL pps(ijb_u:ije_u)
+c
+      REAL pdvfi(ijb_v:ije_v,llm),pdufi(ijb_u:ije_u,llm)
+      REAL pdqfi(ijb_u:ije_u,llm,nqtot),pdhfi(ijb_u:ije_u,llm)
+      REAL pdpfi(ijb_u:ije_u)
+c
+      LOGICAL leapf,forward
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      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
+ 
+      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
+
+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: LMDZ5/trunk/libf/addfi_p.F
===================================================================
--- LMDZ5/trunk/libf/addfi_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/addfi_p.F	(revision 1630)
@@ -0,0 +1,244 @@
+!
+! $Header$
+!
+      SUBROUTINE addfi_p(pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      USE parallel
+      USE infotrac, ONLY : nqtot
+      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 "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      REAL pdt
+c
+      REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
+      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1)
+c
+      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
+      REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
+c
+      LOGICAL leapf,forward
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      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
+ 
+      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
+
+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: LMDZ5/trunk/libf/advect_new_loc.F
===================================================================
--- LMDZ5/trunk/libf/advect_new_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/advect_new_loc.F	(revision 1630)
@@ -0,0 +1,295 @@
+!
+! $Header$
+!
+      SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby,
+     &                        du,dv,dteta)
+      USE parallel
+      USE write_field_loc
+      USE advect_new_mod
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+      REAL teta(ijb_u:ije_u,llm)
+      REAL massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
+      REAL w(ijb_u:ije_u,llm)
+      REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
+      REAL dteta(ijb_u:ije_u,llm)
+c   Local:
+c   ------
+
+      REAL wsur2(ijb_u:ije_u)
+      REAL unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l,ijb,ije
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+      
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+c$OMP MASTER
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+      DO ij=ijb,ije
+        du2(ij,1)=0.
+        du1(ij,llm)=0.
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+        dv2(ij,1)=0.
+        dv1(ij,llm)=0.
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+
+      DO ij=ijb,ije
+        dteta2(ij,1)=0.
+        dteta1(ij,llm)=0.
+      ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+ 
+c$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
+         
+c         DO    ij     = iip2, ip1jmp1
+c            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+c         ENDDO
+
+c         DO    ij     = iip2, ip1jm
+c            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+c         ENDDO
+         
+         DO    ij     = ijb, ije
+                  
+           uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
+     .	             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+         ENDDO
+         
+         if (pole_nord) then
+           DO      ij         = 1, iip1
+              uav(ij      ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO      ij         = 1, iip1
+              uav(ip1jm+ij,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+c$OMP END DO      
+c      call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+      
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO  l=1,llm
+         
+         DO    ij   = ijb+1, ije
+           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         
+         DO    ij   = ijb,ije,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         
+         
+         DO    ij   = ijb, ije-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         
+         DO    ij       = ijb, ije, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+         
+      ENDDO
+c$OMP END DO
+c       call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+
+c-----------------------------------------------------------------------
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if (pole_sud)  ije=ij_end
+      
+      DO 5   ij   = ijb, ije
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+         
+      DO 6 ij = ijb ,ije-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 8 ij = ijb, ije
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+        ijb=ij_begin
+        ije=ij_end
+        
+        DO 15 ij = ijb, ije
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta1(ij, l ) =   ww
+         dteta2(ij,l+1) =   ww
+  15    CONTINUE
+
+c ym ---> conser a voir plus tard
+
+c      IF( conser)  THEN
+c        
+c        DO 17 ij = 1,ip1jmp1
+c        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+c  17    CONTINUE
+c        gt       = SSUM( ip1jmp1,ge,1 )
+c        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+c      END IF
+
+  20  CONTINUE
+c$OMP END DO
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+#ifdef DEBUG_IO    
+       CALL WriteField_u('du_bis',du)     
+#endif
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+        DO ij=ijb,ije-1
+	  du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
+	ENDDO
+
+        DO   ij   = ijb+iip1-1, ije, iip1
+         du( ij, l  ) = du( ij -iim, l  )
+        ENDDO 
+      ENDDO
+c$OMP END DO NOWAIT
+#ifdef DEBUG_IO    
+      CALL WriteField_u('du1',du1)      
+      CALL WriteField_u('du2',du2)      
+      CALL WriteField_u('du_bis',du)      
+#endif
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+        DO ij=ijb,ije
+	  dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
+	ENDDO
+      ENDDO
+c$OMP END DO NOWAIT      
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO l=1,llm
+        DO ij=ijb,ije
+	  dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
+	ENDDO
+      ENDDO
+c$OMP END DO NOWAIT      
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/advect_new_mod.F90
===================================================================
--- LMDZ5/trunk/libf/advect_new_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/advect_new_mod.F90	(revision 1630)
@@ -0,0 +1,55 @@
+MODULE advect_new_mod
+
+  REAL,POINTER,SAVE :: dv1(:,:)
+  REAL,POINTER,SAVE :: du1(:,:)
+  REAL,POINTER,SAVE :: dteta1(:,:)
+  REAL,POINTER,SAVE :: dv2(:,:)
+  REAL,POINTER,SAVE :: du2(:,:)
+  REAL,POINTER,SAVE :: dteta2(:,:)
+  REAL,POINTER,SAVE :: uav(:,:)
+  REAL,POINTER,SAVE :: vav(:,:)
+
+  
+CONTAINS
+
+  SUBROUTINE advect_new_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_v(dv1,llm,d)
+    CALL allocate_u(du1,llm,d)
+    CALL allocate_u(dteta1,llm,d)
+    CALL allocate_v(dv2,llm,d)
+    CALL allocate_u(du2,llm,d)
+    CALL allocate_u(dteta2,llm,d)
+    CALL allocate_u(uav,llm,d)
+    CALL allocate_v(vav,llm,d)
+ 
+    
+  END SUBROUTINE advect_new_allocate
+  
+  SUBROUTINE advect_new_switch_caldyn(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_v(dv1,distrib_caldyn,dist)
+    CALL switch_u(du1,distrib_caldyn,dist)
+    CALL switch_u(dteta1,distrib_caldyn,dist)
+    CALL switch_v(dv2,distrib_caldyn,dist)
+    CALL switch_u(du2,distrib_caldyn,dist)
+    CALL switch_u(dteta2,distrib_caldyn,dist)
+    CALL switch_u(uav,distrib_caldyn,dist)
+    CALL switch_v(vav,distrib_caldyn,dist)
+
+  END SUBROUTINE advect_new_switch_caldyn
+  
+END MODULE advect_new_mod  
Index: LMDZ5/trunk/libf/advect_p.F
===================================================================
--- LMDZ5/trunk/libf/advect_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/advect_p.F	(revision 1630)
@@ -0,0 +1,219 @@
+!
+! $Header$
+!
+      SUBROUTINE advect_p(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
+      USE parallel
+      USE write_field_p
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l,ijb,ije
+
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+      DO  l=1,llm
+         
+         ijb=ij_begin
+         ije=ij_end
+         if (pole_nord) ijb=ijb+iip1
+         if (pole_sud)  ije=ije-iip1
+         
+c         DO    ij     = iip2, ip1jmp1
+c            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+c         ENDDO
+
+c         DO    ij     = iip2, ip1jm
+c            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+c         ENDDO
+         
+         DO    ij     = ijb, ije
+                  
+           uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
+     .	             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+         ENDDO
+         
+         if (pole_nord) then
+           DO      ij         = 1, iip1
+              uav(ij      ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO      ij         = 1, iip1
+              uav(ip1jm+ij,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+      
+c      call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+      
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO  l=1,llm
+         
+         DO    ij   = ijb+1, ije
+           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         
+         DO    ij   = ijb,ije,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         
+         
+         DO    ij   = ijb, ije-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         
+         DO    ij       = ijb, ije, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+         
+      ENDDO
+c       call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+c-----------------------------------------------------------------------
+
+
+      
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if (pole_sud)  ije=ij_end
+      
+      DO 5   ij   = ijb, ije
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+         
+      DO 6 ij = ijb ,ije-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .....  correction pour  du(iip1,j,l)  ........
+c     .....     du(iip1,j,l)= du(1,j,l)   .....
+
+CDIR$ IVDEP
+      DO   7  ij   = ijb+iip1-1, ije, iip1
+      du( ij, l  ) = du( ij -iim, l  )
+      du( ij,l+1 ) = du( ij -iim,l+1 )
+   7  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 8 ij = ijb, ije
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+        ijb=ij_begin
+        ije=ij_end
+        
+        DO 15 ij = ijb, ije
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta(ij, l ) = dteta(ij, l )  -  ww
+         dteta(ij,l+1) = dteta(ij,l+1)  +  ww
+  15    CONTINUE
+
+c ym ---> conser a voir plus tard
+
+c      IF( conser)  THEN
+c        
+c        DO 17 ij = 1,ip1jmp1
+c        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+c  17    CONTINUE
+c        gt       = SSUM( ip1jmp1,ge,1 )
+c        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+c      END IF
+
+  20  CONTINUE
+ 
+      RETURN
+      END
Index: LMDZ5/trunk/libf/advn.F
===================================================================
--- LMDZ5/trunk/libf/advn.F	(revision 1630)
+++ LMDZ5/trunk/libf/advn.F	(revision 1630)
@@ -0,0 +1,983 @@
+!
+! $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 "logic.h"
+#include "comvert.h"
+#include "comconst.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,ztemps3,ssum
+      logical testcpu
+      save testcpu
+      save temps1,temps2,temps3
+      real zzpbar,zzw
+
+#ifdef CRAY
+      real second
+#endif
+
+      real qmin,qmax
+      data qmin,qmax/0.,1./
+      data testcpu/.false./
+      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     ')
+
+#ifdef CRAY
+      if(testcpu) then
+         ztemps1=second(0.)
+         temps1=temps1+ztemps1-ztemps2
+            print*,'VLSPLT X:',temps1,'   Y:',temps2,'   Z:',temps3
+      endif
+#endif
+      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.eq.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).le.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.eq.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).le.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.eq.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).le.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 "logic.h"
+#include "comvert.h"
+#include "comconst.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
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+
+      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).gt.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).ge.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.gt.zm
+          zsig=zu/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (mode.eq.1) then
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*zqp
+             else if (mode.eq.1) then
+                 u_mq(ij,l)=
+     s           sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm)
+             endif 
+          else
+             if (zsig.le.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.gt.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).gt.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).ne.0) then
+                     iju=iju+1
+                     indu(iju)=ij
+                  endif
+               enddo
+               niju=iju
+c              print*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               do iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  if(zu_m.gt.0.) then
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   MODIFS SPECIFIQUES DU SCHEMA
+c   ajout de la maille non completement advectee
+             zsig=zu_m/masse(ijq,l)
+             if(zsig.le.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.gt.0..and.zz.le.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.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   ajout de la maille non completement advectee
+c 2eme MODIF SPECIFIQUE
+             zsig=-zu_m/masse(ij+1,l)
+             if(zsig.le.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.gt.0..and.zz.le.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
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+      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).gt.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).ge.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.eq.0.) zsigp=0.1
+          if (zsig.le.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
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-13/
+#endif
+
+      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).gt.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).ge.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.eq.0.) zsigp=0.1
+          if (zsig.le.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: LMDZ5/trunk/libf/advtrac_loc.F
===================================================================
--- LMDZ5/trunk/libf/advtrac_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/advtrac_loc.F	(revision 1630)
@@ -0,0 +1,360 @@
+!
+! $Id: advtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+#define DEBUG_IO
+#undef DEBUG_IO
+      SUBROUTINE advtrac_loc(pbarug,pbarvg ,wg,
+     *                   p,  massem,q,teta,
+     *                   pk   )
+
+c     Auteur :  F. Hourdin
+c
+c     Modif. P. Le Van     (20/12/97)
+c            F. Codron     (10/99)
+c            D. Le Croller (07/2001)
+c            M.A Filiberti (04/2002)
+c
+      USE parallel
+      USE Write_Field_loc
+      USE Write_Field
+      USE Bands
+      USE mod_hallo
+      USE Vampir
+      USE times
+      USE infotrac
+      USE control_mod
+      USE advtrac_mod
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comdissip.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+
+c-------------------------------------------------------------------
+c     Arguments
+c-------------------------------------------------------------------
+c     Ajout PPM
+c--------------------------------------------------------
+      REAL massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
+c--------------------------------------------------------
+      INTEGER iapptrac
+      REAL pbarug(ijb_u:ije_u,llm),pbarvg(ijb_v:ije_v,llm)
+      REAL wg(ijb_u:ije_u,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot),massem(ijb_u:ije_u,llm)
+      REAL p( ijb_u:ije_u,llmp1 ),teta(ijb_u:ije_u,llm)
+      REAL pk(ijb_u:ije_u,llm)
+
+c-------------------------------------------------------------
+c     Variables locales
+c-------------------------------------------------------------
+
+      REAL zdp(ijb_u:ije_u)
+      REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu
+      INTEGER,SAVE :: iadvtr=0
+c$OMP THREADPRIVATE(iadvtr)
+      INTEGER ij,l,iq,iiq
+      REAL zdpmin, zdpmax
+c----------------------------------------------------------
+c     Rajouts pour PPM
+c----------------------------------------------------------
+      INTEGER indice,n
+      REAL dtbon ! Pas de temps adaptatif pour que CFL<1
+      REAL CFLmaxz,aaa,bbb ! CFL maximum
+      REAL psppm(iim,jjb_u:jje_u) ! pression  au sol
+      REAL unatppm(iim,jjb_u:jje_u,llm),vnatppm(iim,jjb_u:jje_u,llm)
+      REAL qppm(iim*jjnb_u,llm,nqtot)
+      REAL fluxwppm(iim,jjb_u:jje_u,llm)
+      REAL apppm(llmp1), bpppm(llmp1)
+      LOGICAL dum,fill
+      DATA fill/.true./
+      DATA dum/.true./
+      integer ijb,ije,ijbu,ijbv,ijeu,ijev,j
+      type(Request) :: testRequest
+
+c  test sur l'eventuelle creation de valeurs negatives de la masse
+         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-1
+            DO ij = ijb+1,ije
+              zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l)
+     s                  - pbarvg(ij-iip1,l) + pbarvg(ij,l)
+     s                  +       wg(ij,l+1)  - wg(ij,l)
+            ENDDO
+            
+c            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+c ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
+            
+            do ij=ijb,ije-iip1+1,iip1
+              zdp(ij)=zdp(ij+iip1-1)
+            enddo
+            
+            DO ij = ijb,ije
+               zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+            ENDDO 
+
+
+c            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+c  ym ---> eventuellement a revoir
+            CALL minmax ( ije-ijb+1, zdp(ijb), zdpmin,zdpmax )
+            
+            IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+            PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin,
+     s        '   MAX:', zdpmax
+            ENDIF
+
+         ENDDO
+c$OMP END DO NOWAIT
+
+c-------------------------------------------------------------------
+c   Advection proprement dite (Modification Le Croller (07/2001)
+c-------------------------------------------------------------------
+
+c----------------------------------------------------
+c        Calcul des moyennes basées sur la masse
+c----------------------------------------------------
+
+cym      ----> Normalement, inutile pour les schémas classiques
+cym      ----> Revérifier lors de la parallélisation des autres schemas
+   
+cym          call massbar_p(massem,massebx,masseby)          
+
+#ifdef DEBUG_IO    
+          CALL WriteField_u('massem',massem)
+          CALL WriteField_u('wg',wg)
+          CALL WriteField_u('pbarug',pbarug)
+          CALL WriteField_v('pbarvg',pbarvg)
+          CALL WriteField_u('p_tmp',p)
+          CALL WriteField_u('pk_tmp',pk)
+          CALL WriteField_u('teta_tmp',teta)
+          do j=1,nqtot
+            call WriteField_u('q_adv'//trim(int2str(j)),
+     .                q(:,:,j))
+          enddo
+#endif
+
+!          
+!       call Register_Hallo_v(pbarvg,llm,1,1,1,1,TestRequest)
+!
+!       call SendRequest(TestRequest)
+!c$OMP BARRIER
+!       call WaitRequest(TestRequest)
+c$OMP BARRIER
+                 
+          call vlspltgen_loc( q,iadv, 2., massem, wg ,
+     *                        pbarug,pbarvg,dtvr,p,
+     *                        pk,teta )
+
+#ifdef DEBUG_IO     
+          do j=1,nqtot
+            call WriteField_u('q_adv'//trim(int2str(j)),
+     .                q(:,:,j))
+          enddo
+#endif
+         
+	  GOTO 1234     
+c-----------------------------------------------------------
+c     Appel des sous programmes d'advection
+c-----------------------------------------------------------
+      do iq=1,nqtot
+c        call clock(t_initial)
+        if(iadv(iq) == 0) cycle 
+c   ----------------------------------------------------------------
+c   Schema de Van Leer I MUSCL
+c   ----------------------------------------------------------------
+        if(iadv(iq).eq.10) THEN
+     
+!LF	    call vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
+
+c   ----------------------------------------------------------------
+c   Schema "pseudo amont" + test sur humidite specifique
+C    pour la vapeur d'eau. F. Codron
+c   ----------------------------------------------------------------
+        else if(iadv(iq).eq.14) then
+c
+cym           stop 'advtrac : appel à vlspltqs :schema non parallelise'
+!LF           CALL vlspltqs_p( q(1,1,1), 2., massem, wg ,
+!LF     *                 pbarug,pbarvg,dtvr,p,pk,teta )
+c   ----------------------------------------------------------------
+c   Schema de Frederic Hourdin
+c   ----------------------------------------------------------------
+        else if(iadv(iq).eq.12) then
+          stop 'advtrac : schema non parallelise'
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+           do indice=1,n
+            call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+           end do
+        else if(iadv(iq).eq.13) then
+          stop 'advtrac : schema non parallelise'
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+          do indice=1,n
+            call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+          end do
+c   ----------------------------------------------------------------
+c   Schema de pente SLOPES
+c   ----------------------------------------------------------------
+        else if (iadv(iq).eq.20) then
+          stop 'advtrac : schema non parallelise'
+
+            call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+c   ----------------------------------------------------------------
+c   Schema de Prather
+c   ----------------------------------------------------------------
+        else if (iadv(iq).eq.30) then
+          stop 'advtrac : schema non parallelise'
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg,
+     s                     n,dtbon)
+c   ----------------------------------------------------------------
+c   Schemas PPM Lin et Rood
+c   ----------------------------------------------------------------
+       else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND.
+     s                     iadv(iq).LE.18)) then
+
+           stop 'advtrac : schema non parallelise'
+
+c        Test sur le flux horizontal
+c        Pas de temps adaptatif
+         call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+         if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+         endif
+c        Test sur le flux vertical
+         CFLmaxz=0.
+         do l=2,llm
+           do ij=iip2,ip1jm
+            aaa=wg(ij,l)*dtvr/massem(ij,l)
+            CFLmaxz=max(CFLmaxz,aaa)
+            bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+            CFLmaxz=max(CFLmaxz,bbb)
+           enddo
+         enddo
+         if (CFLmaxz.GE.1) then
+            write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+         endif
+
+c-----------------------------------------------------------
+c        Ss-prg interface LMDZ.4->PPM3d
+c-----------------------------------------------------------
+
+          call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem,
+     s                 apppm,bpppm,massebx,masseby,pbarug,pbarvg,
+     s                 unatppm,vnatppm,psppm)
+
+          do indice=1,n
+c---------------------------------------------------------------------
+c                         VL (version PPM) horiz. et PPM vert.
+c---------------------------------------------------------------------
+                if (iadv(iq).eq.11) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+
+c----------------------------------------------------------------------
+c                           Monotonic PPM
+c----------------------------------------------------------------------
+               else if (iadv(iq).eq.16) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c                           Semi Monotonic PPM
+c---------------------------------------------------------------------
+               else if (iadv(iq).eq.17) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c                         Positive Definite PPM
+c---------------------------------------------------------------------
+                else if (iadv(iq).eq.18) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+                endif
+            enddo
+c-----------------------------------------------------------------
+c               Ss-prg interface PPM3d-LMDZ.4
+c-----------------------------------------------------------------
+                  call interpost(q(1,1,iq),qppm(1,1,iq))
+            endif
+c----------------------------------------------------------------------
+
+c-----------------------------------------------------------------
+c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
+c et Nord j=1
+c-----------------------------------------------------------------
+
+c                  call traceurpole(q(1,1,iq),massem)
+
+c calcul du temps cpu pour un schema donne
+
+
+       end DO
+
+1234  CONTINUE
+c$OMP BARRIER
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+       DO l = 1, llm
+         DO ij = ijb, ije
+           finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+         ENDDO
+       ENDDO
+c$OMP END DO
+
+       CALL qminimum_loc( q, 2, finmasse )
+
+
+       RETURN
+       END
+
Index: LMDZ5/trunk/libf/advtrac_mod.F90
===================================================================
--- LMDZ5/trunk/libf/advtrac_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/advtrac_mod.F90	(revision 1630)
@@ -0,0 +1,37 @@
+MODULE advtrac_mod
+
+  REAL,POINTER,SAVE :: finmasse(:,:)
+  
+CONTAINS
+
+  SUBROUTINE advtrac_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE infotrac
+  USE vlspltgen_mod
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+    
+    d=>distrib_vanleer
+    CALL allocate_u(finmasse,llm,d)
+    CALL vlspltgen_allocate
+  END SUBROUTINE advtrac_allocate
+  
+  SUBROUTINE advtrac_switch_vanleer(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE vlspltgen_mod
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(finmasse,distrib_vanleer,dist)
+
+    CALL vlspltgen_switch_vanleer(dist)
+
+  END SUBROUTINE advtrac_switch_vanleer  
+  
+END MODULE advtrac_mod  
Index: LMDZ5/trunk/libf/advx.F
===================================================================
--- LMDZ5/trunk/libf/advx.F	(revision 1630)
+++ LMDZ5/trunk/libf/advx.F	(revision 1630)
@@ -0,0 +1,497 @@
+!
+! $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"
+#include "comconst.h"
+#include "comvert.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 300 j = 1,jjp1 
+         NUM(j) = 1
+  300 CONTINUE
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+               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 500 l = 1,llm
+         DO 500 j = 1,jjm+1
+            DO 500 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)
+  500 CONTINUE
+
+
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+  
+C  start here          
+C
+C  boucle principale sur les niveaux et les latitudes
+C
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      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.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0(I,JV)=0.
+         TX(I,JV)=0.
+         TY(I,JV)=0.
+         TZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 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)
+ 113     CONTINUE
+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
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 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)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+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 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))
+ 120  CONTINUE
+ 12   CONTINUE
+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 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.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 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.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
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 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
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.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
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.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
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.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
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 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)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 180 I2=1,NUMK
+C
+         DO 180 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
+ 180     CONTINUE
+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 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 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)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+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
+             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: LMDZ5/trunk/libf/advxp.F
===================================================================
--- LMDZ5/trunk/libf/advxp.F	(revision 1630)
+++ LMDZ5/trunk/libf/advxp.F	(revision 1630)
@@ -0,0 +1,650 @@
+!
+! $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"
+#include "comconst.h"
+#include "comvert.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 300 j =1,jjp1
+         NUM(j) =1 
+ 300  CONTINUE
+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 500 l = 1,llm
+       DO 500 j = 1,jjp1
+       DO 500 i = 1,iip1
+       ugri (i,j,llm+1-l) =pbaru (i,j,l) 
+ 500   CONTINUE
+
+C  ---------------------------------------------------------
+C  start here
+C
+C  boucle principale sur les niveaux et les latitudes
+C     
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      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.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 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.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 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)
+ 113     CONTINUE
+C
+         DO 114 JV=1,NTRA
+         DO 1140 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)
+ 1140    CONTINUE
+ 114     CONTINUE
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 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)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+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 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        IF(T0(I,JV).GT.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
+ 120  CONTINUE
+ 12   CONTINUE
+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 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.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 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 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)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.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
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 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
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.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
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 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)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.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
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.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
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 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)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 18 I2=1,NUMK
+C
+         DO 180 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
+ 180     CONTINUE
+C
+         DO 181 JV=1,NTRA
+         DO 181 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
+ 181     CONTINUE
+C
+ 18   CONTINUE
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 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)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+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: LMDZ5/trunk/libf/advy.F
===================================================================
--- LMDZ5/trunk/libf/advy.F	(revision 1630)
+++ LMDZ5/trunk/libf/advy.F	(revision 1630)
@@ -0,0 +1,422 @@
+!
+! $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 "comconst.h"
+#include "comvert.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 1 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 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 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))
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.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
+ 21   CONTINUE
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.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
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.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
+ 25   CONTINUE
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.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
+ 260  CONTINUE
+ 26   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 KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 300  CONTINUE
+ 30   CONTINUE
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 310  CONTINUE
+ 31   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 320  CONTINUE
+ 32   CONTINUE
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 330  CONTINUE
+ 33   CONTINUE
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.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
+ 41   CONTINUE
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.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
+ 420  CONTINUE
+ 42   CONTINUE
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 45   CONTINUE
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 460  CONTINUE
+ 46   CONTINUE
+C
+ 1    CONTINUE
+C
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/advyp.F
===================================================================
--- LMDZ5/trunk/libf/advyp.F	(revision 1630)
+++ LMDZ5/trunk/libf/advyp.F	(revision 1630)
@@ -0,0 +1,653 @@
+!
+! $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 "comconst.h"
+#include "comvert.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 500 l = 1,llm
+         DO 500 j = 1,jjm
+            DO 500 i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
+  500 CONTINUE
+
+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 1 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 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         IF(S0(I,K,L,JV).GT.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
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.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
+ 21   CONTINUE
+c     print*,'ADVYP 21'
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.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
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+c     print*,'av ADVYP 25'
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.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
+ 25   CONTINUE
+c     print*,'av ADVYP 25'
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.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
+ 260  CONTINUE
+ 26   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 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 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 300  CONTINUE
+ 30   CONTINUE
+c     print*,'ap ADVYP 30'
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 310  CONTINUE
+ 31   CONTINUE
+c     print*,'ap ADVYP 31'
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 320  CONTINUE
+ 32   CONTINUE
+c     print*,'ap ADVYP 32'
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 330  CONTINUE
+ 33   CONTINUE
+c     print*,'ap ADVYP 33'
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.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
+ 41   CONTINUE
+c     print*,'ap ADVYP 41'
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.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
+ 420  CONTINUE
+ 42   CONTINUE
+c     print*,'ap ADVYP 42'
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+c     print*,'ap ADVYP 43'
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 45   CONTINUE
+c     print*,'ap ADVYP 45'
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.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
+ 460  CONTINUE
+ 46   CONTINUE
+c     print*,'ap ADVYP 46'
+C
+ 1    CONTINUE
+
+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: LMDZ5/trunk/libf/advz.F
===================================================================
--- LMDZ5/trunk/libf/advz.F	(revision 1630)
+++ LMDZ5/trunk/libf/advz.F	(revision 1630)
@@ -0,0 +1,320 @@
+!
+! $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"
+#include "comconst.h"
+#include "comvert.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
+               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 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 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.
+  500 CONTINUE
+         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 1 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 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 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))
+ 100     CONTINUE
+ 10   CONTINUE
+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 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+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
+               sqf = sqf + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+      PRINT*,'sqf=', sqf
+
+C-------------------------------------------------------------
+      RETURN
+      END
+C_______________________________________________________________
+C_______________________________________________________________
Index: LMDZ5/trunk/libf/advzp.F
===================================================================
--- LMDZ5/trunk/libf/advzp.F	(revision 1630)
+++ LMDZ5/trunk/libf/advzp.F	(revision 1630)
@@ -0,0 +1,378 @@
+!
+! $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 "comconst.h"
+#include "comvert.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 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+            wgri (i,j,llm+1-l) = w (i,j,l)  
+  500 CONTINUE
+      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 1 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 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            IF(S0(I,K,L,JV).GT.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
+ 100     CONTINUE
+ 10   CONTINUE
+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 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.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
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+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: LMDZ5/trunk/libf/allocate_field_mod.f90
===================================================================
--- LMDZ5/trunk/libf/allocate_field_mod.f90	(revision 1630)
+++ LMDZ5/trunk/libf/allocate_field_mod.f90	(revision 1630)
@@ -0,0 +1,739 @@
+MODULE allocate_field
+
+  INTERFACE allocate_u
+    MODULE PROCEDURE allocate1d_u1d,allocate2d_u1d,allocate3d_u1d
+  END INTERFACE allocate_u
+
+  INTERFACE switch_u
+    MODULE PROCEDURE switch1d_u1d,switch2d_u1d,switch3d_u1d
+  END INTERFACE switch_u
+
+  INTERFACE switch_v
+    MODULE PROCEDURE switch1d_v1d,switch2d_v1d,switch3d_v1d
+  END INTERFACE switch_v
+
+  INTERFACE allocate_v
+    MODULE PROCEDURE allocate1d_v1d,allocate2d_v1d,allocate3d_v1d
+  END INTERFACE allocate_v
+
+  INTERFACE allocate2d_u
+    MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d
+  END INTERFACE allocate2d_u
+
+  INTERFACE allocate2d_v
+    MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d
+  END INTERFACE allocate2d_v
+
+  INTERFACE switch2d_u
+    MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d
+  END INTERFACE switch2d_u
+
+  INTERFACE switch2d_v
+    MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d
+  END INTERFACE switch2D_v
+
+  REAL :: nan
+
+CONTAINS
+
+  SUBROUTINE Init_nan
+  IMPLICIT NONE
+    REAL*8 :: rnan
+    INTEGER :: inan(2)
+    EQUIVALENCE(rnan,inan)
+    
+    inan(1)=2147483647
+    inan(2)=2147483647
+    
+    nan=rnan
+  
+  END SUBROUTINE Init_nan
+
+  SUBROUTINE allocate1d_u1d(field,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u1d
+
+
+  SUBROUTINE allocate2d_u1d(field,dim1,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_u1d 
+
+  SUBROUTINE allocate3d_u1d(field,dim1,dim2,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u1d   
+
+
+
+  SUBROUTINE allocate1d_v1d(field,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v1d
+
+
+  SUBROUTINE allocate2d_v1d(field,dim1,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_v1d 
+
+  SUBROUTINE allocate3d_v1d(field,dim1,dim2,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v1d   
+
+
+
+
+
+
+
+
+
+  SUBROUTINE allocate1d_u2d(field,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u2d
+
+
+  SUBROUTINE allocate2d_u2d(field,dim1,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_u2d
+
+  SUBROUTINE allocate3d_u2d(field,dim1,dim2,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u2d   
+
+
+
+  SUBROUTINE allocate1d_v2d(field,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v2d
+
+
+  SUBROUTINE allocate2d_v2d(field,dim1,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_v2d
+
+  SUBROUTINE allocate3d_v2d(field,dim1,dim2,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v2d   
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u1d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+  
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+   
+    CALL barrier
+  END SUBROUTINE switch1d_u1d  
+  
+  SUBROUTINE switch2d_u1d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_u1d  
+
+  SUBROUTINE switch3d_u1d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u1d  
+
+
+
+
+  SUBROUTINE switch1d_v1d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch1d_v1d  
+  
+  SUBROUTINE switch2d_v1d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_v1d  
+
+  SUBROUTINE switch3d_v1d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_v1d  
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_u2d  
+  
+  SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_u2d  
+
+  SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u2d  
+
+
+
+
+  SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_v2d  
+  
+  SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch2d_v2d  
+
+  SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch3d_v2d 
+
+END MODULE allocate_field
+  
+  
+  
+  
Index: LMDZ5/trunk/libf/allocate_field_mod.f90.mod
===================================================================
--- LMDZ5/trunk/libf/allocate_field_mod.f90.mod	(revision 1630)
+++ LMDZ5/trunk/libf/allocate_field_mod.f90.mod	(revision 1630)
@@ -0,0 +1,739 @@
+MODULE allocate_field
+
+  INTERFACE allocate_u
+    MODULE PROCEDURE allocate1d_u,allocate1d_u2d,allocate2d_u2d,allocate3d_u2d,allocate3d_u
+  END INTERFACE allocate_u
+
+  INTERFACE switch_u
+    MODULE PROCEDURE switch1d_u,switch1d_u2d,switch2d_u2d,switch3d_u2d,switch3d_u
+  END INTERFACE switch_u
+
+  INTERFACE switch_v
+    MODULE PROCEDURE switch1d_v,switch1d_v2d,switch2d_v2d,switch3d_v2d,switch3d_v
+  END INTERFACE switch_v
+
+  INTERFACE allocate_v
+    MODULE PROCEDURE allocate1d_v,allocate1d_v2d,allocate2d_v2d,allocate3d_v2d,allocate3d_v
+  END INTERFACE allocate_v
+
+  INTERFACE allocate2d_u
+    MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d
+  END INTERFACE allocate2d_u
+
+  INTERFACE allocate2d_v
+    MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d
+  END INTERFACE allocate2d_v
+
+  INTERFACE switch2d_u
+    MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d
+  END INTERFACE switch2d_u
+
+  INTERFACE switch2d_v
+    MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d
+  END INTERFACE switch2D_v
+
+  REAL :: nan
+
+CONTAINS
+
+  SUBROUTINE Init_nan
+  IMPLICIT NONE
+    REAL*8 :: rnan
+    INTEGER :: inan(2)
+    EQUIVALENCE(rnan,inan)
+    
+    inan(1)=2147483647
+    inan(2)=2147483647
+    
+    nan=rnan
+  
+  END SUBROUTINE Init_nan
+
+  SUBROUTINE allocate1d_u(field,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u
+
+
+!!  SUBROUTINE allocate2d_u(field,dim1,d)
+!!  USE parallel
+!!  IMPLICIT NONE
+!!  REAL,POINTER :: field(:,:)
+!!  INTEGER      :: dim1
+!!   TYPE(distrib),INTENT(IN) :: d
+!! 
+!!!$OMP BARRIER
+!!!$OMP MASTER    
+!!    IF (ASSOCIATED(field)) DEALLOCATE(field)
+!!    ALLOCATE(field(d%ijb_u:d%ije_u,dim1))
+!!!$OMP END MASTER
+!!!$OMP BARRIER
+!!
+!!  END SUBROUTINE allocate2d_u 
+
+  SUBROUTINE allocate3d_u(field,dim1,dim2,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u   
+
+
+
+  SUBROUTINE allocate1d_v(field,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v
+
+
+!!  SUBROUTINE allocate2d_v(field,dim1,d)
+!!  USE parallel
+!!  IMPLICIT NONE
+!!  REAL,POINTER :: field(:,:)
+!!  INTEGER      :: dim1
+!!  TYPE(distrib),INTENT(IN) :: d
+!!
+!!!$OMP BARRIER
+!!!$OMP MASTER    
+!!    IF (ASSOCIATED(field)) DEALLOCATE(field)
+!!    ALLOCATE(field(d%ijb_v:d%ije_v,dim1))
+!!!$OMP END MASTER
+!!!$OMP BARRIER
+!!
+!!  END SUBROUTINE allocate2d_v 
+
+  SUBROUTINE allocate3d_v(field,dim1,dim2,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v   
+
+
+
+
+
+
+
+
+
+  SUBROUTINE allocate1d_u2d(field,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u2d
+
+
+  SUBROUTINE allocate2d_u2d(field,dim1,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_u2d
+
+  SUBROUTINE allocate3d_u2d(field,dim1,dim2,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u2d   
+
+
+
+  SUBROUTINE allocate1d_v2d(field,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v2d
+
+
+  SUBROUTINE allocate2d_v2d(field,dim1,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_v2d
+
+  SUBROUTINE allocate3d_v2d(field,dim1,dim2,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v2d   
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+  
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+   
+    CALL barrier
+  END SUBROUTINE switch1d_u  
+  
+!!  SUBROUTINE switch2d_u(field,old_dist,new_dist,up,down)
+!!  USE parallel
+!!  USE mod_hallo
+!!  IMPLICIT NONE
+!!  REAL,POINTER :: field(:,:)
+!!  TYPE(distrib),INTENT(IN) :: old_dist
+!!  TYPE(distrib),INTENT(IN) :: new_dist
+!!  INTEGER, OPTIONAL,INTENT(IN) :: up
+!!  INTEGER, OPTIONAL,INTENT(IN) :: down
+!!
+!!  REAL,POINTER,SAVE :: new_field(:,:)
+!!  TYPE(request) :: req
+!!  
+!!  !$OMP BARRIER
+!!  !$OMP MASTER    
+!!    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2)))
+!!    new_field=nan
+!!  !$OMP END MASTER
+!!  !$OMP BARRIER
+!!    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+!!  
+!!    CALL SendRequest(req)
+!!
+!!  !$OMP BARRIER
+!!    CALL WaitRequest(req)     
+!!  !$OMP BARRIER
+!!    
+!!  !$OMP MASTER
+!!    DEALLOCATE(field)
+!!    field=>new_field
+!!  !$OMP END MASTER
+!!  !$OMP BARRIER
+!!    CALL barrier
+!!
+!!  END SUBROUTINE switch2d_u  
+
+  SUBROUTINE switch3d_u(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u  
+
+
+
+
+  SUBROUTINE switch1d_v(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch1d_v  
+  
+!!  SUBROUTINE switch2d_v(field,old_dist,new_dist,up,down)
+!!  USE parallel
+!!  USE mod_hallo
+!!  IMPLICIT NONE
+!!  REAL,POINTER :: field(:,:)
+!!  TYPE(distrib),INTENT(IN) :: old_dist
+!!  TYPE(distrib),INTENT(IN) :: new_dist
+!!  INTEGER, OPTIONAL,INTENT(IN) :: up
+!!  INTEGER, OPTIONAL,INTENT(IN) :: down
+!!
+!!  REAL,POINTER,SAVE :: new_field(:,:)
+!!  TYPE(request) :: req
+!!  
+!!  !$OMP BARRIER
+!!  !$OMP MASTER    
+!!    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2)))
+!!    new_field=nan
+!!  !$OMP END MASTER
+!!  !$OMP BARRIER
+!!    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+!!  
+!!    CALL SendRequest(req)
+!!
+!!  !$OMP BARRIER
+!!    CALL WaitRequest(req)     
+!!  !$OMP BARRIER
+!!    
+!!  !$OMP MASTER
+!!    DEALLOCATE(field)
+!!    field=>new_field
+!!  !$OMP END MASTER
+!!  !$OMP BARRIER
+!!    CALL barrier
+!!
+!!  END SUBROUTINE switch2d_v  
+
+  SUBROUTINE switch3d_v(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_v  
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_u2d  
+  
+  SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_u2d  
+
+  SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u2d  
+
+
+
+
+  SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_v2d  
+  
+  SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch2d_v2d  
+
+  SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch3d_v2d 
+
+END MODULE allocate_field
+  
+  
+  
+  
Index: LMDZ5/trunk/libf/allocate_field_mod.f90.modified
===================================================================
--- LMDZ5/trunk/libf/allocate_field_mod.f90.modified	(revision 1630)
+++ LMDZ5/trunk/libf/allocate_field_mod.f90.modified	(revision 1630)
@@ -0,0 +1,739 @@
+MODULE allocate_field
+
+  INTERFACE allocate_u
+    MODULE PROCEDURE allocate1d_u,allocate1d_u2d,allocate2d_u2d,allocate3d_u2d,allocate3d_u
+  END INTERFACE allocate_u
+
+  INTERFACE switch_u
+    MODULE PROCEDURE switch1d_u,switch1d_u2d,switch2d_u2d,switch3d_u2d,switch3d_u
+  END INTERFACE switch_u
+
+  INTERFACE switch_v
+    MODULE PROCEDURE switch1d_v,switch1d_v2d,switch2d_v2d,switch3d_v2d,switch3d_v
+  END INTERFACE switch_v
+
+  INTERFACE allocate_v
+    MODULE PROCEDURE allocate1d_v,allocate1d_v2d,allocate2d_v2d,allocate3d_v2d,allocate3d_v
+  END INTERFACE allocate_v
+
+  INTERFACE allocate2d_u
+    MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d
+  END INTERFACE allocate2d_u
+
+  INTERFACE allocate2d_v
+    MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d
+  END INTERFACE allocate2d_v
+
+  INTERFACE switch2d_u
+    MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d
+  END INTERFACE switch2d_u
+
+  INTERFACE switch2d_v
+    MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d
+  END INTERFACE switch2D_v
+
+  REAL :: nan
+
+CONTAINS
+
+  SUBROUTINE Init_nan
+  IMPLICIT NONE
+    REAL*8 :: rnan
+    INTEGER :: inan(2)
+    EQUIVALENCE(rnan,inan)
+    
+    inan(1)=2147483647
+    inan(2)=2147483647
+    
+    nan=rnan
+  
+  END SUBROUTINE Init_nan
+
+  SUBROUTINE allocate1d_u(field,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u
+
+
+!  SUBROUTINE allocate2d_u(field,dim1,d)
+!  USE parallel
+!  IMPLICIT NONE
+!  REAL,POINTER :: field(:,:)
+!  INTEGER      :: dim1
+!  TYPE(distrib),INTENT(IN) :: d
+!
+!!$OMP BARRIER
+!!$OMP MASTER    
+!    IF (ASSOCIATED(field)) DEALLOCATE(field)
+!    ALLOCATE(field(d%ijb_u:d%ije_u,dim1))
+!!$OMP END MASTER
+!!$OMP BARRIER
+!
+!  END SUBROUTINE allocate2d_u 
+
+  SUBROUTINE allocate3d_u(field,dim1,dim2,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u   
+
+
+
+  SUBROUTINE allocate1d_v(field,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v
+
+
+!  SUBROUTINE allocate2d_v(field,dim1,d)
+!  USE parallel
+!  IMPLICIT NONE
+!  REAL,POINTER :: field(:,:)
+!  INTEGER      :: dim1
+!  TYPE(distrib),INTENT(IN) :: d
+!
+!!$OMP BARRIER
+!!$OMP MASTER    
+!    IF (ASSOCIATED(field)) DEALLOCATE(field)
+!    ALLOCATE(field(d%ijb_v:d%ije_v,dim1))
+!!$OMP END MASTER
+!!$OMP BARRIER
+!
+!  END SUBROUTINE allocate2d_v 
+
+  SUBROUTINE allocate3d_v(field,dim1,dim2,d)
+  USE parallel
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v   
+
+
+
+
+
+
+
+
+
+  SUBROUTINE allocate1d_u2d(field,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u2d
+
+
+  SUBROUTINE allocate2d_u2d(field,dim1,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_u2d
+
+  SUBROUTINE allocate3d_u2d(field,dim1,dim2,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u2d   
+
+
+
+  SUBROUTINE allocate1d_v2d(field,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v2d
+
+
+  SUBROUTINE allocate2d_v2d(field,dim1,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_v2d
+
+  SUBROUTINE allocate3d_v2d(field,dim1,dim2,d)
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v2d   
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+  
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+   
+    CALL barrier
+  END SUBROUTINE switch1d_u  
+  
+!  SUBROUTINE switch2d_u(field,old_dist,new_dist,up,down)
+!  USE parallel
+!  USE mod_hallo
+!  IMPLICIT NONE
+!  REAL,POINTER :: field(:,:)
+!  TYPE(distrib),INTENT(IN) :: old_dist
+!  TYPE(distrib),INTENT(IN) :: new_dist
+!  INTEGER, OPTIONAL,INTENT(IN) :: up
+!  INTEGER, OPTIONAL,INTENT(IN) :: down
+!
+!  REAL,POINTER,SAVE :: new_field(:,:)
+!  TYPE(request) :: req
+!  
+!  !$OMP BARRIER
+!  !$OMP MASTER    
+!    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2)))
+!    new_field=nan
+!  !$OMP END MASTER
+!  !$OMP BARRIER
+!    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+!  
+!    CALL SendRequest(req)
+!
+!  !$OMP BARRIER
+!    CALL WaitRequest(req)     
+!  !$OMP BARRIER
+!    
+!  !$OMP MASTER
+!    DEALLOCATE(field)
+!    field=>new_field
+!  !$OMP END MASTER
+!  !$OMP BARRIER
+!    CALL barrier
+!
+!  END SUBROUTINE switch2d_u  
+
+  SUBROUTINE switch3d_u(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u  
+
+
+
+
+  SUBROUTINE switch1d_v(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch1d_v  
+  
+!  SUBROUTINE switch2d_v(field,old_dist,new_dist,up,down)
+!  USE parallel
+!  USE mod_hallo
+!  IMPLICIT NONE
+!  REAL,POINTER :: field(:,:)
+!  TYPE(distrib),INTENT(IN) :: old_dist
+!  TYPE(distrib),INTENT(IN) :: new_dist
+!  INTEGER, OPTIONAL,INTENT(IN) :: up
+!  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+!  REAL,POINTER,SAVE :: new_field(:,:)
+!  TYPE(request) :: req
+  
+!  !$OMP BARRIER
+!  !$OMP MASTER    
+!    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2)))
+!    new_field=nan
+!  !$OMP END MASTER
+!  !$OMP BARRIER
+!    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+!  
+!    CALL SendRequest(req)
+!
+!  !$OMP BARRIER
+!    CALL WaitRequest(req)     
+!  !$OMP BARRIER
+!    
+!  !$OMP MASTER
+!    DEALLOCATE(field)
+!    field=>new_field
+!  !$OMP END MASTER
+!  !$OMP BARRIER
+!    CALL barrier
+!
+!  END SUBROUTINE switch2d_v  
+
+  SUBROUTINE switch3d_v(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_v  
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_u2d  
+  
+  SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_u2d  
+
+  SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u2d  
+
+
+
+
+  SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_v2d  
+  
+  SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch2d_v2d  
+
+  SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel
+  USE mod_hallo
+  USE dimensions
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch3d_v2d 
+
+END MODULE allocate_field
+  
+  
+  
+  
Index: LMDZ5/trunk/libf/bands.F90
===================================================================
--- LMDZ5/trunk/libf/bands.F90	(revision 1630)
+++ LMDZ5/trunk/libf/bands.F90	(revision 1630)
@@ -0,0 +1,482 @@
+!
+! $Id: bands.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+  module Bands
+  USE parallel
+    integer, parameter :: bands_caldyn=1
+    integer, parameter :: bands_vanleer=2
+    integer, parameter :: bands_dissip=3
+    
+    INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2
+    INTEGER,dimension(:),allocatable :: jj_Nb_dissip
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis
+   
+    TYPE(distrib),SAVE,TARGET :: distrib_Caldyn
+    TYPE(distrib),SAVE,TARGET :: distrib_vanleer
+    TYPE(distrib),SAVE,TARGET :: distrib_vanleer2
+    TYPE(distrib),SAVE,TARGET :: distrib_dissip
+    TYPE(distrib),SAVE,TARGET :: distrib_physic
+    TYPE(distrib),SAVE,TARGET :: distrib_physic_bis
+
+    INTEGER,dimension(:),allocatable :: distrib_phys
+  
+  contains
+  
+  subroutine AllocateBands
+    use parallel
+    implicit none
+    
+    allocate(jj_Nb_Caldyn(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer2(0:MPI_Size-1))
+    allocate(jj_Nb_dissip(0:MPI_Size-1))
+    allocate(jj_Nb_physic(0:MPI_Size-1))
+    allocate(jj_Nb_physic_bis(0:MPI_Size-1))
+    allocate(distrib_phys(0:MPI_Size-1))
+  
+  end subroutine AllocateBands
+  
+  subroutine Read_distrib
+    use parallel
+    implicit none
+
+    include "dimensions.h"
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+    
+      call AllocateBands
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+       
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+      
+         do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_caldyn(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_vanleer(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_dissip(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,distrib_phys(i)
+        enddo
+	
+	CLOSE(unit_number)  
+  
+      else
+        do i=0,mpi_size-1
+          jj_nb_caldyn(i)=(jjm+1)/mpi_size
+	  if (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
+        enddo
+      
+        jj_nb_vanleer(:)=jj_nb_caldyn(:)
+        jj_nb_dissip(:)=jj_nb_caldyn(:)
+        
+	do i=0,mpi_size-1
+	  distrib_phys(i)=(iim*(jjm-1)+2)/mpi_size
+	  IF (i<MOD(iim*(jjm-1)+2,mpi_size)) distrib_phys(i)=distrib_phys(i)+1
+	enddo
+      endif
+      
+!      distrib_phys(:)=jj_nb_caldyn(:)*iim
+!      distrib_phys(0) = distrib_phys(0) - (iim-1)
+!      distrib_phys(mpi_size-1) = distrib_phys(mpi_size-1) - (iim-1)
+      
+   end subroutine Read_distrib
+   
+   
+   SUBROUTINE  Set_Bands 
+     USE parallel
+#ifdef CPP_EARTH
+! Ehouarn: what follows is only related to // physics; for now only for Earth 
+     USE mod_phys_lmdz_para, ONLY : jj_para_begin,jj_para_end
+#endif
+     IMPLICIT NONE
+     INCLUDE 'dimensions.h'    
+     INTEGER :: i
+        
+      do i=0,mpi_size-1
+         jj_nb_vanleer2(i)=(jjm+1)/mpi_size
+	 if (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
+      enddo
+          
+#ifdef CPP_EARTH
+! Ehouarn: what follows is only related to // physics; for now only for Earth          
+      do i=0,MPI_Size-1
+        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic(i-1)=jj_Nb_physic(i-1)-1
+          endif
+        endif
+      enddo
+      
+      do i=0,MPI_Size-1
+        jj_Nb_physic_bis(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+          else
+	    jj_Nb_physic_bis(i-1)=jj_Nb_physic_bis(i-1)+1
+	    jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+	  endif
+        endif
+      enddo
+#endif      
+      CALL create_distrib(jj_Nb_Caldyn,distrib_caldyn)
+      CALL create_distrib(jj_Nb_vanleer,distrib_vanleer)
+      CALL create_distrib(jj_Nb_vanleer2,distrib_vanleer2)
+      CALL create_distrib(jj_Nb_dissip,distrib_dissip)
+      CALL create_distrib(jj_Nb_physic,distrib_physic)
+      CALL create_distrib(jj_Nb_physic_bis,distrib_physic_bis)
+      
+      distrib_physic_bis%jjb_u=distrib_physic%jjb_u
+      distrib_physic_bis%jje_u=distrib_physic%jje_u
+      distrib_physic_bis%jjnb_u=distrib_physic%jjnb_u
+
+      distrib_physic_bis%ijb_u=distrib_physic%ijb_u
+      distrib_physic_bis%ije_u=distrib_physic%ije_u
+      distrib_physic_bis%ijnb_u=distrib_physic%ijnb_u
+
+      distrib_physic_bis%jjb_v=distrib_physic%jjb_v
+      distrib_physic_bis%jje_v=distrib_physic%jje_v
+      distrib_physic_bis%jjnb_v=distrib_physic%jjnb_v
+
+      distrib_physic_bis%ijb_v=distrib_physic%ijb_v
+      distrib_physic_bis%ije_v=distrib_physic%ije_v
+      distrib_physic_bis%ijnb_v=distrib_physic%ijnb_v
+     
+    end subroutine Set_Bands
+
+
+    subroutine AdjustBands_caldyn(new_dist)
+      use times
+      use parallel
+      implicit none
+      TYPE(distrib),INTENT(INOUT) :: new_dist
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+        if (jj_nb_caldyn(max_proc)>3) then
+          if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then
+             jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+             jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
+	        -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then
+               jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+               jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+      CALL create_distrib(jj_nb_caldyn,new_dist)
+        
+    end subroutine AdjustBands_caldyn
+    
+    subroutine AdjustBands_vanleer(new_dist)
+      use times
+      use parallel
+      implicit none
+      TYPE(distrib),INTENT(INOUT) :: new_dist
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_vanleer(max_proc)>3) then
+          if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. &
+             timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then
+             jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+             jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then
+               jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+               jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+ 
+      CALL create_distrib(jj_nb_vanleer,new_dist)
+         
+    end subroutine AdjustBands_vanleer
+
+    subroutine AdjustBands_dissip(new_dist)
+      use times
+      use parallel
+      implicit none
+      TYPE(distrib),INTENT(INOUT) :: new_dist
+      
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_dissip(max_proc)>3) then
+          if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then
+             jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+             jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
+	        - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then
+               jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+               jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+  
+      CALL create_distrib(jj_nb_dissip,new_dist)
+         
+    end subroutine AdjustBands_dissip
+
+    subroutine AdjustBands_physic
+      use times
+#ifdef CPP_EARTH
+! Ehouarn: what follows is only related to // physics; for now only for Earth 
+      USE mod_phys_lmdz_para, only : klon_mpi_para_nb
+#endif
+      USE parallel
+      implicit none
+
+      integer :: i,Index
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: Inc
+      real :: medium
+      integer :: NbTot,sgn
+      
+      allocate(value(0:mpi_size-1))
+      allocate(Inc(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+      
+      medium=0
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_physic(i),timer_physic,i)
+	medium=medium+value(i)
+      enddo    
+      
+      medium=medium/mpi_size      
+      NbTot=0
+#ifdef CPP_EARTH
+! Ehouarn: what follows is only related to // physics; for now only for Earth 
+      do i=0,mpi_size-1
+        Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i))
+        NbTot=NbTot+Inc(i)  
+      enddo
+      
+      if (NbTot>=0) then
+        Sgn=1
+      else
+        Sgn=-1
+	NbTot=-NbTot
+      endif
+      
+      Index=0
+      do i=1,NbTot
+        Inc(Index)=Inc(Index)-Sgn
+	Index=Index+1
+	if (Index>mpi_size-1) Index=0
+      enddo
+      
+      do i=0,mpi_size-1
+        distrib_phys(i)=klon_mpi_para_nb(i)+inc(i)
+      enddo
+#endif  
+         
+    end subroutine AdjustBands_physic
+
+    subroutine WriteBands
+    USE parallel
+    implicit none
+    include "dimensions.h"
+
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+  
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+      
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+        
+!	write (unit_number,*) '*** Bandes caldyn ***'
+	do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_caldyn(i)
+        enddo
+        
+!	write (unit_number,*) '*** Bandes vanleer ***' 
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_vanleer(i)
+        enddo
+       
+!        write (unit_number,*) '*** Bandes dissip ***'
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_dissip(i)
+        enddo
+        
+	do i=0,mpi_size-1
+          write (unit_number,*) i,distrib_phys(i)
+        enddo
+	
+        CLOSE(unit_number)   
+      else 
+        print *,'probleme lors de l ecriture des bandes'
+      endif
+       
+    end subroutine WriteBands
+  
+  end module Bands
+  
+  
Index: LMDZ5/trunk/libf/bernoui.F
===================================================================
--- LMDZ5/trunk/libf/bernoui.F	(revision 1630)
+++ LMDZ5/trunk/libf/bernoui.F	(revision 1630)
@@ -0,0 +1,58 @@
+!
+! $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"
+#include "logic.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 4 ijl = 1,ngrid*nlay
+         pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
+   4  CONTINUE
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+      CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      RETURN
+      END
Index: LMDZ5/trunk/libf/bernoui_loc.F
===================================================================
--- LMDZ5/trunk/libf/bernoui_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/bernoui_loc.F	(revision 1630)
@@ -0,0 +1,77 @@
+      SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
+      USE parallel
+      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"
+#include "logic.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 4 ij = ijb,ije
+          pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
+   4    CONTINUE
+       
+       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: LMDZ5/trunk/libf/bilan_dyn_loc.F
===================================================================
--- LMDZ5/trunk/libf/bilan_dyn_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/bilan_dyn_loc.F	(revision 1630)
@@ -0,0 +1,839 @@
+!
+! $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 * ...
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE parallel
+      USE mod_hallo
+      use misc_mod
+      use write_field
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.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 fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      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) :: 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(jjb_v:jje_v))
+      ALLOCATE(rlatg(jjb_v:jje_v))
+      
+!$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).gt.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
+           stop
+        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(jjb:jje), 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.eq.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.EQ.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.
+          flux_v_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,:)=masse_cum(:,jjb:jje,:)+masse(:,jjb:jje,:)
+        flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:)
+     .                         +flux_u(:,jjb:jje,:)
+      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,:)=flux_v_cum(:,jjb:jje,:)
+     .                          +flux_v(:,jjb:jje,:)
+      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,:,iQ)=Q_cum(:,jjb:jje,:,iQ)
+     .                       +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:)
+        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,1,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 END DO NOWAIT
+      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.eq.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 
+          
+      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 
+
+      call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
+      do iQ=1,nQ
+        call Register_Hallo_u(Q_cum(1,1,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 
+
+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.eq.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=====================================================================
+
+      return
+      end
Index: LMDZ5/trunk/libf/bilan_dyn_p.F
===================================================================
--- LMDZ5/trunk/libf/bilan_dyn_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/bilan_dyn_p.F	(revision 1630)
@@ -0,0 +1,717 @@
+!
+! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE bilan_dyn_p (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 * ...
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE parallel
+      USE mod_hallo
+      use misc_mod
+      use write_field
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.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,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+      real flux_u(iip1,jjp1,llm)
+      real flux_v(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+      real phi(iip1,jjp1,llm)
+      real ucov(iip1,jjp1,llm)
+      real vcov(iip1,jjm,llm)
+      real trac(iip1,jjp1,llm,ntrac)
+
+c   Local :
+c   =======
+
+      integer icum,ncum
+      logical first
+      real zz,zqy,zfactv(jjm,llm)
+
+      integer nQ
+      parameter (nQ=7)
+
+
+cym      character*6 nom(nQ)
+cym      character*6 unites(nQ)
+      character*6,save :: nom(nQ)
+      character*6,save :: unites(nQ)
+
+      character*10 file
+      integer ifile
+      parameter (ifile=4)
+
+      integer itemp,igeop,iecin,iang,iu,iovap,iun
+      integer i_sortie
+
+      save first,icum,ncum
+      save itemp,igeop,iecin,iang,iu,iovap,iun
+      save i_sortie
+
+      real time
+      integer itau
+      save time,itau
+      data time,itau/0.,0/
+
+      data first/.true./
+      data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
+      data i_sortie/1/
+
+      real ww
+
+c   variables dynamiques intermédiaires
+      REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+      REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL vorpot(iip1,jjm,llm)
+      REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
+      REAL bern(iip1,jjp1,llm)
+
+c   champ contenant les scalaires advectés.
+      real Q(iip1,jjp1,llm,nQ)
+    
+c   champs cumulés
+      real ps_cum(iip1,jjp1)
+      real masse_cum(iip1,jjp1,llm)
+      real flux_u_cum(iip1,jjp1,llm)
+      real flux_v_cum(iip1,jjm,llm)
+      real Q_cum(iip1,jjp1,llm,nQ)
+      real flux_uQ_cum(iip1,jjp1,llm,nQ)
+      real flux_vQ_cum(iip1,jjm,llm,nQ)
+      real flux_wQ_cum(iip1,jjp1,llm,nQ)
+      real dQ(iip1,jjp1,llm,nQ)
+
+      save ps_cum,masse_cum,flux_u_cum,flux_v_cum
+      save Q_cum,flux_uQ_cum,flux_vQ_cum
+
+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 iave,itot,immc,itrs,istn
+      data iave,itot,immc,itrs,istn/1,2,3,4,5/
+      character*3 ctrs(ntr)
+      data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+      real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+      real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+      real zmasse(jjm,llm),zamasse(jjm)
+
+      real zv(jjm,llm),psi(jjm,llm+1)
+
+      integer i,j,l,iQ
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      character*10 infile
+
+      integer fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      integer ndex3d(jjm*llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer ii,jj
+      integer zan, dayref
+C
+      real rlong(jjm),rlatg(jjm)
+      integer :: jjb,jje,jjn,ijb,ije
+      type(Request) :: 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=====================================================================
+      ndex3d=0
+      if (adjust) return
+      
+      time=time+dt_app
+      itau=itau+1
+
+      if (first) then
+
+
+        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).gt.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
+           stop
+        endif
+
+        if (i_sortie.eq.1) then
+	 file='dynzon'
+         if (mpi_rank==0) then
+	 call inigrads(ifile,1
+     s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dt_cum,file,'dyn_zon ')
+         endif
+        endif
+
+        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(jjb:jje), 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.eq.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)
+
+
+      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(ucov,ip1jmp1,llm,1,1,1,1,Req)
+      call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Req)
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      CALL covcont_p(llm,ucov,vcov,ucont,vcont)
+      CALL enercin_p(vcov,ucov,vcont,ucont,ecin)
+
+c   moment cinétique
+      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
+
+      Q(:,jjb:jje,:,itemp)=teta(:,jjb:jje,:)*pk(:,jjb:jje,:)/cpp
+      Q(:,jjb:jje,:,igeop)=phi(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iecin)=ecin(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iang)=ang(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iu)=unat(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iovap)=trac(:,jjb:jje,:,1)
+      Q(:,jjb:jje,:,iun)=1.
+
+
+c=====================================================================
+c   Cumul
+c=====================================================================
+c
+      if(icum.EQ.0) then
+         jjb=jj_begin
+         jje=jj_end
+
+         ps_cum(:,jjb:jje)=0.
+         masse_cum(:,jjb:jje,:)=0.
+         flux_u_cum(:,jjb:jje,:)=0.
+         Q_cum(:,jjb:jje,:,:)=0.
+         flux_uQ_cum(:,jjb:jje,:,:)=0.
+         flux_v_cum(:,jjb:jje,:)=0.
+         if (pole_sud) jje=jj_end-1
+         flux_v_cum(:,jjb:jje,:)=0.
+         flux_vQ_cum(:,jjb:jje,:,:)=0.
+      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
+
+      ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
+      masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)+masse(:,jjb:jje,:)
+      flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:)
+     .                       +flux_u(:,jjb:jje,:)
+      if (pole_sud) jje=jj_end-1
+      flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:)
+     .                         +flux_v(:,jjb:jje,:)
+
+      jjb=jj_begin
+      jje=jj_end
+
+      do iQ=1,nQ
+        Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ)
+     .                       +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:)
+      enddo
+
+c=====================================================================
+c  FLUX ET TENDANCES
+c=====================================================================
+
+c   Flux longitudinal
+c   -----------------
+      do iQ=1,nQ
+         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
+      enddo
+
+c    flux méridien
+c    -------------
+      do iQ=1,nQ
+        call Register_Hallo(Q(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req)
+      enddo
+      call SendRequest(Req)
+      call WaitRequest(Req)
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      
+      do iQ=1,nQ
+         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
+      enddo
+
+
+c    tendances
+c    ---------
+
+c   convergence horizontale
+      call Register_Hallo(flux_uQ_cum,ip1jmp1,llm,2,2,2,2,Req)
+      call Register_Hallo(flux_vQ_cum,ip1jm,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      call  convflu_p(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+c   calcul de la vitesse verticale
+      call Register_Hallo(flux_u_cum,ip1jmp1,llm,2,2,2,2,Req)
+      call Register_Hallo(flux_v_cum,ip1jm,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      call convmas_p(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert_p(convm,w)
+
+      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
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+c=====================================================================
+c   PAS DE TEMPS D'ECRITURE
+c=====================================================================
+      if (icum.eq.ncum) then
+c=====================================================================
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Pas d ecriture'
+
+c   Normalisation
+      do iQ=1,nQ
+         Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ)
+     .	                      /masse_cum(:,jjb:jje,:)
+      enddo
+      zz=1./REAL(ncum)
+
+      jjb=jj_begin
+      jje=jj_end
+
+      ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
+      masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)*zz
+      flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:)*zz
+      flux_uQ_cum(:,jjb:jje,:,:)=flux_uQ_cum(:,jjb:jje,:,:)*zz
+      dQ(:,jjb:jje,:,:)=dQ(:,jjb:jje,:,:)*zz
+      
+      IF (pole_sud) jje=jj_end-1
+      flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:)*zz
+      flux_vQ_cum(:,jjb:jje,:,:)=flux_vQ_cum(:,jjb:jje,:,:)*zz
+
+      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
+         dQ(:,jjb:jje,:,iQ)=dQ(:,jjb:jje,:,iQ)/masse_cum(:,jjb:jje,:)
+      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
+
+      zv(jjb:jje,:)=0.
+      zmasse(jjb:jje,:)=0.
+
+      call Register_Hallo(masse_cum,ip1jmp1,llm,1,1,1,1,Req)
+      do iQ=1,nQ
+        call Register_Hallo(Q_cum(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req)
+      enddo
+
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      call massbar_p(masse_cum,massebx,masseby)
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      
+      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
+
+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
+         zvQtmp=0.
+         do l=1,llm
+            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
+c   fonction de courant meridienne pour la quantite Q
+         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
+      enddo
+
+c   fonction de courant pour la circulation meridienne moyenne
+      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
+
+c     print*,'4OK'
+c   sorties proprement dites
+      if (i_sortie.eq.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
+
+c     on doit pouvoir tracer systematiquement la fonction de courant.
+
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+
+      return
+      end
Index: LMDZ5/trunk/libf/caladvtrac_loc.F
===================================================================
--- LMDZ5/trunk/libf/caladvtrac_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/caladvtrac_loc.F	(revision 1630)
@@ -0,0 +1,211 @@
+!
+! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+            SUBROUTINE caladvtrac_loc(q,pbaru,pbarv ,
+     *                   p ,masse, dq ,  teta,
+     *                   flxw, pk, iapptrac)
+      USE parallel 
+      USE infotrac
+      USE control_mod
+      USE caladvtrac_mod
+      USE mod_hallo
+      USE bands
+      USE times
+      USE Vampir
+      USE write_field_loc
+c
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron  
+c
+c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+c=======================================================================
+c
+c       Shema de  Van Leer
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+c   Arguments:
+c   ----------
+      REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+      REAL :: masse(ijb_u:ije_u,llm)
+      REAL :: p( ijb_u:ije_u,llmp1)
+      REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm,2 )
+      REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm)
+      REAL :: flxw(ijb_u:ije_u,llm)
+      INTEGER :: iapptrac
+c   Local:
+c   ------
+!      REAL :: pbarug(ijb_u:ije_u,llm)
+!      REAL :: pbarvg(ijb_v:ije_v,llm)
+!      REAL :: wg(ijb_u:ije_u,llm)
+      
+      REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm)
+      INTEGER,SAVE :: iadvtr=0
+!$OMP THREADPRIVATE(iadvtr)
+      INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
+      INTEGER :: ij,l
+      TYPE(Request) :: Request_vanleer
+
+
+           
+      ijbu=ij_begin
+      ijeu=ij_end
+      
+      ijbv=ij_begin-iip1
+      ijev=ij_end
+      if (pole_nord) ijbv=ij_begin
+      if (pole_sud)  ijev=ij_end-iip1
+
+      IF(iadvtr.EQ.0) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+	DO l=1,llm   
+          pbaruc(ijbu:ijeu,l)=0.
+          pbarvc(ijbv:ijev,l)=0.
+        ENDDO
+c$OMP END DO NOWAIT  
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij = ijbu,ijeu
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+         ENDDO
+         DO ij = ijbv,ijev
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+
+          ijb=ij_begin
+          ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,llm
+          massem(ijb:ije,l)=masse(ijb:ije,l)
+       ENDDO
+c$OMP END DO NOWAIT
+
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+c$OMP MASTER
+      iapptrac = iadvtr
+c$OMP END MASTER
+
+c   Test pour savoir si on advecte a ce pas de temps
+
+      IF ( iadvtr.EQ.iapp_tracvl ) THEN
+c$OMP MASTER
+        call suspend_timer(timer_caldyn)
+c$OMP END MASTER
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
+cc
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+        pbarvg(:,:)=-1
+        pbarvg_adv(:,:)=-2
+        CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+        flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/REAL(iapp_tracvl)
+
+#ifdef DEBUG_IO    
+         CALL WriteField_u('pbarug1',pbarug)
+         CALL WriteField_v('pbarvg1',pbarvg)
+         CALL WriteField_u('wg1',wg)
+#endif
+
+c$OMP BARRIER
+
+
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer,
+     &                          Request_vanleer)
+      call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer,
+     &                          Request_vanleer,up=1)
+      call Register_SwapField_u(massem,massem_adv, distrib_vanleer,
+     &                          Request_vanleer)
+      call Register_SwapField_u(wg,wg_adv,distrib_vanleer,
+     &                          Request_vanleer)
+      call Register_SwapField_u(teta,teta_adv, distrib_vanleer,
+     &                          Request_vanleer,up=1,down=1)
+      call Register_SwapField_u(p,p_adv, distrib_vanleer,
+     &                          Request_vanleer,up=1,down=1)
+      call Register_SwapField_u(pk,pk_adv, distrib_vanleer,
+     &                          Request_vanleer,up=1,down=1)
+      call Register_SwapField_u(q,q_adv, distrib_vanleer,
+     &                          Request_vanleer)
+
+      call SendRequest(Request_vanleer)
+c$OMP BARRIER
+      call WaitRequest(Request_vanleer)
+
+
+c$OMP BARRIER
+c$OMP MASTER      
+      call Set_Distrib(distrib_vanleer)
+      call VTe(VTHallo)
+      call VTb(VTadvection)
+      call start_timer(timer_vanleer)
+c$OMP END MASTER
+c$OMP BARRIER
+!      CALL WriteField_u('pbarug_adv',pbarug_adv)
+!      CALL WriteField_u('',)
+      
+      
+#ifdef DEBUG_IO
+         CALL WriteField_u('pbarug1',pbarug_adv)
+         CALL WriteField_v('pbarvg1',pbarvg_adv)
+         CALL WriteField_u('wg1',wg_adv)
+#endif        
+      CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, 
+     *             p_adv,  massem_adv,q_adv, teta_adv,
+     .             pk_adv)
+
+
+c$OMP MASTER
+	call VTe(VTadvection)
+        call stop_timer(timer_vanleer)
+        call VTb(VThallo)
+c$OMP END MASTER
+
+        call Register_SwapField_u(q_adv,q,distrib_caldyn,
+     *                             Request_vanleer)
+
+        call SendRequest(Request_vanleer)
+c$OMP BARRIER
+        call WaitRequest(Request_vanleer)      
+
+c$OMP BARRIER
+c$OMP MASTER
+        call Set_Distrib(distrib_caldyn)
+	call VTe(VThallo)
+	call resume_timer(timer_caldyn)
+c$OMP END MASTER
+c$OMP BARRIER	
+          iadvtr=0
+       ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+      END
+
+
Index: LMDZ5/trunk/libf/caladvtrac_mod.F90
===================================================================
--- LMDZ5/trunk/libf/caladvtrac_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/caladvtrac_mod.F90	(revision 1630)
@@ -0,0 +1,96 @@
+MODULE caladvtrac_mod
+
+  REAL,POINTER,SAVE :: q_adv(:,:,:)
+  REAL,POINTER,SAVE :: massem_adv(:,:)
+  REAL,POINTER,SAVE :: wg_adv(:,:)
+  REAL,POINTER,SAVE :: teta_adv(:,:)
+  REAL,POINTER,SAVE :: p_adv(:,:)
+  REAL,POINTER,SAVE :: pk_adv(:,:)
+  REAL,POINTER,SAVE :: pbarug_adv(:,:)
+  REAL,POINTER,SAVE :: pbarvg_adv(:,:)
+  REAL,POINTER,SAVE :: pbaruc(:,:)
+  REAL,POINTER,SAVE :: pbarvc(:,:)
+  REAL,POINTER,SAVE :: pbarug(:,:)
+  REAL,POINTER,SAVE :: pbarvg(:,:)
+  REAL,POINTER,SAVE :: wg(:,:)
+
+  REAL,POINTER,SAVE :: massem(:,:)
+  
+CONTAINS
+
+  SUBROUTINE caladvtrac_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE infotrac
+  USE advtrac_mod, ONLY : advtrac_allocate
+  USE groupe_mod 
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+
+    d=>distrib_vanleer
+    CALL allocate_u(q_adv,llm,nqtot,d)
+    CALL allocate_u(massem_adv,llm,d)
+    CALL allocate_u(wg_adv,llm,d)
+    CALL allocate_u(teta_adv,llm,d)
+    CALL allocate_u(p_adv,llmp1,d)
+    CALL allocate_u(pk_adv,llm,d)
+    CALL allocate_u(pbarug_adv,llm,d)
+    CALL allocate_v(pbarvg_adv,llm,d)
+
+    d=>distrib_caldyn
+    CALL allocate_u(massem,llm,d)
+    CALL allocate_u(pbaruc,llm,d)
+    CALL allocate_v(pbarvc,llm,d)
+    CALL allocate_u(pbarug,llm,d)
+    CALL allocate_v(pbarvg,llm,d)
+    CALL allocate_u(wg,llm,d)
+
+    CALL groupe_allocate
+    CALL advtrac_allocate
+    
+  END SUBROUTINE caladvtrac_allocate
+  
+  SUBROUTINE caladvtrac_switch_caldyn(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE groupe_mod
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(massem,distrib_caldyn,dist)
+    CALL switch_u(pbaruc,distrib_caldyn,dist)
+    CALL switch_v(pbarvc,distrib_caldyn,dist,up=1)
+    CALL switch_u(pbarug,distrib_caldyn,dist)
+    CALL switch_v(pbarvg,distrib_caldyn,dist)
+    CALL switch_u(wg,distrib_caldyn,dist)
+    
+    CALL groupe_switch_caldyn(dist)
+
+  END SUBROUTINE caladvtrac_switch_caldyn
+  
+  SUBROUTINE caladvtrac_switch_vanleer(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE advtrac_mod, ONLY : advtrac_switch_vanleer 
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(q_adv,distrib_vanleer,dist)
+    CALL switch_u(massem_adv,distrib_vanleer,dist)
+    CALL switch_u(wg_adv,distrib_vanleer,dist)
+    CALL switch_u(teta_adv,distrib_vanleer,dist)
+    CALL switch_u(p_adv,distrib_vanleer,dist)
+    CALL switch_u(pk_adv,distrib_vanleer,dist)
+    CALL switch_u(pbarug_adv,distrib_vanleer,dist)
+    CALL switch_v(pbarvg_adv,distrib_vanleer,dist)
+
+    CALL advtrac_switch_vanleer(dist)
+    
+  END SUBROUTINE caladvtrac_switch_vanleer  
+  
+END MODULE caladvtrac_mod  
Index: LMDZ5/trunk/libf/caldyn0.F
===================================================================
--- LMDZ5/trunk/libf/caldyn0.F	(revision 1630)
+++ LMDZ5/trunk/libf/caldyn0.F	(revision 1630)
@@ -0,0 +1,89 @@
+!
+! $Header$
+!
+      SUBROUTINE caldyn0
+     $ (itau,ucov,vcov,teta,ps,masse,pk,phis ,
+     $  phi,w,pbaru,pbarv,time )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL pk(iip1,jjp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
+      REAL vorpot(ip1jm,llm)
+      REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+      REAL massebxy(ip1jm,llm), dp(ip1jmp1)
+    
+
+      INTEGER   ij,l
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+      CALL psextbar (   ps   , psexbarxy                            )
+      CALL massdair (    p   , masse                                )
+      CALL massbar  (   masse, massebx , masseby                    )
+      CALL massbarxy(   masse, massebxy                             )
+      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      CALL convmas  (   pbaru, pbarv   , convm                      )
+
+      DO ij =1, ip1jmp1
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+
+      CALL vitvert ( convm  , w                                  )
+      CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+         ENDDO
+      ENDDO
+
+        CALL sortvarc0
+     $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/caldyn_loc.F
===================================================================
--- LMDZ5/trunk/libf/caldyn_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/caldyn_loc.F	(revision 1630)
@@ -0,0 +1,162 @@
+!
+! $Header$
+!
+c
+c
+#undef DEBUG_IO
+!#define DEBUG_IO
+
+      SUBROUTINE caldyn_loc
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+      USE parallel
+      USE Write_Field_loc
+      USE caldyn_mod
+      
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      LOGICAL conser
+
+      INTEGER itau
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+      REAL teta(ijb_u:ije_u,llm)
+      REAL ps(ijb_u:ije_u),phis(ijb_u:ije_u)
+      REAL pk(iip1,jjb_u:jje_u,llm),pkf(ijb_u:ije_u,llm)
+      REAL phi(ijb_u:ije_u,llm),masse(ijb_u:ije_u,llm)
+      REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
+      REAL dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u)
+      REAL w(ijb_u:ije_u,llm)
+      REAL pbaru(ijb_u:ije_u,llm),pbarv(ijb_v:ije_v,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      INTEGER   ij,l,ijb,ije,ierr
+
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+      CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
+      CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
+cym      CALL psextbar (   ps   , psexbarxy                          )
+c$OMP BARRIER
+      CALL massdair_loc (    p   , masse                             )
+      CALL massbar_loc  (   masse, massebx , masseby                 )
+      call massbarxy_loc(   masse, massebxy                          )
+      CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
+      CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
+      CALL convmas1_loc  (   pbaru, pbarv   , convm                  )
+c$OMP BARRIER      
+      CALL convmas2_loc  (   convm                      )
+c$OMP BARRIER
+#ifdef DEBUG_IO
+      call WriteField_u('ucont',ucont)
+      call WriteField_v('vcont',vcont)
+      call WriteField_u('p',p)
+      call WriteField_u('masse',masse)
+      call WriteField_u('massebx',massebx)
+      call WriteField_v('masseby',masseby)
+      call WriteField_v('massebxy',massebxy)
+      call WriteField_u('pbaru',pbaru)
+      call WriteField_v('pbarv',pbarv)
+      call WriteField_u('dteta',dteta)
+      call WriteField_u('convm',convm)
+#endif      
+
+c$OMP BARRIER
+c$OMP MASTER
+      ijb=ij_begin
+      ije=ij_end
+            
+      DO ij =ijb, ije
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+      CALL vitvert_loc ( convm  , w                                )
+      CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
+      CALL dudv1_loc   ( vorpot , pbaru , pbarv     , du     , dv  )
+
+#ifdef DEBUG_IO      
+      call WriteField_u('w',w)
+      call WriteField_v('vorpot',vorpot)
+      call WriteField_u('du',du)
+      call WriteField_v('dv',dv)
+#endif      
+      CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
+      CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
+      CALL dudv2_loc   ( teta   , pkf   , bern      , du     , dv  )
+
+#ifdef DEBUG_IO
+      call WriteField_u('ecin',ecin)
+      call WriteField_u('bern',bern)
+      call WriteField_u('du',du)
+      call WriteField_v('dv',dv)
+      call WriteField_u('pkf',pkf)
+#endif
+      
+      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,llm
+         DO ij=ijb,ije
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO
+
+      CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) 
+
+C  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi 
+C          probablement. Observe sur le code compile avec pgf90 3.0-1 
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l = 1, llm
+         DO ij = ijb, ije, iip1
+           IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+c         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',  
+c    ,   ' dans caldyn'
+c         PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+          dv(ij+iim,l) = dv(ij,l)
+          endif
+         enddo
+      enddo
+c$OMP END DO NOWAIT      
+
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/caldyn_mod.F90
===================================================================
--- LMDZ5/trunk/libf/caldyn_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/caldyn_mod.F90	(revision 1630)
@@ -0,0 +1,75 @@
+MODULE caldyn_mod
+
+  REAL,POINTER,SAVE :: vcont(:,:)
+  REAL,POINTER,SAVE :: ucont(:,:)
+  REAL,POINTER,SAVE :: ang(:,:)
+  REAL,POINTER,SAVE :: p(:,:)
+  REAL,POINTER,SAVE :: massebx(:,:)
+  REAL,POINTER,SAVE :: masseby(:,:)
+  REAL,POINTER,SAVE :: psexbarxy(:,:)
+  REAL,POINTER,SAVE :: vorpot(:,:)
+  REAL,POINTER,SAVE :: ecin(:,:)
+  REAL,POINTER,SAVE :: bern(:,:)
+  REAL,POINTER,SAVE :: massebxy(:,:)
+  REAL,POINTER,SAVE :: convm(:,:)
+
+
+  
+CONTAINS
+
+  SUBROUTINE caldyn_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  USE advect_new_mod,ONLY : advect_new_allocate
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_v(vcont,llm,d)
+    CALL allocate_u(ucont,llm,d)
+    CALL allocate_u(ang,llm,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(massebx,llm,d)
+    CALL allocate_v(masseby,llm,d)
+    CALL allocate_v(psexbarxy,llm,d)
+    CALL allocate_v(vorpot,llm,d)
+    CALL allocate_u(ecin,llm,d)
+    CALL allocate_u(bern,llm,d)
+    CALL allocate_v(massebxy,llm,d)
+    CALL allocate_u(convm,llm,d)
+    
+    CALL advect_new_allocate
+    
+  END SUBROUTINE caldyn_allocate
+  
+  SUBROUTINE caldyn_switch_caldyn(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE advect_new_mod,ONLY : advect_new_switch_caldyn
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_v(vcont,distrib_caldyn,dist)
+    CALL switch_u(ucont,distrib_caldyn,dist)
+    CALL switch_u(ang,distrib_caldyn,dist)
+    CALL switch_u(p,distrib_caldyn,dist)
+    CALL switch_u(massebx,distrib_caldyn,dist)
+    CALL switch_v(masseby,distrib_caldyn,dist)
+    CALL switch_v(psexbarxy,distrib_caldyn,dist)
+    CALL switch_v(vorpot,distrib_caldyn,dist)
+    CALL switch_u(ecin,distrib_caldyn,dist)
+    CALL switch_u(bern,distrib_caldyn,dist)
+    CALL switch_v(massebxy,distrib_caldyn,dist)
+    CALL switch_u(convm,distrib_caldyn,dist)
+    
+    CALL advect_new_switch_caldyn(dist)
+    
+  END SUBROUTINE caldyn_switch_caldyn
+  
+
+  
+END MODULE caldyn_mod  
Index: LMDZ5/trunk/libf/calfis_loc.F
===================================================================
--- LMDZ5/trunk/libf/calfis_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/calfis_loc.F	(revision 1630)
@@ -0,0 +1,1122 @@
+!
+! $Id: calfis_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+C
+C
+      SUBROUTINE calfis_loc(lafin,
+     $                  jD_cur, jH_cur,
+     $                  pucov,
+     $                  pvcov,
+     $                  pteta,
+     $                  pq,
+     $                  pmasse,
+     $                  pps,
+     $                  pp,
+     $                  ppk,
+     $                  pphis,
+     $                  pphi,
+     $                  pducov,
+     $                  pdvcov,
+     $                  pdteta,
+     $                  pdq,
+     $                  flxw,
+     $                  clesphy0,
+     $                  pdufi,
+     $                  pdvfi,
+     $                  pdhfi,
+     $                  pdqfi,
+     $                  pdpsfi)
+#ifdef CPP_EARTH
+! Ehouarn: For now, calfis_p needs Earth physics
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+      USE dimphy
+      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
+      USE parallel, ONLY : omp_chunk, using_mpi,jjb_u,jje_u,jjb_v,jje_v
+      USE mod_interface_dyn_phys
+      USE Write_Field
+      Use Write_field_p
+      USE Times
+      USE IOPHY
+      USE infotrac
+      USE control_mod
+
+      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       ecritphy        frequence d'ecriture (en jours)de histphy
+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"
+#include "temps.h"
+
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+c    Arguments :
+c    -----------
+      LOGICAL  lafin
+      REAL heure
+
+      REAL pvcov(iip1,jjb_v:jje_v,llm)
+      REAL pucov(iip1,jjb_u:jje_u,llm)
+      REAL pteta(iip1,jjb_u:jje_u,llm)
+      REAL pmasse(iip1,jjb_u:jje_u,llm)
+      REAL pq(iip1,jjb_u:jje_u,llm,nqtot)
+      REAL pphis(iip1,jjb_u:jje_u)
+      REAL pphi(iip1,jjb_u:jje_u,llm)
+c
+      REAL pdvcov(iip1,jjb_v:jje_v,llm)
+      REAL pducov(iip1,jjb_u:jje_u,llm)
+      REAL pdteta(iip1,jjb_u:jje_u,llm)
+      REAL pdq(iip1,jjb_u:jje_u,llm,nqtot)
+c
+      REAL pps(iip1,jjb_u:jje_u)
+      REAL pp(iip1,jjb_u:jje_u,llmp1)
+      REAL ppk(iip1,jjb_u:jje_u,llm)
+c
+      REAL pdvfi(iip1,jjb_v:jje_v,llm)
+      REAL pdufi(iip1,jjb_u:jje_u,llm)
+      REAL pdhfi(iip1,jjb_u:jje_u,llm)
+      REAL pdqfi(iip1,jjb_u:jje_u,llm,nqtot)
+      REAL pdpsfi(iip1,jjb_u:jje_u)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq,iiq
+      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
+      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
+c
+      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
+      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
+
+c
+      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
+      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
+      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) 
+      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
+
+c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
+c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
+c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
+c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp)       
+
+      LOGICAL,SAVE :: first_omp=.true.
+c$OMP THREADPRIVATE(first_omp)
+      
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+c
+cIM diagnostique PVteta, Amip2
+      INTEGER ntetaSTD
+      PARAMETER(ntetaSTD=3)
+      REAL rtetaSTD(ntetaSTD)
+      DATA rtetaSTD/350., 380., 405./
+      REAL PVteta(klon,ntetaSTD)
+      
+      REAL flxw(iip1,jjb_u:jje_u,llm)  ! Flux de masse verticale sur la grille dynamique
+      
+      REAL SSUM
+
+      LOGICAL firstcal, debut
+      DATA firstcal/.true./
+      SAVE firstcal,debut
+c$OMP THREADPRIVATE(firstcal,debut)
+      REAL, intent(in):: jD_cur, jH_cur
+      
+      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
+      INTEGER :: ierr
+#ifdef CPP_MPI
+      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
+#else
+      INTEGER,dimension(1,4) :: Status
+#endif
+      INTEGER, dimension(4) :: Req
+      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
+      integer :: k,kstart,kend
+      INTEGER :: offset  
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+      klon=klon_mpi
+      
+      PVteta(:,:)=0.
+            
+c
+      IF ( firstcal )  THEN
+        debut = .TRUE.
+        IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         PRINT*,'STOP dans calfis'
+         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         PRINT*,'  ngridmx  jjm   iim   '
+         PRINT*,ngridmx,jjm,iim
+         STOP
+        ENDIF
+c$OMP MASTER
+      ALLOCATE(zpsrf(klon))
+      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
+      ALLOCATE(zphi(klon,llm),zphis(klon))
+      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
+      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
+      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
+      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
+      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
+      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
+      ALLOCATE(zdpsrf(klon))
+      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
+      ALLOCATE(flxwfi(klon,llm))
+c$OMP END MASTER
+c$OMP BARRIER	  
+      ELSE
+          debut = .FALSE.
+      ENDIF
+
+c
+c
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+
+c$OMP MASTER
+      call start_timer(timer_physic)
+c$OMP END MASTER
+
+c$OMP MASTER             
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+      do ig0=1,klon
+        i=index_i(ig0)
+        j=index_j(ig0)
+        zpsrf(ig0)=pps(i,j)
+      enddo
+c$OMP END MASTER
+
+
+c   42. pression intercouches :
+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
+c      print *,omp_rank,'klon--->',klon
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llmp1
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zplev( ig0,l ) = pp(i,j,l)
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pksurcp        = ppk(i,j,l) / cpp
+          zplay(ig0,l)   = preff * pksurcp ** unskap
+          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
+        enddo
+
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   43.bis traceurs
+c   ---------------
+c
+
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zphi(ig0,l)  = pphi(i,j,l)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT	 
+
+c      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
+
+c$OMP MASTER
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zphis(ig0)  = pphis(i,j)
+           enddo
+c$OMP END MASTER
+
+
+c      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
+
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+	 DO ig=1,klon
+	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
+	 ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+
+c
+c   45. champ u:
+c   ------------
+
+      kstart=1
+      kend=klon
+      
+      if (is_north_pole) kstart=2
+      if (is_south_pole) kend=klon-1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!CDIR SPARSE
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          if (i==1) then
+            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
+     $                         + pucov(1,j,l)/cu(1,j) )
+          else
+            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j) 
+     $                       + pucov(i,j,l)/cu(i,j) )
+          endif
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   46.champ v:
+c   -----------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        DO ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1) 
+     $                       + pvcov(i,j,l)/cv(i,j) )
+    
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+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 ]
+
+      if (is_north_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+
+           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+           DO i=2,iim
+              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+           ENDDO
+  
+           DO i=1,iim
+              zcos(i)   = COS(rlonv(i))*z1(i)
+              zsin(i)   = SIN(rlonv(i))*z1(i)
+           ENDDO
+  
+           zufi(1,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+  
+        ENDDO
+c$OMP END DO NOWAIT      
+      endif
+
+
+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 ]
+
+      if (is_south_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+  
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+           DO i=2,iim
+             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+	   ENDDO
+  
+           DO i=1,iim
+              zcos(i)    = COS(rlonv(i))*z1(i)
+              zsin(i)    = SIN(rlonv(i))*z1(i)
+	   ENDDO
+  
+           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
+        ENDDO
+c$OMP END DO NOWAIT       
+      endif
+
+
+      IF (is_sequential) THEN
+c
+cIM calcul PV a teta=350, 380, 405K
+        CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
+     $           ztfi,zplay,zplev,
+     $           ntetaSTD,rtetaSTD,PVteta)
+c
+      ENDIF
+
+c On change de grille, dynamique vers physiq, pour le flux de masse verticale
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             flxwfi(ig0,l)  = flxw(i,j,l)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT
+
+c      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+
+c$OMP BARRIER
+      if (first_omp) then
+        klon=klon_omp
+
+        allocate(zplev_omp(klon,llm+1))
+        allocate(zplay_omp(klon,llm))
+        allocate(zphi_omp(klon,llm))
+        allocate(zphis_omp(klon))
+        allocate(presnivs_omp(llm))
+        allocate(zufi_omp(klon,llm))
+        allocate(zvfi_omp(klon,llm))
+        allocate(ztfi_omp(klon,llm))
+        allocate(zqfi_omp(klon,llm,nqtot))
+        allocate(zdufi_omp(klon,llm))
+        allocate(zdvfi_omp(klon,llm))
+        allocate(zdtfi_omp(klon,llm))
+        allocate(zdqfi_omp(klon,llm,nqtot))
+        allocate(zdpsrf_omp(klon))
+        allocate(flxwfi_omp(klon,llm))
+	first_omp=.false.
+      endif
+       
+	   
+      klon=klon_omp
+      offset=klon_omp_begin-1
+      
+      do l=1,llm+1
+        do i=1,klon
+          zplev_omp(i,l)=zplev(offset+i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay_omp(i,l)=zplay(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi_omp(i,l)=zphi(offset+i,l)
+	enddo 
+      enddo
+	
+      do i=1,klon
+	zphis_omp(i)=zphis(offset+i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs_omp(l)=presnivs(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi_omp(i,l)=zufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi_omp(i,l)=zvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi_omp(i,l)=ztfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi_omp(i,l)=zdufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi_omp(i,l)=zdvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi_omp(i,l)=zdtfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf_omp(i)=zdpsrf(offset+i)
+      enddo 
+
+      do l=1,llm
+        do i=1,klon
+          flxwfi_omp(i,l)=flxwfi(offset+i,l)
+	enddo 
+      enddo
+      
+c$OMP BARRIER
+      
+      if (planet_type=="earth") then
+#ifdef CPP_EARTH
+      CALL physiq (klon,
+     .             llm,
+     .             debut,
+     .             lafin,
+     .             jD_cur,
+     .             jH_cur,
+     .             dtphys,
+     .             zplev_omp,
+     .             zplay_omp,
+     .             zphi_omp,
+     .             zphis_omp,
+     .             presnivs_omp,
+     .             clesphy0,
+     .             zufi_omp,
+     .             zvfi_omp,
+     .             ztfi_omp,
+     .             zqfi_omp,
+c#ifdef INCA
+     .             flxwfi_omp,
+c#endif
+     .             zdufi_omp,
+     .             zdvfi_omp,
+     .             zdtfi_omp,
+     .             zdqfi_omp,
+     .             zdpsrf_omp,
+cIM diagnostique PVteta, Amip2          
+     .             pducov,
+     .             PVteta)
+#endif
+      endif !of if (planet_type=="earth")
+c$OMP BARRIER
+
+      do l=1,llm+1
+        do i=1,klon
+          zplev(offset+i,l)=zplev_omp(i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay(offset+i,l)=zplay_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi(offset+i,l)=zphi_omp(i,l)
+	enddo 
+      enddo
+	
+
+      do i=1,klon
+	zphis(offset+i)=zphis_omp(i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs(l)=presnivs_omp(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi(offset+i,l)=zufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi(offset+i,l)=zvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi(offset+i,l)=ztfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi(offset+i,l)=zdufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi(offset+i,l)=zdvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi(offset+i,l)=zdtfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf(offset+i)=zdpsrf_omp(i)
+      enddo 
+      
+
+      klon=klon_mpi
+500   CONTINUE
+c$OMP BARRIER
+
+c$OMP MASTER
+      call stop_timer(timer_physic)
+c$OMP END MASTER
+
+      IF (using_mpi) THEN
+            
+      if (MPI_rank>0) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+       DO l=1,llm      
+        du_send(1:iim,l)=zdufi(1:iim,l)
+        dv_send(1:iim,l)=zdvfi(1:iim,l)
+       ENDDO
+c$OMP END DO NOWAIT       
+
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER
+!$OMP CRITICAL (MPI)
+        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
+     &                   COMM_LMDZ,Req(1),ierr)
+        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
+     &                  COMM_LMDZ,Req(2),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+c$OMP BARRIER
+     
+      endif
+   
+      if (MPI_rank<MPI_Size-1) then
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER      
+!$OMP CRITICAL (MPI)
+        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
+     &                 COMM_LMDZ,Req(3),ierr)
+        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
+     &                 COMM_LMDZ,Req(4),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+      endif
+
+c$OMP BARRIER
+
+
+#ifdef CPP_MPI 
+c$OMP MASTER    
+!$OMP CRITICAL (MPI)
+      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
+        call MPI_WAITALL(4,Req(1),Status,ierr)
+      else if (MPI_rank>0) then
+        call MPI_WAITALL(2,Req(1),Status,ierr)
+      else if (MPI_rank <MPI_Size-1) then
+        call MPI_WAITALL(2,Req(3),Status,ierr)
+      endif
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+
+c$OMP BARRIER     
+
+      ENDIF ! using_mpi
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+            
+        zdufi2(1:klon,l)=zdufi(1:klon,l)
+        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
+            
+        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
+        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l) 
+
+        pdhfi(:,jj_begin,l)=0
+        pdqfi(:,jj_begin,l,:)=0
+        pdufi(:,jj_begin,l)=0
+        pdvfi(:,jj_begin,l)=0
+                
+        if (.not. is_south_pole) then
+          pdhfi(:,jj_end:jj_end+1,l)=0
+          pdqfi(:,jj_end:jj_end+1,l,:)=0
+          pdufi(:,jj_end:jj_end+1,l)=0
+          pdvfi(:,jj_end:jj_end+1,l)=0
+        endif
+      
+       ENDDO 
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+        pdpsfi(:,jj_begin)=0    
+       
+       if (.not. is_south_pole) then
+	 pdpsfi(:,jj_end:jj_end+1)=0
+       endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+c      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
+
+c$OMP MASTER
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1
+
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pdpsfi(i,j) = zdpsrf(ig0)
+          if (i==1) pdpsfi(iip1,j) =  zdpsrf(ig0)
+         enddo          
+
+        if (is_north_pole) then
+            DO i=1,iip1
+              pdpsfi(i,1)    = zdpsrf(1)
+            enddo
+        endif
+        
+        if (is_south_pole) then
+            DO i=1,iip1
+              pdpsfi(i,jjp1) = zdpsrf(klon)
+            ENDDO
+        endif
+c$OMP END MASTER
+cc$OMP BARRIER
+
+c
+c   62. enthalpie potentielle
+c   ---------------------
+      
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
+          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
+         enddo          
+
+        if (is_north_pole) then
+            DO i=1,iip1
+              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+            enddo
+        endif
+        
+        if (is_south_pole) then
+            DO i=1,iip1
+              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
+            ENDDO
+        endif
+      ENDDO
+c$OMP END DO NOWAIT
+      
+c   62. humidite specifique
+c   ---------------------
+! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+!      DO iq=1,nqtot
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!         DO l=1,llm
+!!!cdir NODEP 
+!           do ig0=kstart,kend
+!             i=index_i(ig0)
+!             j=index_j(ig0)
+!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq) 
+!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq) 
+!           enddo
+!           
+!           if (is_north_pole) then
+!             do i=1,iip1
+!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
+!             enddo
+!           endif
+!           
+!           if (is_south_pole) then
+!             do i=1,iip1
+!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq) 
+!             enddo
+!           endif
+!         ENDDO
+!c$OMP END DO NOWAIT
+!      ENDDO
+
+c   63. traceurs
+c   ------------
+C     initialisation des tendances
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        pdqfi(:,jj_begin:jj_end,l,:)=0.
+      ENDDO
+c$OMP END DO NOWAIT	 
+
+C
+!cdir NODEP
+      DO iq=1,nqtot
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP           
+	     DO ig0=kstart,kend
+              i=index_i(ig0)
+              j=index_j(ig0)
+              pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
+              if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
+            ENDDO
+	    
+	    IF (is_north_pole) then
+	      DO i=1,iip1
+                pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+	    IF (is_south_pole) then
+	      DO i=1,iip1
+                pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+      
+c   65. champ u:
+c   ------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+         do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           
+           if (i/=iim) then
+             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+           
+           if (i==1) then
+              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
+     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
+             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+         
+         enddo
+         
+         if (is_north_pole) then
+           DO i=1,iip1
+            pdufi(i,1,l)    = 0.
+           ENDDO
+         endif
+         
+         if (is_south_pole) then
+           DO i=1,iip1
+            pdufi(i,jjp1,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   67. champ v:
+c   ------------
+
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1-iim
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
+           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
+     $	                                    zdvfi2(ig0+iim,l))
+     $				          *cv(i,j)
+        enddo
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      v = U * cos(long) + V * SIN(long)
+
+      if (is_north_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        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,1,l)=
+     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+          ENDDO
+
+          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+
+      endif    
+      
+      if (is_south_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+         DO l=1,llm
+  
+           DO i=1,iim
+              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
+     $        +zdvfi(klon,l)*SIN(rlonv(i))
+
+              pdvfi(i,jjm,l)=
+     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
+           ENDDO
+
+           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+     
+      endif
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+ 
+      firstcal = .FALSE.
+
+#else
+      write(*,*) "calfis_p: for now can only work with parallel physics"
+      stop
+#endif
+! of #ifdef CPP_EARTH
+      RETURN
+      END
Index: LMDZ5/trunk/libf/call_calfis_mod.F90
===================================================================
--- LMDZ5/trunk/libf/call_calfis_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/call_calfis_mod.F90	(revision 1630)
@@ -0,0 +1,388 @@
+!#define DEBUG_IO
+MODULE call_calfis_mod
+
+    REAL,POINTER,SAVE :: ucov(:,:)
+    REAL,POINTER,SAVE :: vcov(:,:) 
+    REAL,POINTER,SAVE :: teta(:,:) 
+    REAL,POINTER,SAVE :: masse(:,:) 
+    REAL,POINTER,SAVE :: ps(:) 
+    REAL,POINTER,SAVE :: phis(:) 
+    REAL,POINTER,SAVE :: q(:,:,:) 
+    REAL,POINTER,SAVE :: flxw(:,:) 
+
+    REAL,POINTER,SAVE :: p(:,:) 
+    REAL,POINTER,SAVE :: alpha(:,:) 
+    REAL,POINTER,SAVE :: beta(:,:) 
+    REAL,POINTER,SAVE :: pks(:) 
+    REAL,POINTER,SAVE :: pk(:,:) 
+    REAL,POINTER,SAVE :: pkf(:,:) 
+    REAL,POINTER,SAVE :: phi(:,:) 
+    REAL,POINTER,SAVE :: du(:,:) 
+    REAL,POINTER,SAVE :: dv(:,:) 
+    REAL,POINTER,SAVE :: dteta(:,:) 
+    REAL,POINTER,SAVE :: dq(:,:,:) 
+    REAL,POINTER,SAVE :: dufi(:,:) 
+    REAL,POINTER,SAVE :: dvfi(:,:) 
+    REAL,POINTER,SAVE :: dtetafi(:,:) 
+    REAL,POINTER,SAVE :: dqfi(:,:,:) 
+    REAL,POINTER,SAVE :: dpfi(:) 
+   
+    
+    
+    
+    
+CONTAINS
+
+  SUBROUTINE call_calfis_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  USE infotrac
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_physic
+
+    CALL allocate_u(ucov,llm,d)
+    CALL allocate_v(vcov,llm,d)
+    CALL allocate_u(teta,llm,d)
+    CALL allocate_u(masse,llm,d)
+    CALL allocate_u(ps,d)
+    CALL allocate_u(phis,d)
+    CALL allocate_u(q,llm,nqtot,d)
+    CALL allocate_u(flxw,llm,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(alpha,llm,d)
+    CALL allocate_u(beta,llm,d)
+    CALL allocate_u(pks,d)
+    CALL allocate_u(pk,llm,d)
+    CALL allocate_u(pkf,llm,d)
+    CALL allocate_u(phi,llm,d)
+    CALL allocate_u(du,llm,d)
+    CALL allocate_v(dv,llm,d)
+    CALL allocate_u(dteta,llm,d)
+    CALL allocate_u(dq,llm,nqtot,d)
+    CALL allocate_u(dufi,llm,d)
+    CALL allocate_v(dvfi,llm,d)
+    CALL allocate_u(dtetafi,llm,d)
+    CALL allocate_u(dqfi,llm,nqtot,d)
+    CALL allocate_u(dpfi,d)
+  
+  END SUBROUTINE call_calfis_allocate
+  
+  
+  SUBROUTINE call_calfis(itau,lafin,clesphy0,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, &
+                         phis_dyn,q_dyn,flxw_dyn)
+  USE dimensions
+  USE parallel
+  USE times
+  USE mod_hallo
+  USE Bands
+  USE vampir
+  USE infotrac
+  USE control_mod
+  USE write_field_loc
+  USE write_field
+  IMPLICIT NONE
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    INCLUDE "logic.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+
+    REAL    :: clesphy0( : )    
+    INTEGER :: itau
+    LOGICAL :: lafin 
+    REAL :: ucov_dyn(ijb_u:ije_u,llm)
+    REAL :: vcov_dyn(ijb_v:ije_v,llm) 
+    REAL :: teta_dyn(ijb_u:ije_u,llm) 
+    REAL :: masse_dyn(ijb_u:ije_u,llm) 
+    REAL :: ps_dyn(ijb_u:ije_u) 
+    REAL :: phis_dyn(ijb_u:ije_u) 
+    REAL :: q_dyn(ijb_u:ije_u,llm,nqtot) 
+    REAL :: flxw_dyn(ijb_u:ije_u,llm) 
+
+    REAL :: dufi_tmp(iip1,llm)    
+    REAL :: dvfi_tmp(iip1,llm)  
+    REAL :: dtetafi_tmp(iip1,llm)
+    REAL :: dpfi_tmp(iip1)
+    REAL :: dqfi_tmp(iip1,llm,nqtot)
+
+    REAL :: jD_cur, jH_cur
+    CHARACTER(LEN=15) :: ztit
+    TYPE(Request) :: Request_physic 
+    INTEGER :: ijb,ije,l,j
+    
+    
+#ifdef DEBUG_IO    
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('pfi',p)
+    CALL WriteField_u('pkfi',pk)
+    DO j=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+    ENDDO
+#endif
+
+!
+!     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+!
+
+
+  !$OMP MASTER
+    CALL suspend_timer(timer_caldyn)
+    WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau
+  !$OMP END MASTER
+   
+    jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) 
+    jH_cur = jH_ref + (itau * dtvr / daysec - int(itau * dtvr / daysec)) 
+
+!   Inbterface avec les routines de phylmd (phymars ... )
+!   -----------------------------------------------------
+
+!+jld
+
+!  Diagnostique de conservation de l'energie : initialisation
+ 
+!-jld
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+
+#ifdef DEBUG_IO    
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('pfi',p)
+    CALL WriteField_u('pkfi',pk)
+#endif
+    
+    CALL SetTag(Request_physic,800)
+    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
+    CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
+ 
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)       
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL Set_Distrib(distrib_Physic)
+    CALL VTe(VThallo)
+        
+    CALL VTb(VTphysiq)
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
+
+  !$OMP BARRIER
+    CALL exner_hyb_loc(  ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+  !$OMP BARRIER
+    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+
+    CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
+    CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
+    CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
+        
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)
+             
+  !$OMP BARRIER
+  
+  
+#ifdef DEBUG_IO    
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('pfi',p)
+    CALL WriteField_u('pkfi',pk)
+    DO j=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+    ENDDO
+#endif
+
+  !$OMP BARRIER
+
+    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
+                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
+                     du,dv,dteta,dq,                             &
+                     flxw,                                       &
+                     clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi  )
+
+    ijb=ij_begin
+    ije=ij_end  
+    IF ( .not. pole_nord) THEN
+  
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l) 
+        dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)  
+        dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)  
+        dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)  
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    !$OMP MASTER
+      dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)  
+    !$OMP END MASTER
+    
+    ENDIF ! of if ( .not. pole_nord)
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL Set_Distrib(distrib_Physic_bis)
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+  !$OMP BARRIER
+ 
+    CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
+    CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
+    CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
+    CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
+
+    DO j=1,nqtot
+      CALL Register_Hallo_u(dqfi(:,:,j),llm,1,0,0,1,Request_physic)
+    ENDDO
+        
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)
+             
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VThallo)
+    CALL Set_Distrib(distrib_Physic)
+  !$OMP END MASTER
+  !$OMP BARRIER        
+    ijb=ij_begin
+    IF (.not. pole_nord) THEN
+        
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+        dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) 
+        dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
+        dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    !$OMP MASTER
+      dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+    !$OMP END MASTER
+          
+    endif ! of if (.not. pole_nord)
+        
+        
+#ifdef DEBUG_IO           
+    CALL WriteField_u('dufi',dufi)
+    CALL WriteField_v('dvfi',dvfi) 
+    CALL WriteField_u('dtetafi',dtetafi)
+    CALL WriteField_u('dpfi',dpfi)
+    DO j=1,nqtot
+      CALL WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
+    ENDDO
+#endif
+
+  !$OMP BARRIER
+
+!      ajout des tendances physiques:
+!      ------------------------------
+#ifdef DEBUG_IO    
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('psfi',ps)
+    DO j=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+    ENDDO
+#endif
+
+    IF (ok_strato) THEN
+      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
+    ENDIF
+
+#ifdef DEBUG_IO           
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('psfi',ps)
+    DO j=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+    ENDDO
+#endif
+
+    CALL addfi_loc( dtphys, leapf, forward   ,              &
+                    ucov, vcov, teta , q   ,ps ,            &
+                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
+
+#ifdef DEBUG_IO    
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('psfi',ps)
+    DO j=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+    ENDDO
+#endif
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VTphysiq)
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+
+    CALL SetTag(Request_physic,800)
+    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)     
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VThallo)
+    CALL set_distrib(distrib_caldyn)
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+!
+!  Diagnostique de conservation de l'energie : difference
+    IF (ip_ebil_dyn.ge.1 ) THEN 
+      ztit='bil phys'
+      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+    ENDIF 
+
+#ifdef DEBUG_IO    
+    CALL WriteField_u('ucovfi',ucov_dyn)
+    CALL WriteField_v('vcovfi',vcov_dyn)
+    CALL WriteField_u('tetafi',teta_dyn)
+    CALL WriteField_u('psfi',ps_dyn)
+    DO j=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(j)),q_dyn(:,:,j))
+    ENDDO
+#endif
+
+
+!-jld
+    !$OMP MASTER
+      CALL resume_timer(timer_caldyn)
+    !$OMP END MASTER
+
+  END SUBROUTINE call_calfis
+  
+END MODULE call_calfis_mod
Index: LMDZ5/trunk/libf/call_dissip_mod.F90
===================================================================
--- LMDZ5/trunk/libf/call_dissip_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/call_dissip_mod.F90	(revision 1630)
@@ -0,0 +1,313 @@
+MODULE call_dissip_mod
+
+    REAL,POINTER,SAVE :: ucov(:,:)
+    REAL,POINTER,SAVE :: vcov(:,:)
+    REAL,POINTER,SAVE :: teta(:,:)
+    REAL,POINTER,SAVE :: p(:,: )
+    REAL,POINTER,SAVE :: pk(:,:)
+
+    REAL,POINTER,SAVE :: ucont(:,:)
+    REAL,POINTER,SAVE :: vcont(:,:)
+    REAL,POINTER,SAVE :: ecin(:,:)
+    REAL,POINTER,SAVE :: ecin0(:,:)
+    REAL,POINTER,SAVE :: dudis(:,:)
+    REAL,POINTER,SAVE :: dvdis(:,:)
+    REAL,POINTER,SAVE :: dtetadis(:,:)
+    REAL,POINTER,SAVE :: dtetaecdt(:,:)
+
+
+
+CONTAINS
+  
+  SUBROUTINE call_dissip_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  USE dissip_mod, ONLY : dissip_allocate
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(ucov,llm,d)
+    CALL allocate_v(vcov,llm,d)
+    CALL allocate_u(teta,llm,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(pk,llm,d)
+    CALL allocate_u(ucont,llm,d)
+    CALL allocate_v(vcont,llm,d)
+    CALL allocate_u(ecin,llm,d)
+    CALL allocate_u(ecin0,llm,d)
+    CALL allocate_u(dudis,llm,d)
+    CALL allocate_v(dvdis,llm,d)
+    CALL allocate_u(dtetadis,llm,d)
+    CALL allocate_u(dtetaecdt,llm,d)
+    
+    
+    CALL dissip_allocate
+    
+  END SUBROUTINE call_dissip_allocate
+  
+  SUBROUTINE call_dissip_switch_dissip(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE dissip_mod, ONLY : dissip_switch_dissip
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(ucov,distrib_dissip,dist)
+    CALL switch_v(vcov,distrib_dissip,dist)
+    CALL switch_u(teta,distrib_dissip,dist)
+    CALL switch_u(p,distrib_dissip,dist)
+    CALL switch_u(pk,distrib_dissip,dist)
+    CALL switch_u(ucont,distrib_dissip,dist)
+    CALL switch_v(vcont,distrib_dissip,dist)
+    CALL switch_u(ecin,distrib_dissip,dist)
+    CALL switch_u(ecin0,distrib_dissip,dist)
+    CALL switch_u(dudis,distrib_dissip,dist)
+    CALL switch_v(dvdis,distrib_dissip,dist)
+    CALL switch_u(dtetadis,distrib_dissip,dist)
+    CALL switch_u(dtetaecdt,distrib_dissip,dist)
+
+    CALL dissip_switch_dissip(dist)
+    
+  END SUBROUTINE call_dissip_switch_dissip  
+  
+
+  
+  SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn)
+  USE dimensions
+  USE parallel
+  USE times
+  USE mod_hallo
+  USE Bands
+  USE vampir
+  USE write_field_loc
+  IMPLICIT NONE
+    INCLUDE 'comgeom.h'
+    REAL :: ucov_dyn(ijb_u:ije_u,llm)
+    REAL :: vcov_dyn(ijb_v:ije_v,llm)
+    REAL :: teta_dyn(ijb_u:ije_u,llm)
+    REAL :: p_dyn(ijb_u:ije_u,llmp1 )
+    REAL :: pk_dyn(ijb_u:ije_u,llm)
+    REAL :: ps_dyn(ijb_u:ije_u)
+    REAL :: tppn(iim),tpps(iim)
+    REAL :: tpn,tps
+
+    REAL  SSUM
+    LOGICAL,PARAMETER :: dissip_conservative=.TRUE.
+    TYPE(Request) :: Request_dissip 
+    
+    INTEGER :: ij,l,ijb,ije 
+  
+    
+  !$OMP MASTER
+    CALL suspend_timer(timer_caldyn)
+        
+!       print*,'Entree dans la dissipation : Iteration No ',true_itau
+!   calcul de l'energie cinetique avant dissipation
+!       print *,'Passage dans la dissipation'
+
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+
+  !$OMP BARRIER
+
+    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_dissip, Request_dissip,up=1,down=1)
+    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_dissip, Request_dissip,up=1,down=1)
+    CALL Register_SwapField_u(teta_dyn,teta,distrib_dissip, Request_dissip)
+    CALL Register_SwapField_u(p_dyn,p,distrib_dissip,Request_dissip)
+    CALL Register_SwapField_u(pk_dyn,pk,distrib_dissip,Request_dissip)
+
+    CALL SendRequest(Request_dissip)       
+  !$OMP BARRIER
+    CALL WaitRequest(Request_dissip)       
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL set_distrib(distrib_dissip)
+    CALL VTe(VThallo)
+    CALL VTb(VTdissipation)
+    CALL start_timer(timer_dissip)
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+    CALL enercin_loc(vcov,ucov,vcont,ucont,ecin0)
+
+!   dissipation
+
+!        CALL FTRACE_REGION_BEGIN("dissip")
+    CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+
+#ifdef DEBUG_IO    
+    CALL WriteField_u('dudis',dudis)
+    CALL WriteField_v('dvdis',dvdis)
+    CALL WriteField_u('dtetadis',dtetadis)
+#endif
+ 
+!      CALL FTRACE_REGION_END("dissip")
+         
+    ijb=ij_begin
+    ije=ij_end
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+    DO l=1,llm
+      ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+    ENDDO
+  !$OMP END DO NOWAIT        
+
+    IF (pole_sud) ije=ije-iip1
+   
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+    DO l=1,llm
+      vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+    ENDDO
+  !$OMP END DO NOWAIT        
+
+!       teta=teta+dtetadis
+
+
+!------------------------------------------------------------------------
+    IF (dissip_conservative) THEN
+!       On rajoute la tendance due a la transform. Ec -> E therm. cree
+!       lors de la dissipation
+    !$OMP BARRIER
+    !$OMP MASTER
+      CALL suspend_timer(timer_dissip)
+      CALL VTb(VThallo)
+    !$OMP END MASTER
+      CALL Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
+      CALL Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
+      CALL SendRequest(Request_Dissip)
+    !$OMP BARRIER
+      CALL WaitRequest(Request_Dissip)
+    !$OMP MASTER
+      CALL VTe(VThallo)
+      CALL resume_timer(timer_dissip)
+    !$OMP END MASTER
+    !$OMP BARRIER            
+      CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+      CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+            
+      ijb=ij_begin
+      ije=ij_end
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+      DO l=1,llm
+        DO ij=ijb,ije
+           dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+           dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+        ENDDO
+      ENDDO
+    !$OMP END DO NOWAIT            
+
+    ENDIF
+
+    ijb=ij_begin
+    ije=ij_end
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+    DO l=1,llm
+      DO ij=ijb,ije
+         teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+      ENDDO
+    ENDDO
+  !$OMP END DO NOWAIT         
+
+!------------------------------------------------------------------------
+
+
+!    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+!   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+!
+
+    ijb=ij_begin
+    ije=ij_end
+         
+    IF (pole_nord) THEN
+  
+   !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l  =  1, llm
+        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
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    !$OMP MASTER               
+      DO ij =  1,iim
+        tppn(ij)  = aire(  ij    ) * ps_dyn (  ij    )
+      ENDDO
+      tpn  = SSUM(iim,tppn,1)/apoln
+  
+      DO ij = 1, iip1
+        ps_dyn(  ij    ) = tpn
+      ENDDO
+    !$OMP END MASTER
+    
+    ENDIF
+        
+    IF (pole_sud) THEN
+
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l  =  1, llm
+        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
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    !$OMP MASTER               
+      DO ij =  1,iim
+        tpps(ij)  = aire(ij+ip1jm) * ps_dyn (ij+ip1jm)
+      ENDDO
+      tps  = SSUM(iim,tpps,1)/apols
+  
+      DO ij = 1, iip1
+        ps_dyn(ij+ip1jm) = tps
+      ENDDO
+    !$OMP END MASTER
+    ENDIF
+
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VTdissipation)
+    CALL stop_timer(timer_dissip)
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+ 
+    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip)
+
+    CALL SendRequest(Request_dissip)       
+
+  !$OMP BARRIER
+    CALL WaitRequest(Request_dissip)       
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL set_distrib(distrib_caldyn)
+    CALL VTe(VThallo)
+    CALL resume_timer(timer_caldyn)
+!        print *,'fin dissipation'
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  
+  END SUBROUTINE call_dissip
+
+END MODULE call_dissip_mod
Index: LMDZ5/trunk/libf/clesph0.h
===================================================================
--- LMDZ5/trunk/libf/clesph0.h	(revision 1630)
+++ LMDZ5/trunk/libf/clesph0.h	(revision 1630)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+c..include clesph0.h
+c
+       COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr ,
+     ,                ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con
+c
+       LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
Index: LMDZ5/trunk/libf/coefpoly.F
===================================================================
--- LMDZ5/trunk/libf/coefpoly.F	(revision 1630)
+++ LMDZ5/trunk/libf/coefpoly.F	(revision 1630)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 ,
+     ,                                          a0,a1,a2,a3         )
+      IMPLICIT NONE
+c
+c   ...  Auteur :   P. Le Van  ...
+c
+c
+c    Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui
+c      satisfait aux 4 equations  suivantes :
+
+c    a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1
+c    a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2
+c               a1  +     2.*a2*xtild1 +     3.*a3*xtild1*xtild1 = Xprim1
+c               a1  +     2.*a2*xtild2 +     3.*a3*xtild2*xtild2 = Xprim2
+
+c  On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3
+
+      REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi 
+      REAL(KIND=8) Xfout, Xprim
+      REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car
+
+      xtil1car = xtild1 * xtild1
+      xtil2car = xtild2 * xtild2 
+
+      derr= 2. *(Xf2-Xf1)/( xtild1-xtild2)
+
+      x1x2car = ( xtild1-xtild2)*(xtild1-xtild2)
+
+      a3 = (derr + Xprim1+Xprim2 )/x1x2car
+      a2     = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) )    /
+     /           (  2.* ( xtild1 - xtild2 )  )
+
+      a1     = Xprim1 -3.* a3 * xtil1car     -2.* a2 * xtild1
+      a0     =  Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/com_io_dyn.h
===================================================================
--- LMDZ5/trunk/libf/com_io_dyn.h	(revision 1630)
+++ LMDZ5/trunk/libf/com_io_dyn.h	(revision 1630)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      integer histid, histvid, histaveid
+      common/com_io_dyn/histid, histvid, histaveid
Index: LMDZ5/trunk/libf/com_io_dyn_mod.F90
===================================================================
--- LMDZ5/trunk/libf/com_io_dyn_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/com_io_dyn_mod.F90	(revision 1630)
@@ -0,0 +1,31 @@
+!
+! $Id $
+!
+module com_io_dyn_mod
+
+  implicit none 
+
+! Names of various files for outputs (in the dynamics)
+  ! to store instantaneous values:
+  character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid
+  character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid
+  character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid
+
+  ! to store averaged values:
+  character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc"
+  character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc"
+  character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc"
+  
+! Ids of various files for outputs (in the dynamics)
+
+  ! instantaneous (these are set by inithist.F)
+  integer :: histid
+  integer :: histvid
+  integer :: histuid
+  
+  ! averages (these are set by initdynav.F)
+  integer :: histaveid
+  integer :: histvaveid
+  integer :: histuaveid
+  
+end module com_io_dyn_mod
Index: LMDZ5/trunk/libf/comconst.h
===================================================================
--- LMDZ5/trunk/libf/comconst.h	(revision 1630)
+++ LMDZ5/trunk/libf/comconst.h	(revision 1630)
@@ -0,0 +1,23 @@
+!
+! $Id: comconst.h 1279 2009-12-10 09:02:56Z fairhead $
+!
+!-----------------------------------------------------------------------
+! INCLUDE comconst.h
+
+      COMMON/comconst/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl,           &
+     & dtvr,daysec,                                                     &
+     & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg              &
+     &                   ,dissip_factz,dissip_deltaz,dissip_zref        &
+     &                   ,iflag_top_bound,tau_top_bound
+
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr,daysec
+      REAL pi,dtphys,dtdiss,rad,r,cpp,kappa
+      REAL cotot,unsim,g,omeg
+      REAL dissip_factz,dissip_deltaz,dissip_zref
+      INTEGER iflag_top_bound
+      REAL tau_top_bound
+
+
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/comdissip.h
===================================================================
--- LMDZ5/trunk/libf/comdissip.h	(revision 1630)
+++ LMDZ5/trunk/libf/comdissip.h	(revision 1630)
@@ -0,0 +1,15 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE comdissip.h
+
+      COMMON/comdissip/                                                 &
+     &    niterdis,coefdis,tetavel,tetatemp,gamdissip
+
+
+      INTEGER niterdis
+
+      REAL tetavel,tetatemp,coefdis,gamdissip
+
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/comdissipn.h
===================================================================
--- LMDZ5/trunk/libf/comdissipn.h	(revision 1630)
+++ LMDZ5/trunk/libf/comdissipn.h	(revision 1630)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comdissipn.h
+
+      REAL  tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
+c
+      COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm)   ,
+     1                        cdivu,      crot,         cdivh
+
+c
+c    Les parametres de ce common proviennent des calculs effectues dans 
+c             Inidissip  .
+c
+c-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/comdissnew.h
===================================================================
--- LMDZ5/trunk/libf/comdissnew.h	(revision 1630)
+++ LMDZ5/trunk/libf/comdissnew.h	(revision 1630)
@@ -0,0 +1,18 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE comdissnew.h
+
+      COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv,  &
+     &                   tetagrot,tetatemp,coefdis 
+
+      LOGICAL lstardis
+      INTEGER nitergdiv, nitergrot, niterh
+      REAL     tetagdiv, tetagrot,  tetatemp, coefdis
+
+!
+! ... Les parametres de ce common comdissnew sont  lues par defrun_new 
+!              sur le fichier  run.def    ....
+!
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/comgeom.h
===================================================================
--- LMDZ5/trunk/libf/comgeom.h	(revision 1630)
+++ LMDZ5/trunk/libf/comgeom.h	(revision 1630)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+!CDK comgeom
+      COMMON/comgeom/                                                   &
+     & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),             &
+     & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),                  &
+     & airev(ip1jm),unsaire(ip1jmp1),apoln,apols,                       &
+     & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),                 &
+     & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),              &
+     & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),                &
+     & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),               &
+     & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),           &
+     & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),            &
+     & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),         &
+     & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),           &
+     & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),                           &
+     & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),         &
+     & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,                 &
+     & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),    &
+     & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+!
+        REAL                                                            &
+     & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,&
+     & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,&
+     & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,&
+     & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,&
+     & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2&
+     & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,&
+     & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu&
+     & , xprimv
+!
Index: LMDZ5/trunk/libf/comgeom2.h
===================================================================
--- LMDZ5/trunk/libf/comgeom2.h	(revision 1630)
+++ LMDZ5/trunk/libf/comgeom2.h	(revision 1630)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+!CDK comgeom2
+      COMMON/comgeom/                                                   &
+     & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm)  , &
+     & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1)           , &
+     & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols                 , &
+     & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm)       , &
+     & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1)       , &
+     & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1)         , &
+     & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1)        , &
+     & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1)    , &
+     & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm),      &
+     & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm)  , &
+     & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1)                        , &
+     & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), &
+     & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , &
+     & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2                , &
+     & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1)                  , &
+     & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm)  &
+     & , xprimu(iip1),xprimv(iip1)
+
+
+      REAL                                                               &
+     & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire &
+     & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4     , &
+     & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , &
+     & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     , &
+     & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1           , &
+     & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2     , &
+     & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu    , &
+     & cusurcvu,xprimu,xprimv
Index: LMDZ5/trunk/libf/comvert.h
===================================================================
--- LMDZ5/trunk/libf/comvert.h	(revision 1630)
+++ LMDZ5/trunk/libf/comvert.h	(revision 1630)
@@ -0,0 +1,19 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'comvert.h'
+
+      COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm),       &
+     &               pa,preff,nivsigs(llm),nivsig(llm+1)
+
+      common/comverti/disvert_type
+
+      REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
+
+      integer disvert_type ! type of vertical discretization:
+                           ! 1: Earth (default for planet_type==earth),
+                           !     automatic generation
+                           ! 2: Planets (default for planet_type!=earth),
+                           !     using 'z2sig.def' (or 'esasig.def) file
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/conf_dat2d.F
===================================================================
--- LMDZ5/trunk/libf/conf_dat2d.F	(revision 1630)
+++ LMDZ5/trunk/libf/conf_dat2d.F	(revision 1630)
@@ -0,0 +1,221 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd ,
+     ,                           interbar                        )
+c
+c     Auteur :  P. Le Van
+
+c    Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que
+c       qu'on ait     - pi    a    pi    en longitude
+c       et qu'on ait   pi/2.  a - pi/2.  en latitude
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c      modifiees pour etre configurees comme ci-dessus .
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      INTEGER lons,lats
+      CHARACTER*25 title
+      REAL xd(lons),yd(lats)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons),yf(lats)
+c
+c    ***  Arguments en entree et  sortie ***
+      REAL champd(lons,lats)
+
+c   ***     Variables  locales  ***
+c
+      REAL pi,pis2,depi
+      LOGICAL radianlon, invlon ,radianlat, invlat, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind
+
+      REAL, ALLOCATABLE :: xtemp(:) 
+      REAL, ALLOCATABLE :: ytemp(:) 
+      REAL, ALLOCATABLE :: champf(:,:)
+     
+c
+c      WRITE(6,*) ' conf_dat2d  pour la variable ', title
+
+      ALLOCATE( xtemp(lons) )
+      ALLOCATE( ytemp(lats) )
+      ALLOCATE( champf(lons,lats) )
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+            radianlon = .FALSE.
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        IF ( invlon )   THEN
+
+           DO j = 1, lats
+            DO i = 1,lons
+             champf(i,j) = champd(i,j)
+            ENDDO
+           ENDDO
+
+           DO i = 1 ,lons
+            xf(i) = xtemp(i)
+           ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+           DO i=1,lons
+            IF( xf(i).GT. pi )  THEN
+            GO TO 88
+            ENDIF
+           ENDDO
+
+88         CONTINUE
+c
+           ip180 = i
+
+           DO i = 1,lons
+            IF (xf(i).GT. pi)  THEN
+             xf(i) = xf(i) - depi
+            ENDIF
+           ENDDO
+
+           DO i= ip180,lons
+            ind = i-ip180 +1
+            xtemp(ind) = xf(i)
+           ENDDO
+
+           DO i= ind +1,lons
+            xtemp(i) = xf(i-ind)
+           ENDDO
+
+c   .....    on tourne les longitudes  pour  champf ....
+c
+           DO j = 1,lats
+
+             DO i = ip180,lons
+              ind  = i-ip180 +1
+              champd (ind,j) = champf (i,j)
+             ENDDO
+   
+             DO i= ind +1,lons
+              champd (i,j)  = champf (i-ind,j)
+             ENDDO
+
+           ENDDO
+
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+
+         IF ( invlat )    THEN
+
+           DO j = 1,lats
+            yf(j) = ytemp(j)
+           ENDDO
+
+           DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j) = champd(i,j)
+             ENDDO
+           ENDDO
+
+           DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1) = champf (i,j)
+              ENDDO
+           ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+
+c        
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+
+      ENDIF
+c
+        DEALLOCATE(champf)
+
+       DO i = 1, lons
+        xf(i) = xtemp(i)
+       ENDDO
+       DO j = 1, lats
+        yf(j) = ytemp(j)
+       ENDDO
+
+      deallocate(xtemp)
+      deallocate(ytemp)
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/conf_dat3d.F
===================================================================
--- LMDZ5/trunk/libf/conf_dat3d.F	(revision 1630)
+++ LMDZ5/trunk/libf/conf_dat3d.F	(revision 1630)
@@ -0,0 +1,296 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf,
+     ,                                 champd , interbar             )
+c
+c     Auteur : P. Le Van
+c
+c    Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon 
+c       qu'on ait     - pi    a    pi    en longitude
+c       qu'on ait      pi/2.  a - pi/2.  en latitude
+c      et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos.
+c           (     en Pascals   ) .
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      zd  les pressions initiales
+c
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c       modifiees pour etre configurees comme ci-dessus .
+c      zf  les pressions en sortie
+c
+c      champd   en meme temps le champ initial et  final
+c
+c      interbar = .TRUE.  si on appelle l'interpo. barycentrique inter_barxy
+c          sinon , l'interpolation   grille_m  ( grid_atob ) .
+c
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      CHARACTER*(*) :: title
+      INTEGER lons, lats, levs
+      REAL xd(lons), yd(lats), zd(levs)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons), yf(lats), zf(levs)
+
+c    ***  Arguments en entree et  sortie ***
+      REAL  champd(lons,lats,levs)
+
+c    ***  Variables locales  ***
+c
+      REAL pi,pis2,depi,presmax
+      LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind,l
+
+      REAL, ALLOCATABLE :: xtemp(:)
+      REAL, ALLOCATABLE :: ytemp(:)
+      REAL, ALLOCATABLE :: ztemp(:)
+      REAL, ALLOCATABLE :: champf(:,:,:)
+     
+
+c      WRITE(6,*) '  Conf_dat3d  pour  ',title
+
+      ALLOCATE(xtemp(lons))
+      ALLOCATE(ytemp(lats))
+      ALLOCATE(ztemp(levs))
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+      DO l = 1, levs
+       ztemp(l) = zd(l)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        alloc =.FALSE.
+
+        IF ( invlon )   THEN
+
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+
+            DO i = 1 ,lons
+             xf(i) = xtemp(i)
+            ENDDO
+
+            DO l = 1, levs
+             DO j = 1, lats
+              DO i= 1, lons
+               champf (i,j,l)  = champd (i,j,l)
+              ENDDO
+             ENDDO
+            ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+            DO i=1,lons
+             IF( xf(i).GT. pi )  THEN
+              GO TO 88
+             ENDIF
+            ENDDO
+
+88          CONTINUE
+c
+            ip180 = i
+
+            DO i = 1,lons
+             IF (xf(i).GT. pi)  THEN
+              xf(i) = xf(i) - depi
+             ENDIF
+            ENDDO
+
+            DO i= ip180,lons
+             ind = i-ip180 +1
+             xtemp(ind) = xf(i)
+            ENDDO
+
+            DO i= ind +1,lons
+             xtemp(i) = xf(i-ind)
+            ENDDO
+
+c   .....    on tourne les longitudes  pour champf  ....
+c
+            DO l = 1,levs
+              DO j = 1,lats
+               DO i = ip180,lons
+                ind  = i-ip180 +1
+                champd (ind,j,l) = champf (i,j,l)
+               ENDDO
+   
+               DO i= ind +1,lons
+                champd (i,j,l)  = champf (i-ind,j,l)
+               ENDDO
+              ENDDO
+            ENDDO
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+         
+         IF ( invlat )    THEN
+
+           IF(.NOT.alloc)  THEN 
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+           ENDIF
+
+           DO j = 1, lats
+            yf(j) = ytemp(j)
+           ENDDO
+         
+           DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+
+            DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1,l) = champf (i,j,l)
+              ENDDO
+            ENDDO
+          ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+c
+c
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+      ENDIF
+c
+
+      invlev = .FALSE.
+      IF( ztemp(1).LT.ztemp(levs) )  invlev = .TRUE.
+
+      presmax = MAX( ztemp(1), ztemp(levs) )
+      IF( presmax.LT.1200. ) THEN
+         DO l = 1,levs
+           ztemp(l) = ztemp(l) * 100.
+         ENDDO
+      ENDIF
+
+      IF( invlev )  THEN
+
+          IF(.NOT.alloc)  THEN
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+          ENDIF
+
+          DO l = 1,levs
+            zf(l) = ztemp(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+          DO l = 1,levs
+            ztemp(levs+1-l) = zf(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champd(i,j,levs+1-l) = champf(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+
+      ENDIF
+
+         IF(alloc)  DEALLOCATE(champf)
+
+         DO i = 1, lons
+           xf(i) = xtemp(i)
+         ENDDO
+         DO j = 1, lats
+           yf(j) = ytemp(j)
+         ENDDO
+         DO l = 1, levs
+           zf(l) = ztemp(l)
+         ENDDO
+
+      DEALLOCATE(xtemp)
+      DEALLOCATE(ytemp)
+      DEALLOCATE(ztemp)
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/conf_gcm.F
===================================================================
--- LMDZ5/trunk/libf/conf_gcm.F	(revision 1630)
+++ LMDZ5/trunk/libf/conf_gcm.F	(revision 1630)
@@ -0,0 +1,868 @@
+!
+! $Id: conf_gcm.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
+c
+#ifdef CPP_IOIPSL
+      use IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      use ioipsl_getincom
+#endif
+      use misc_mod
+      use mod_filtre_fft, ONLY : use_filtre_fft
+      use mod_filtre_fft_loc, ONLY : use_filtre_fft_loc=>use_filtre_fft
+      use mod_hallo, ONLY : use_mpi_alloc
+      use parallel, ONLY : omp_chunk
+      USE control_mod
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+!#include "clesphys.h"
+#include "iniprint.h"
+#include "temps.h"
+#include "comconst.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy, tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+      adjust=.false.
+      call getin('adjust',adjust)
+      
+      itaumax=0
+      call getin('itaumax',itaumax);
+      if (itaumax<=0) itaumax=HUGE(itaumax)
+      
+!Config  Key  = lunout
+!Config  Desc = unite de fichier pour les impressions
+!Config  Def  = 6
+!Config  Help = unite de fichier pour les impressions 
+!Config         (defaut sortie standard = 6)
+      lunout=6
+      CALL getin('lunout', lunout)
+      IF (lunout /= 5 .and. lunout /= 6) THEN
+        OPEN(lunout,FILE='lmdz.out')
+      ENDIF
+
+!Config  Key  = prt_level
+!Config  Desc = niveau d'impressions de débogage
+!Config  Def  = 0
+!Config  Help = Niveau d'impression pour le débogage
+!Config         (0 = minimum d'impression)
+      prt_level = 0
+      CALL getin('prt_level',prt_level)
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+!Config  Key  = planet_type
+!Config  Desc = planet type ("earth", "mars", "venus", ...)
+!Config  Def  = earth
+!Config  Help = this flag sets the type of atymosphere that is considered
+      planet_type="earth"
+      CALL getin('planet_type',planet_type)
+
+!Config  Key  = calend
+!Config  Desc = type de calendrier utilise
+!Config  Def  = earth_360d
+!Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
+!Config         
+      calend = 'earth_360d'
+      CALL getin('calend', calend)
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = raz_date
+!Config  Desc = Remise a zero de la date initiale
+!Config  Def  = 0 (pas de remise a zero)
+!Config  Help = Remise a zero de la date initiale 
+!Config         0 pas de remise a zero, on garde la date du fichier restart
+!Config         1 prise en compte de la date de gcm.def avec remise a zero
+!Config         des compteurs de pas de temps
+      raz_date = 0
+      CALL getin('raz_date', raz_date)
+
+!Config  Key  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps)
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+!Config  Key  = iapp_tracvl
+!Config  Desc = frequence du groupement des flux 
+!Config  Def  = iperiod
+!Config  Help = frequence du groupement des flux (en pas de temps) 
+       iapp_tracvl = iperiod
+       CALL getin('iapp_tracvl',iapp_tracvl)
+
+!Config  Key  = iconser
+!Config  Desc = periode de sortie des variables de controle
+!Config  Def  = 240  
+!Config  Help = periode de sortie des variables de controle
+!Config         (En pas de temps)
+       iconser = 240  
+       CALL getin('iconser', iconser)
+
+!Config  Key  = iecri
+!Config  Desc = periode d'ecriture du fichier histoire
+!Config  Def  = 1
+!Config  Help = periode d'ecriture du fichier histoire (en jour) 
+       iecri = 1
+       CALL getin('iecri',iecri)
+
+
+!Config  Key  = periodav
+!Config  Desc = periode de stockage fichier histmoy
+!Config  Def  = 1
+!Config  Help = periode de stockage fichier histmoy (en jour) 
+       periodav = 1.
+       CALL getin('periodav',periodav)
+
+!Config  Key  = output_grads_dyn
+!Config  Desc = output dynamics diagnostics in 'dyn.dat' file
+!Config  Def  = n
+!Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
+       output_grads_dyn=.false.
+       CALL getin('output_grads_dyn',output_grads_dyn)
+
+!Config  Key  = idissip
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 10
+!Config  Help = periode de la dissipation 
+!Config         (en pas) ... a completer !
+       idissip = 10
+       CALL getin('idissip',idissip)
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+! Parametres controlant la variation sur la verticale des constantes de
+! dissipation.
+! Pour le moment actifs uniquement dans la version a 39 niveaux
+! avec ok_strato=y
+
+       dissip_factz=4.
+       dissip_deltaz=10.
+       dissip_zref=30.
+       CALL getin('dissip_factz',dissip_factz )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_zref',dissip_zref )
+
+       iflag_top_bound=1
+       tau_top_bound=1.e-5
+       CALL getin('iflag_top_bound',iflag_top_bound)
+       CALL getin('tau_top_bound',tau_top_bound)
+
+!
+!Config  Key  = coefdis
+!Config  Desc = coefficient pour gamdissip
+!Config  Def  = 0
+!Config  Help = coefficient pour gamdissip  
+       coefdis = 0.
+       CALL getin('coefdis',coefdis)
+
+!Config  Key  = purmats
+!Config  Desc = Schema d'integration
+!Config  Def  = n
+!Config  Help = Choix du schema d'integration temporel.
+!Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+       purmats = .FALSE.
+       CALL getin('purmats',purmats)
+
+!Config  Key  = ok_guide
+!Config  Desc = Guidage
+!Config  Def  = n
+!Config  Help = Guidage
+       ok_guide = .FALSE.
+       CALL getin('ok_guide',ok_guide)
+
+c    ...............................................................
+
+!Config  Key  =  read_start
+!Config  Desc = Initialize model using a 'start.nc' file
+!Config  Def  = y
+!Config  Help = y: intialize dynamical fields using a 'start.nc' file
+!               n: fields are initialized by 'iniacademic' routine
+       read_start= .true.
+       CALL getin('read_start',read_start)
+
+!Config  Key  = iflag_phys
+!Config  Desc = Avec ls physique 
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       iflag_phys = 1
+       CALL getin('iflag_phys',iflag_phys)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+
+
+!Config  Key  = ip_ebil_dyn
+!Config  Desc = PRINT level for energy conserv. diag.
+!Config  Def  = 0
+!Config  Help = PRINT level for energy conservation diag. ;
+!               les options suivantes existent :
+!Config         0 pas de print
+!Config         1 pas de print
+!Config         2 print,
+       ip_ebil_dyn = 0
+       CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+!
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clonn = 0.
+       CALL getin('clon',clonn)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clatt = 0.
+       CALL getin('clat',clatt)
+
+c
+c
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def',
+     &    ' est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismxx = 1.0
+       CALL getin('grossismx',grossismxx)
+
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ',
+     &  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismyy = 1.0
+       CALL getin('grossismy',grossismyy)
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ',
+     & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)
+     &       'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)
+     &       'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+         IF( fxyhypbb )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** fxyhypb lu sur le fichier start est ',
+     *       'F alors  qu il est  T  sur  run.def  ***'
+              STOP
+         ENDIF
+      ELSE
+         IF( .NOT.fxyhypbb )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' ***  fxyhypb lu sur le fichier start est ',
+     *        'T alors  qu il est  F  sur  run.def  ****  '
+              STOP
+         ENDIF
+      ENDIF
+c
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ',
+     *  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomyy = 0.0
+       CALL getin('dzoomy',dzoomyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ',
+     * 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+      
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       tauxx = 3.0
+       CALL getin('taux',tauxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de taux passee par ',
+     * 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = tauyy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauyy = 3.0
+       CALL getin('tauy',tauyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de tauy passee par ',
+     * 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+cc
+      IF( .NOT.fxyhypb  )  THEN
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinuss = .TRUE.
+       CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+          IF( ysinuss )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+            STOP
+          ENDIF
+        ELSE
+          IF( .NOT.ysinuss )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est T',
+     *        ' alors  qu il est  F  sur  run.def  ****  '
+              STOP
+          ENDIF
+        ENDIF
+      ENDIF ! of IF( .NOT.fxyhypb  )
+c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+!Config  Key  = ok_dynzon 
+!Config  Desc = calcul et sortie des transports 
+!Config  Def  = n 
+!Config  Help = Permet de mettre en route le calcul des transports 
+!Config          
+      ok_dynzon = .FALSE. 
+      CALL getin('ok_dynzon',ok_dynzon) 
+
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' planet_type = ', planet_type
+      write(lunout,*)' calend = ', calend
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+      write(lunout,*)' idissip = ', idissip
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' read_start = ', read_start
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' clonn = ', clonn 
+      write(lunout,*)' clatt = ', clatt
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypbb = ', fxyhypbb
+      write(lunout,*)' dzoomxx = ', dzoomxx
+      write(lunout,*)' dzoomy = ', dzoomyy
+      write(lunout,*)' tauxx = ', tauxx
+      write(lunout,*)' tauyy = ', tauyy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' config_inca = ', config_inca
+      write(lunout,*)' ok_dynzon = ', ok_dynzon 
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)
+     &   'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)
+     &  'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+!Config  Key  = ok_dynzon 
+!Config  Desc = calcul et sortie des transports 
+!Config  Def  = n 
+!Config  Help = Permet de mettre en route le calcul des transports 
+!Config          
+      ok_dynzon = .FALSE. 
+      CALL getin('ok_dynzon',ok_dynzon) 
+
+!Config  Key  = use_filtre_fft
+!Config  Desc = flag d'activation des FFT pour le filtre
+!Config  Def  = false
+!Config  Help = permet d'activer l'utilisation des FFT pour effectuer
+!Config         le filtrage aux poles. 
+      use_filtre_fft=.FALSE.
+      CALL getin('use_filtre_fft',use_filtre_fft)
+      use_filtre_fft_loc=use_filtre_fft
+      
+      IF (use_filtre_fft .AND. grossismx /= 1.0) THEN
+        write(lunout,*)'WARNING !!! '
+        write(lunout,*)"Le zoom en longitude est incompatible",
+     &                 " avec l'utilisation du filtre FFT ",
+     &                 "---> filtre FFT dÃ©sactivÃ© "
+       use_filtre_fft=.FALSE.
+      ENDIF
+      
+ 
+      
+!Config  Key  = use_mpi_alloc
+!Config  Desc = Utilise un buffer MPI en mï¿½moire globale
+!Config  Def  = false
+!Config  Help = permet d'activer l'utilisation d'un buffer MPI
+!Config         en mï¿½moire globale a l'aide de la fonction MPI_ALLOC.
+!Config         Cela peut amï¿½liorer la bande passante des transferts MPI
+!Config         d'un facteur 2  
+      use_mpi_alloc=.FALSE.
+      CALL getin('use_mpi_alloc',use_mpi_alloc)
+
+!Config  Key  = omp_chunk
+!Config  Desc = taille des blocs openmp
+!Config  Def  = 1
+!Config  Help = defini la taille des packets d'itï¿½ration openmp
+!Config         distribuï¿½e ï¿½ chaque tï¿½che lors de l'entrï¿½e dans une
+!Config         boucle parallï¿½lisï¿½e
+  
+      omp_chunk=1
+      CALL getin('omp_chunk',omp_chunk)
+
+!Config key = ok_strato
+!Config  Desc = activation de la version strato
+!Config  Def  = .FALSE.
+!Config  Help = active la version stratosphérique de LMDZ de F. Lott
+
+      ok_strato=.FALSE.
+      CALL getin('ok_strato',ok_strato)
+
+!Config  Key  = ok_gradsfile
+!Config  Desc = activation des sorties grads du guidage
+!Config  Def  = n
+!Config  Help = active les sorties grads du guidage
+
+       ok_gradsfile = .FALSE.
+       CALL getin('ok_gradsfile',ok_gradsfile)
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' planet_type = ', planet_type
+      write(lunout,*)' calend = ', calend
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+      write(lunout,*)' idissip = ', idissip
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' read_start = ', read_start
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' clon = ', clon
+      write(lunout,*)' clat = ', clat
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypb = ', fxyhypb
+      write(lunout,*)' dzoomx = ', dzoomx
+      write(lunout,*)' dzoomy = ', dzoomy
+      write(lunout,*)' taux = ', taux
+      write(lunout,*)' tauy = ', tauy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' config_inca = ', config_inca
+      write(lunout,*)' ok_dynzon = ', ok_dynzon 
+      write(lunout,*)' use_filtre_fft = ', use_filtre_fft
+      write(lunout,*)' use_mpi_alloc = ', use_mpi_alloc
+      write(lunout,*)' omp_chunk = ', omp_chunk
+      write(lunout,*)' ok_strato = ', ok_strato
+      write(lunout,*)' ok_gradsfile = ', ok_gradsfile
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/control.h
===================================================================
--- LMDZ5/trunk/libf/control.h	(revision 1630)
+++ LMDZ5/trunk/libf/control.h	(revision 1630)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'control.h'
+
+      COMMON/control/nday,day_step,                                     &
+     &              iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , &
+     &              periodav,iecrimoy,dayref,anneeref,                  &
+     &              raz_date,offline,ip_ebil_dyn,config_inca,           &
+     &              planet_type,output_grads_dyn,ok_dynzon
+
+      INTEGER   nday,day_step,iperiod,iapp_tracvl,iconser,iecri,        &
+     &          idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date      &
+     &          ,ip_ebil_dyn
+      REAL periodav
+      logical offline
+      CHARACTER (len=4) :: config_inca
+      CHARACTER(len=10) :: planet_type ! planet type ('earth','mars',...)
+      LOGICAL :: output_grads_dyn ! output dynamics diagnostics in
+                                  ! binary grads file 'dyn.dat' (y/n)
+      LOGICAL :: ok_dynzon 
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/control_mod.F90
===================================================================
--- LMDZ5/trunk/libf/control_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/control_mod.F90	(revision 1630)
@@ -0,0 +1,26 @@
+!
+! $Id$
+!
+
+MODULE control_mod
+
+! LF 01/2010
+! Remplacement du fichier et common control
+
+  IMPLICIT NONE
+
+  REAL    :: periodav
+  INTEGER :: nday,day_step,iperiod,iapp_tracvl
+  INTEGER :: iconser,iecri,idissip,iphysiq,iecrimoy
+  INTEGER :: dayref,anneeref, raz_date, ip_ebil_dyn
+  LOGICAL :: offline, output_grads_dyn
+  CHARACTER (len=4)  :: config_inca
+  CHARACTER (len=10) :: planet_type
+
+  LOGICAL ok_dynzon  ! output zonal transports in dynzon.nc file
+  LOGICAL ok_dyn_ins ! output instantaneous values of fields
+                     ! in the dynamics in NetCDF files dyn_hist*nc
+  LOGICAL ok_dyn_ave ! output averaged values of fields in the dynamics
+                     ! in NetCDF files dyn_hist*ave.nc
+
+END MODULE
Index: LMDZ5/trunk/libf/convflu.F
===================================================================
--- LMDZ5/trunk/libf/convflu.F	(revision 1630)
+++ LMDZ5/trunk/libf/convflu.F	(revision 1630)
@@ -0,0 +1,62 @@
+!
+! $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 5 l = 1,nbniv
+c
+      DO 2  ij = iip2, ip1jm - 1
+      convfl( ij + 1,l ) =  xflu(   ij,l ) - xflu( ij +  1,l )   +
+     *                      yflu(ij +1,l ) - yflu( ij -iim,l )
+   2  CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+   3  CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+      DO 4 ij = 1,iip1
+      convfl(     ij   ,l ) = convpn * aire(   ij     ) / apoln
+      convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols
+   4  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convflu_loc.F
===================================================================
--- LMDZ5/trunk/libf/convflu_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/convflu_loc.F	(revision 1630)
@@ -0,0 +1,84 @@
+      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
+      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 5 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 2  ij = ijb , ije - 1
+          convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   +
+     *                     yflu(ij +1,l ) - yflu( ij -iim,l )
+   2    CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+        DO 3 ij = ijb,ije,iip1
+          convfl( ij,l ) = convfl( ij + iim,l )
+   3    CONTINUE
+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
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT   
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convflu_p.F
===================================================================
--- LMDZ5/trunk/libf/convflu_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/convflu_p.F	(revision 1630)
@@ -0,0 +1,84 @@
+      SUBROUTINE convflu_p( 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
+      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
+      INTEGER ijb,ije
+      EXTERNAL   SSUM
+      REAL       SSUM
+c
+c
+#include "comgeom.h"
+c
+     
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+      DO 5 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 2  ij = ijb , ije - 1
+          convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   +
+     *                     yflu(ij +1,l ) - yflu( ij -iim,l )
+   2    CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+        DO 3 ij = ijb,ije,iip1
+          convfl( ij,l ) = convfl( ij + iim,l )
+   3    CONTINUE
+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
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT   
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convmas.F
===================================================================
--- LMDZ5/trunk/libf/convmas.F	(revision 1630)
+++ LMDZ5/trunk/libf/convmas.F	(revision 1630)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      SUBROUTINE convmas (pbaru, pbarv, convm )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+
+       CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+
+      DO      l      = llmm1, 1, -1
+        DO    ij     = 1, ip1jmp1
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convmas1_loc.F
===================================================================
--- LMDZ5/trunk/libf/convmas1_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/convmas1_loc.F	(revision 1630)
@@ -0,0 +1,64 @@
+      SUBROUTINE convmas1_loc (pbaru, pbarv, convm )
+c
+      USE parallel
+      USE mod_filtreg_p
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm )
+      REAL, target :: convm(  ijb_u:ije_u,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_loc( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p( convm, jjb_u,jje_u,jjb, jje, jjp1, llm,
+     &                 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convmas2_loc.F
===================================================================
--- LMDZ5/trunk/libf/convmas2_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/convmas2_loc.F	(revision 1630)
@@ -0,0 +1,56 @@
+      SUBROUTINE convmas2_loc ( convm )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm )
+      REAL :: convm(  ijb_u:ije_u,llm )
+      INTEGER   l,ij
+      INTEGER ijb,ije,jjb,jje
+ 
+c$OMP MASTER
+c    integration de la convergence de masse de haut  en bas ......
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+c$OMP END MASTER
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convmas_loc.F
===================================================================
--- LMDZ5/trunk/libf/convmas_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/convmas_loc.F	(revision 1630)
@@ -0,0 +1,77 @@
+      SUBROUTINE convmas_loc (pbaru, pbarv, convm )
+c
+      USE parallel
+      USE mod_filtreg_p
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm )
+      REAL, target :: convm(  ijb_u:ije_u,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_loc( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p(convm, jjb_u, jje_u,jjb, jje, jjp1, llm,
+     &                 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+!$OMP BARRIER
+!$OMP MASTER
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+!$OMP END MASTER
+!$OMP BARRIER
+      RETURN
+      END
Index: LMDZ5/trunk/libf/convmas_p.F
===================================================================
--- LMDZ5/trunk/libf/convmas_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/convmas_p.F	(revision 1630)
@@ -0,0 +1,71 @@
+      SUBROUTINE convmas_p (pbaru, pbarv, convm )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL, target :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_p( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/coordij.F
===================================================================
--- LMDZ5/trunk/libf/coordij.F	(revision 1630)
+++ LMDZ5/trunk/libf/coordij.F	(revision 1630)
@@ -0,0 +1,48 @@
+!
+! $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=======================================================================
+
+      IMPLICIT NONE
+      REAL lon,lat
+      INTEGER ilon,jlat
+      INTEGER i,j
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+
+      real zlon,zlat
+
+      zlon=lon*pi/180.
+      zlat=lat*pi/180.
+
+      DO i=1,iim+1
+         IF (rlonu(i).GT.zlon) THEN
+            ilon=i
+            GOTO 10
+         ENDIF
+      ENDDO
+10    CONTINUE
+
+      j=0
+      DO j=1,jjm
+         IF(rlatv(j).LT.zlat) THEN
+            jlat=j
+            GOTO 20
+         ENDIF
+      ENDDO
+20    CONTINUE
+      IF(j.EQ.0) j=jjm+1
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/covcont.F
===================================================================
--- LMDZ5/trunk/libf/covcont.F	(revision 1630)
+++ LMDZ5/trunk/libf/covcont.F	(revision 1630)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
+      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( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO 10 l = 1,klevel
+
+      DO 2  ij = iip2, ip1jm
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = 1,ip1jm
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/covcont_loc.F
===================================================================
--- LMDZ5/trunk/libf/covcont_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/covcont_loc.F	(revision 1630)
@@ -0,0 +1,59 @@
+      SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
+      USE parallel
+      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 10 l = 1,klevel
+
+      DO 2  ij = ijb_u,ije_u
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = ijb_v,ije_v
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/covnat_loc.F
===================================================================
--- LMDZ5/trunk/libf/covnat_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/covnat_loc.F	(revision 1630)
@@ -0,0 +1,84 @@
+!
+! $Header$
+!
+      SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
+      USE parallel
+      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: LMDZ5/trunk/libf/covnat_p.F
===================================================================
--- LMDZ5/trunk/libf/covnat_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/covnat_p.F	(revision 1630)
@@ -0,0 +1,76 @@
+!
+! $Header$
+!
+      SUBROUTINE covnat_p(klevel,ucov, vcov, unat, vnat )
+      USE parallel
+      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( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER :: ijb,ije
+      
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (pole_nord) then
+        DO l = 1,klevel
+           DO ij = 1, iip1
+              unat (ij,l) =0.
+           END DO
+        ENDDO
+      endif
+
+      if (pole_sud) then
+        DO l = 1,klevel
+           DO ij = ip1jm+1, ip1jmp1  
+            unat (ij,l) =0.
+           END DO
+        ENDDO
+      endif
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO l = 1,klevel
+         DO ij = ijb, ije
+            unat( ij,l ) = ucov( ij,l ) / cu(ij)
+         ENDDO
+      END DO
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+     
+      DO l = 1,klevel
+         DO ij = ijb,ije
+            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+         ENDDO
+
+      ENDDO
+      
+      RETURN
+      END
Index: LMDZ5/trunk/libf/cray.F
===================================================================
--- LMDZ5/trunk/libf/cray.F	(revision 1630)
+++ LMDZ5/trunk/libf/cray.F	(revision 1630)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+#ifdef CRAY
+      SUBROUTINE riencray
+      END
+#else
+      subroutine scopy(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      real sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      if (incx.eq.1.and.incy.eq.1) then
+      do 10 i=1,n
+         sy(i)=sx(i)
+10    continue
+      else
+      iy=1
+      ix=1
+      do 11 i=1,n
+         sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+11    continue
+      endif
+c
+      return
+      end
+
+      function ssum(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,i,ix
+      real ssum,sx((n-1)*incx+1)
+c
+      ssum=0.
+      if (incx.eq.1) then
+      do 10 i=1,n
+         ssum=ssum+sx(i)
+10    continue
+      else
+      ix=1
+      do 11 i=1,n
+         ssum=ssum+sx(ix)
+         ix=ix+incx
+11    continue
+      endif
+c
+      return
+      end
+#endif
Index: LMDZ5/trunk/libf/create_etat0_limit.F
===================================================================
--- LMDZ5/trunk/libf/create_etat0_limit.F	(revision 1630)
+++ LMDZ5/trunk/libf/create_etat0_limit.F	(revision 1630)
@@ -0,0 +1,86 @@
+!
+! $Id: create_etat0_limit.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+       PROGRAM create_etat0_limit
+#ifdef CPP_EARTH
+! This prog. is designed to work for Earth
+       USE dimphy
+       USE comgeomphy
+       USE mod_phys_lmdz_para
+       USE mod_const_mpi
+       USE infotrac
+      USE control_mod
+#ifdef CPP_IOIPSL
+       use ioipsl, only: ioconf_calendar
+#endif
+       IMPLICIT NONE
+c
+c
+c     Programme d'appel a etat0, creation des etats initiaux et limit_netcdf
+c   
+c
+c     interbar = .T . si appel a  interpol. barycentrique inter_barxy
+c
+c     extrap   = .T . si on fait une extrapolation de donnees , comme pour
+c       les  SST  lorsque  le fichier ne contient pas uniquement  des points 
+c     oceaniques .
+c
+c     oldice   = .T. si l'on veut garder les anciennes glaces , obtenues
+c     par  grille_m  ( grid_atob ) .
+c
+c     on cree le masque dans etat0 que l'on passe ensuite dans limit pour 
+c     garder les coherences
+
+      LOGICAL interbar, extrap , oldice
+      PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.)
+#include "dimensions.h"
+#include "paramet.h"
+#include "indicesol.h"
+      REAL :: masque(iip1,jjp1)
+!      REAL :: pctsrf(iim*(jjm-1)+2, nbsrf)
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         call init_const_lmdz(
+     $        nbtr,anneeref,dayref,
+     $        iphysiq, day_step,nday)
+#endif
+         print *, 'nbtr =' , nbtr 
+      END IF
+
+      CALL init_mpi
+
+
+      CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+      PRINT *,'---> klon=',klon
+
+      IF (mpi_size>1 .OR. omp_size>1) THEN
+        CALL abort_gcm('create_etat0_limit','In parallel mode, 
+     &                 create_etat0_limit must be called only 
+     &                 for 1 process and 1 task')
+      ENDIF
+      call InitComgeomphy
+
+#ifdef CPP_IOIPSL
+      call ioconf_calendar('360d')
+#endif
+
+      WRITE(6,*) '  *********************  '
+      WRITE(6,*) ' interbar = ',interbar
+      CALL etat0_netcdf ( interbar, masque )
+c
+      WRITE(6,1)
+      WRITE(6,*) '  *********************  '
+      WRITE(6,*) '  ***  Limit_netcdf ***  '
+      WRITE(6,*) '  *********************  '
+      WRITE(6,1)
+      
+c     
+      CALL  limit_netcdf ( interbar, extrap , oldice, masque)
+
+1     FORMAT(//)
+
+#endif
+! of #ifdef CPP_EARTH
+      STOP
+      END
Index: LMDZ5/trunk/libf/defrun.F
===================================================================
--- LMDZ5/trunk/libf/defrun.F	(revision 1630)
+++ LMDZ5/trunk/libf/defrun.F	(revision 1630)
@@ -0,0 +1,497 @@
+!
+! $Id: defrun.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+      SUBROUTINE defrun( tapedef, etatinit, clesphy0 )
+c
+      USE control_mod
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "clesph0.h"
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      INTEGER   tapeout
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy,tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      tapeout = 6
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+      OPEN( tapedef,file ='gcm.def',status='old',form='formatted')
+
+
+      READ (tapedef,9000) ch1,ch2,ch3
+      WRITE(tapeout,9000) ch1,ch2,ch3
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dayref
+      WRITE(tapeout,9001) ch1,'dayref'
+      WRITE(tapeout,*)    dayref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    anneeref
+      WRITE(tapeout,9001) ch1,'anneeref'
+      WRITE(tapeout,*)    anneeref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nday
+      WRITE(tapeout,9001) ch1,'nday'
+      WRITE(tapeout,*)    nday
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    day_step
+      WRITE(tapeout,9001) ch1,'day_step'
+      WRITE(tapeout,*)    day_step
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iperiod
+      WRITE(tapeout,9001) ch1,'iperiod'
+      WRITE(tapeout,*)    iperiod
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iapp_tracvl
+      WRITE(tapeout,9001) ch1,'iapp_tracvl'
+      WRITE(tapeout,*)    iapp_tracvl
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iconser
+      WRITE(tapeout,9001) ch1,'iconser'
+      WRITE(tapeout,*)    iconser
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iecri
+      WRITE(tapeout,9001) ch1,'iecri'
+      WRITE(tapeout,*)    iecri
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    periodav
+      WRITE(tapeout,9001) ch1,'periodav'
+      WRITE(tapeout,*)    periodav
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    idissip
+      WRITE(tapeout,9001) ch1,'idissip'
+      WRITE(tapeout,*)    idissip
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    lstardis
+      WRITE(tapeout,9001) ch1,'lstardis'
+      WRITE(tapeout,*)    lstardis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergdiv
+      WRITE(tapeout,9001) ch1,'nitergdiv'
+      WRITE(tapeout,*)    nitergdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergrot
+      WRITE(tapeout,9001) ch1,'nitergrot'
+      WRITE(tapeout,*)    nitergrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    niterh
+      WRITE(tapeout,9001) ch1,'niterh'
+      WRITE(tapeout,*)    niterh
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagdiv
+      WRITE(tapeout,9001) ch1,'tetagdiv'
+      WRITE(tapeout,*)    tetagdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagrot
+      WRITE(tapeout,9001) ch1,'tetagrot'
+      WRITE(tapeout,*)    tetagrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetatemp
+      WRITE(tapeout,9001) ch1,'tetatemp'
+      WRITE(tapeout,*)    tetatemp
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    coefdis
+      WRITE(tapeout,9001) ch1,'coefdis'
+      WRITE(tapeout,*)    coefdis
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    purmats
+      WRITE(tapeout,9001) ch1,'purmats'
+      WRITE(tapeout,*)    purmats
+
+c    ...............................................................
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_phys
+      WRITE(tapeout,9001) ch1,'iflag_phys'
+      WRITE(tapeout,*)    iflag_phys
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iphysiq
+      WRITE(tapeout,9001) ch1,'iphysiq'
+      WRITE(tapeout,*)    iphysiq
+
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    cycle_diurne
+      WRITE(tapeout,9001) ch1,'cycle_diurne'
+      WRITE(tapeout,*)    cycle_diurne
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    soil_model
+      WRITE(tapeout,9001) ch1,'soil_model'
+      WRITE(tapeout,*)    soil_model
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    new_oliq
+      WRITE(tapeout,9001) ch1,'new_oliq'
+      WRITE(tapeout,*)    new_oliq
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orodr
+      WRITE(tapeout,9001) ch1,'ok_orodr'
+      WRITE(tapeout,*)    ok_orodr
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orolf
+      WRITE(tapeout,9001) ch1,'ok_orolf'
+      WRITE(tapeout,*)    ok_orolf
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_limitvrai
+      WRITE(tapeout,9001) ch1,'ok_limitvrai'
+      WRITE(tapeout,*)    ok_limitvrai
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nbapp_rad
+      WRITE(tapeout,9001) ch1,'nbapp_rad'
+      WRITE(tapeout,*)    nbapp_rad
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_con
+      WRITE(tapeout,9001) ch1,'iflag_con'
+      WRITE(tapeout,*)    iflag_con
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = REAL( iflag_con )
+                          clesphy0(2) = REAL( nbapp_rad )
+
+       IF( cycle_diurne  ) clesphy0(3) =  1.
+       IF(   soil_model  ) clesphy0(4) =  1.
+       IF(     new_oliq  ) clesphy0(5) =  1.
+       IF(     ok_orodr  ) clesphy0(6) =  1.
+       IF(     ok_orolf  ) clesphy0(7) =  1.
+       IF(  ok_limitvrai ) clesphy0(8) =  1.
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clonn
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clonn
+      IF( ABS(clon - clonn).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clatt
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clatt
+
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismxx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismxx
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismyy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismyy
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypbb
+      WRITE(tapeout,9001) ch1,'fxyhypbb'
+      WRITE(tapeout,*)    fxyhypbb
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F'
+     *,      '                   alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t'
+     *,      '                   alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomxx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomyy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomyy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauxx
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    tauxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauyy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauyy
+
+      IF( fxyhypb )  THEN
+
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de taux passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de tauy passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+      ENDIF
+      
+cc
+      IF( .NOT.fxyhypb  )  THEN
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ysinuss
+        WRITE(tapeout,9001) ch1,'ysinus'
+        WRITE(tapeout,*)    ysinuss
+
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est T',
+     *       ' alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+      WRITE(6,*) ' alphax alphay defrun ',alphax,alphay
+
+      CLOSE(tapedef)
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clon
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clon
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clat
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clat
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismy
+
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) '***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypb
+      WRITE(tapeout,9001) ch1,'fxyhypb'
+      WRITE(tapeout,*)    fxyhypb
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    taux
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    taux
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ysinus
+      WRITE(tapeout,9001) ch1,'ysinus'
+      WRITE(tapeout,*)    ysinus
+       
+      WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a12)
+cc
+      CLOSE(tapedef)
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/description.h
===================================================================
--- LMDZ5/trunk/libf/description.h	(revision 1630)
+++ LMDZ5/trunk/libf/description.h	(revision 1630)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      character (len=120) :: descript
+      common /titre/descript
Index: LMDZ5/trunk/libf/diagedyn.F
===================================================================
--- LMDZ5/trunk/libf/diagedyn.F	(revision 1630)
+++ LMDZ5/trunk/libf/diagedyn.F	(revision 1630)
@@ -0,0 +1,321 @@
+!
+! $Id: diagedyn.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+
+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======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+#ifdef CPP_EARTH
+#include "../phylmd/YOMCST.h"
+#include "../phylmd/YOETHF.h"
+#endif
+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
+
+
+#ifdef CPP_EARTH
+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.gt.0) .and. (pas(idiag2) .ne. 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.ge.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
+      write(lunout,*)'diagedyn: Needs Earth physics to function'
+#endif
+! #endif of #ifdef CPP_EARTH 
+      RETURN 
+      END 
Index: LMDZ5/trunk/libf/dimensions_mod.F90
===================================================================
--- LMDZ5/trunk/libf/dimensions_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/dimensions_mod.F90	(revision 1630)
@@ -0,0 +1,4 @@
+MODULE dimensions
+  INCLUDE 'dimensions.h'
+  INCLUDE 'paramet.h'
+END MODULE dimensions
Index: LMDZ5/trunk/libf/dissip_loc.F
===================================================================
--- LMDZ5/trunk/libf/dissip_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/dissip_loc.F	(revision 1630)
@@ -0,0 +1,228 @@
+      SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
+c
+      USE parallel
+      USE write_field_loc
+      USE dissip_mod
+      IMPLICIT NONE
+
+
+c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+c                                 (  10/01/98  )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation horizontale
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comdissnew.h"
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+      REAL teta(ijb_u:ije_u,llm)
+      REAL  p( ijb_u:ije_u,llmp1 )
+      REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm),dh(ijb_u:ije_u,llm)
+
+c   Local:
+c   ------
+
+      REAL gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm)
+      REAL grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm)
+      REAL te1dt(llm),te2dt(llm),te3dt(llm)
+      REAL deltapres(ijb_u:ije_u,llm)
+
+      INTEGER l,ij
+
+      REAL  SSUM
+      integer :: ijb,ije
+      
+      LOGICAl,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+      PRINT *,"----> calldissip"
+      IF (first) THEN
+        CALL dissip_allocate
+        first=.FALSE.
+      ENDIF
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+         te1dt(l) = tetaudiv(l) * dtdiss
+         te2dt(l) = tetaurot(l) * dtdiss
+         te3dt(l) = tetah(l)    * dtdiss
+      ENDDO
+c$OMP END DO NOWAIT
+c      CALL initial0( ijp1llm, du )
+c      CALL initial0( ijmllm , dv )
+c      CALL initial0( ijp1llm, dh )
+     
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+        du(ijb:ije,l)=0
+        dh(ijb:ije,l)=0
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+        dv(ijb:ije,l)=0
+      ENDDO
+c$OMP END DO NOWAIT
+     
+c-----------------------------------------------------------------------
+c   Calcul de la dissipation:
+c   -------------------------
+
+c   Calcul de la partie   grad  ( div ) :
+c   -------------------------------------
+      
+     
+      
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+         CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+!         CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ENDIF
+
+#ifdef DEBUG_IO    
+      call WriteField_u('gdx',gdx)
+      call WriteField_v('gdy',gdy)
+#endif
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+         if (pole_nord) then
+           DO ij = 1, iip1
+              gdx(     ij ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO ij = 1, iip1
+              gdx(ij+ip1jm,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_nord) ijb=ij_begin+iip1
+         DO ij = ijb,ije
+            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+         ENDDO
+
+         if (pole_nord) ijb=ij_begin
+         DO ij = ijb,ije
+            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+         ENDDO
+
+       ENDDO
+c$OMP END DO NOWAIT
+c   calcul de la partie   n X grad ( rot ):
+c   ---------------------------------------
+
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+         CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+!         CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
+      ENDIF
+
+#ifdef DEBUG_IO    
+      call WriteField_u('grx',grx)
+      call WriteField_v('gry',gry)
+#endif
+
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+         
+         if (pole_nord) then
+           DO ij = 1, iip1
+              grx(ij,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_nord) ijb=ij_begin+iip1
+         DO ij = ijb,ije
+            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+         ENDDO
+         
+         if (pole_nord) ijb=ij_begin
+         DO ij =  ijb, ije
+            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+         ENDDO
+      
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   calcul de la partie   div ( grad ):
+c   -----------------------------------
+
+        
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+    
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+       DO l = 1, llm
+          DO ij = ijb, ije
+            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+          ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+         CALL divgrad2_loc( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+!         CALL divgrad_p ( llm,teta, niterh, gdx        )
+      ENDIF
+
+#ifdef DEBUG_IO    
+      call WriteField_u('gdx',gdx)
+#endif
+
+
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1,llm
+         DO ij = ijb,ije
+            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dissip_mod.F90
===================================================================
--- LMDZ5/trunk/libf/dissip_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/dissip_mod.F90	(revision 1630)
@@ -0,0 +1,40 @@
+MODULE dissip_mod
+
+
+  
+CONTAINS
+
+  SUBROUTINE dissip_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  USE gradiv2_mod, ONLY : gradiv2_allocate
+  USE nxgraro2_mod, ONLY : nxgraro2_allocate
+  USE divgrad2_mod, ONLY : divgrad2_allocate
+  IMPLICIT NONE
+
+    CALL gradiv2_allocate
+    CALL nxgraro2_allocate
+    CALL divgrad2_allocate
+
+    
+  END SUBROUTINE dissip_allocate
+  
+  SUBROUTINE dissip_switch_dissip(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE gradiv2_mod,ONLY : gradiv2_switch_dissip
+  USE nxgraro2_mod,ONLY : nxgraro2_switch_dissip
+  USE divgrad2_mod,ONLY : divgrad2_switch_dissip
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL gradiv2_switch_dissip(dist)
+    CALL nxgraro2_switch_dissip(dist)
+    CALL divgrad2_switch_dissip(dist)
+    
+  END SUBROUTINE dissip_switch_dissip
+  
+END MODULE dissip_mod  
Index: LMDZ5/trunk/libf/disvert.F
===================================================================
--- LMDZ5/trunk/libf/disvert.F	(revision 1630)
+++ LMDZ5/trunk/libf/disvert.F	(revision 1630)
@@ -0,0 +1,194 @@
+!
+! $Id: disvert.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+#include "logic.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL pa,preff
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+       real zzz(1:llm+1)
+       real dzz(1:llm)
+      real zk,zkm1,dzk1,dzk2,k0,k1
+c
+      INTEGER l
+      REAL snorm,dsigmin
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) h           ! hauteur d'echelle 8.
+      READ(99,*) deltaz      ! epaiseur de la premiere couche 0.04
+      READ(99,*) beta        ! facteur d'acroissement en haut 1.3
+      READ(99,*) k0          ! nombre de couches dans la transition surf
+      READ(99,*) k1          ! nombre de couches dans la transition haute
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+      write(lunout,*)'h,alpha,k0,k1,beta'
+
+c     read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2
+
+      alpha=deltaz/tanh(1./k0)*2.
+      zkm1=0.
+      sig(1)=1.
+      do l=1,llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/h)
+     + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta))
+        zk=-h*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        write(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2
+        zkm1=zk
+      enddo
+
+      sig(llm+1)=0.
+
+c
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      WRITE(LUNOUT,*)'WARNING!!! Ancienne discretisation verticale'
+
+      if (ok_strato) then
+         if (llm==39) then
+            dsigmin=0.3
+         else if (llm==50) then
+            dsigmin=1.
+         else
+            WRITE(LUNOUT,*) 'ATTENTION discretisation z a ajuster'
+            dsigmin=1.
+         endif
+         WRITE(LUNOUT,*) 'Discretisation verticale DSIGMIN=',dsigmin
+      endif
+
+      h=7.
+      snorm  = 0.
+      DO l = 1, llm
+         x = 2.*asin(1.) * (REAL(l)-0.5) / REAL(llm+1)
+
+         IF (ok_strato) THEN
+           dsig(l) =(dsigmin + 7.0 * SIN(x)**2)
+     &            *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2        
+         ELSE
+           dsig(l) = 1.0 + 7.0 * SIN(x)**2
+         ENDIF
+
+         snorm = snorm + dsig(l)
+      ENDDO
+      snorm = 1./snorm
+      DO l = 1, llm
+         dsig(l) = dsig(l)*snorm
+      ENDDO
+      sig(llm+1) = 0.
+      DO l = llm, 1, -1
+         sig(l) = sig(l+1) + dsig(l)
+      ENDDO
+
+      ENDIF
+
+
+      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
+c   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+c
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+cc
+ccc    ap(l) = 0.
+ccc    bp(l) = sig(l)
+
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+c
+      ENDDO
+
+      bp(1)=1.
+      ap(1)=0.
+
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      write(lunout,*)' BP '
+      write(lunout,*)  bp
+      write(lunout,*)' AP '
+      write(lunout,*)  ap
+
+      write(lunout,*)
+     .'Niveaux de pressions approximatifs aux centres des'
+      write(lunout,*)'couches calcules pour une pression de surface =',
+     .                 preff
+      write(lunout,*)
+     .     'et altitudes equivalentes pour une hauteur d echelle de'
+      write(lunout,*)'8km'
+      DO l = 1, llm
+       dpres(l) = bp(l) - bp(l+1)
+       presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
+       write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),'    Z ~ ',
+     .        log(preff/presnivs(l))*8.
+     .  ,'   DZ ~ ',8.*log((ap(l)+bp(l)*preff)/
+     .       max(ap(l+1)+bp(l+1)*preff,1.e-10))
+      ENDDO
+
+      write(lunout,*)' PRESNIVS '
+      write(lunout,*)presnivs
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/diverg.F
===================================================================
--- LMDZ5/trunk/libf/diverg.F	(revision 1630)
+++ LMDZ5/trunk/libf/diverg.F	(revision 1630)
@@ -0,0 +1,85 @@
+!
+! $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 10 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
+  10  CONTINUE
+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: LMDZ5/trunk/libf/diverg_gam.F
===================================================================
--- LMDZ5/trunk/libf/diverg_gam.F	(revision 1630)
+++ LMDZ5/trunk/libf/diverg_gam.F	(revision 1630)
@@ -0,0 +1,80 @@
+!
+! $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 10 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
+  10  CONTINUE
+c
+
+       RETURN
+       END
Index: LMDZ5/trunk/libf/diverg_gam_loc.F
===================================================================
--- LMDZ5/trunk/libf/diverg_gam_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/diverg_gam_loc.F	(revision 1630)
@@ -0,0 +1,98 @@
+      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
+      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 10 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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+c
+
+       RETURN
+       END
Index: LMDZ5/trunk/libf/diverg_gam_p.F
===================================================================
--- LMDZ5/trunk/libf/diverg_gam_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/diverg_gam_p.F	(revision 1630)
@@ -0,0 +1,97 @@
+      SUBROUTINE diverg_gam_p(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
+      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
+      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 10 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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+c
+
+       RETURN
+       END
Index: LMDZ5/trunk/libf/diverg_p.F
===================================================================
--- LMDZ5/trunk/libf/diverg_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/diverg_p.F	(revision 1630)
@@ -0,0 +1,106 @@
+      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
+      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 10 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
+
+
+  10  CONTINUE
+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: LMDZ5/trunk/libf/divergf.F
===================================================================
--- LMDZ5/trunk/libf/divergf.F	(revision 1630)
+++ LMDZ5/trunk/libf/divergf.F	(revision 1630)
@@ -0,0 +1,85 @@
+!
+! $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 10 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
+  10  CONTINUE
+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: LMDZ5/trunk/libf/divergf_loc.F
===================================================================
--- LMDZ5/trunk/libf/divergf_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/divergf_loc.F	(revision 1630)
@@ -0,0 +1,118 @@
+      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
+      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 10 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
+        
+  10    CONTINUE
+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: LMDZ5/trunk/libf/divergf_p.F
===================================================================
--- LMDZ5/trunk/libf/divergf_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/divergf_p.F	(revision 1630)
@@ -0,0 +1,115 @@
+      SUBROUTINE divergf_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
+      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
+      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 10 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
+        
+  10    CONTINUE
+c$OMP END DO NOWAIT
+
+c
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        
+        CALL filtreg_p( div,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: LMDZ5/trunk/libf/divergst.F
===================================================================
--- LMDZ5/trunk/libf/divergst.F	(revision 1630)
+++ LMDZ5/trunk/libf/divergst.F	(revision 1630)
@@ -0,0 +1,62 @@
+!
+! $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 10 l = 1,klevel
+c
+      DO 1 ij = iip2, ip1jm - 1
+      div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
+   1  CONTINUE
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      div( ij,l ) = div( ij + iim,l )
+   3  CONTINUE
+c
+c     ....  calcul  aux poles  .....
+c
+c
+      DO 5 i  = 1,iim
+      aiy1(i)= y(i,l)
+      aiy2(i)= y(i+ip1jmi1,l)
+   5  CONTINUE
+      sumypn = SSUM ( iim,aiy1,1 )
+      sumyps = SSUM ( iim,aiy2,1 )
+      DO 7 i = 1,iip1
+      div(     i    , l ) = - sumypn/iim
+      div( i + ip1jm, l ) =   sumyps/iim
+   7  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/divgrad.F
===================================================================
--- LMDZ5/trunk/libf/divgrad.F	(revision 1630)
+++ LMDZ5/trunk/libf/divgrad.F	(revision 1630)
@@ -0,0 +1,56 @@
+!
+! $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"
+#include "logic.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 10 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 5 l = 1,klevel
+      DO 4  ij = 1, ip1jmp1
+      divgra( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/divgrad2.F
===================================================================
--- LMDZ5/trunk/libf/divgrad2.F	(revision 1630)
+++ LMDZ5/trunk/libf/divgrad2.F	(revision 1630)
@@ -0,0 +1,79 @@
+!
+! $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: LMDZ5/trunk/libf/divgrad2_loc.F
===================================================================
--- LMDZ5/trunk/libf/divgrad2_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/divgrad2_loc.F	(revision 1630)
@@ -0,0 +1,120 @@
+      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
+      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) :: 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: LMDZ5/trunk/libf/divgrad2_mod.F90
===================================================================
--- LMDZ5/trunk/libf/divgrad2_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/divgrad2_mod.F90	(revision 1630)
@@ -0,0 +1,33 @@
+MODULE divgrad2_mod
+
+  REAL,POINTER,SAVE ::  divgra( :,: )
+  
+CONTAINS
+
+  SUBROUTINE divgrad2_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(divgra,llm,d)
+
+    
+  END SUBROUTINE divgrad2_allocate
+  
+  SUBROUTINE divgrad2_switch_dissip(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(divgra,distrib_dissip,dist)
+
+
+  END SUBROUTINE divgrad2_switch_dissip
+  
+END MODULE divgrad2_mod  
Index: LMDZ5/trunk/libf/divgrad2_p.F
===================================================================
--- LMDZ5/trunk/libf/divgrad2_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/divgrad2_p.F	(revision 1630)
@@ -0,0 +1,120 @@
+      SUBROUTINE divgrad2_p ( 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
+      USE times
+      USE mod_hallo
+      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_out( ip1jmp1,klevel)
+      REAL,SAVE :: divgra( ip1jmp1,llm)
+
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+      Type(Request) :: request_dissip
+      INTEGER ijb,ije
+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(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      CALL laplacien_p( 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(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+
+c$OMP BARRIER
+
+
+       CALL laplacien_gam_p ( 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(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      CALL laplacien_p ( 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: LMDZ5/trunk/libf/divgrad_p.F
===================================================================
--- LMDZ5/trunk/libf/divgrad_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/divgrad_p.F	(revision 1630)
@@ -0,0 +1,91 @@
+      SUBROUTINE divgrad_p (klevel,h, lh, divgra_out )
+      USE parallel
+      USE times
+      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"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra_out( ip1jmp1,klevel )
+      REAL,SAVE :: divgra( ip1jmp1,llm )
+
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+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
+      DO 10 iter = 1,lh
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1  )
+
+c      call exchange_Hallo(divgra,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(divgra,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER       
+      CALL    grad_p (klevel,divgra, ghx  , ghy          )
+
+c$OMP BARRIER
+c$OMP MASTER   
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(ghy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER            
+
+      CALL  diverg_p (klevel,  ghx , ghy  , divgra       )
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1)
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,klevel
+      DO 4  ij = ijb, ije
+      divgra_out( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dteta1_loc.F
===================================================================
--- LMDZ5/trunk/libf/dteta1_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/dteta1_loc.F	(revision 1630)
@@ -0,0 +1,91 @@
+      SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
+      USE parallel
+      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"
+#include "logic.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 5 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 1  ij = ijb, ije - 1
+        hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
+   1  CONTINUE
+
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+CDIR$ IVDEP
+      DO 2 ij = ijb+iip1-1, ije, iip1
+        hbxu( ij, l ) = hbxu( ij - iim, l )
+   2  CONTINUE
+
+      ijb=ij_begin-iip1
+      if (pole_nord) ijb=ij_begin
+      
+      DO 3 ij = ijb,ije
+        hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
+   3  CONTINUE
+
+       if (.not. pole_sud) then
+	  hbxu(ije+1:ije+iip1,l) = 0
+	  hbyv(ije+1:ije+iip1,l) = 0
+	endif
+	
+   5  CONTINUE
+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: LMDZ5/trunk/libf/dudv1_loc.F
===================================================================
--- LMDZ5/trunk/libf/dudv1_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/dudv1_loc.F	(revision 1630)
@@ -0,0 +1,65 @@
+      SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
+      USE parallel
+      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 10 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 2  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)   )
+   2  CONTINUE
+   
+ 
+c
+      if (pole_nord) ijb=ij_begin
+      
+      DO 3 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)  )
+   3  CONTINUE
+c
+c    .... correction  pour  dv( 1,j,l )  .....
+c    ....   dv(1,j,l)= dv(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 4 ij = ijb, ije, iip1
+      dv( ij,l ) = dv( ij + iim, l )
+   4  CONTINUE
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dudv2_loc.F
===================================================================
--- LMDZ5/trunk/libf/dudv2_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/dudv2_loc.F	(revision 1630)
@@ -0,0 +1,70 @@
+      SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
+      USE parallel
+      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"
+#include "comvert.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 5 l = 1,llm
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+      DO 2  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)
+   2  CONTINUE
+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 3 ij = ijb+iip1-1, ije, iip1
+      du( ij,l ) = du( ij - iim,l )
+   3  CONTINUE
+c
+c
+      if (pole_nord) ijb=ijb-iip1
+
+      DO 4 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 )
+   4  CONTINUE
+c
+   5  CONTINUE
+c$OMP END DO NOWAIT 
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dump2d.F
===================================================================
--- LMDZ5/trunk/libf/dump2d.F	(revision 1630)
+++ LMDZ5/trunk/libf/dump2d.F	(revision 1630)
@@ -0,0 +1,46 @@
+!
+! $Id: dump2d.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      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).GT.zllm) THEN
+               illm=i
+               jllm=j
+               zllm=z(i,j)
+            ENDIF
+            IF(z(i,j).LT.zmin) THEN
+               imin=i
+               jmin=j
+               zmin=z(i,j)
+            ENDIF
+         ENDDO
+      ENDDO
+
+      PRINT*,'MIN: ',zmin
+      PRINT*,'MAX: ',zllm
+
+      IF(zllm.GT.zmin) THEN
+       DO j=1,jm
+        WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
+       ENDDO
+      ENDIF
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dynetat0.F
===================================================================
--- LMDZ5/trunk/libf/dynetat0.F	(revision 1630)
+++ LMDZ5/trunk/libf/dynetat0.F	(revision 1630)
@@ -0,0 +1,379 @@
+!
+! $Header$
+!
+      SUBROUTINE dynetat0(fichnom,vcov,ucov,
+     .                    teta,q,masse,ps,phis,time)
+      USE infotrac
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / L.Fairhead
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Lecture de l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "logic.h"
+
+c   Arguments:
+c   ----------
+
+      CHARACTER*(*) fichnom
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+
+      REAL time
+
+c   Variables 
+c
+      INTEGER length,iq
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid
+
+c-----------------------------------------------------------------------
+c  Ouverture NetCDF du fichier etat initial
+
+      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier start.nc'
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+
+      im         = tab_cntrl(1)
+      jm         = tab_cntrl(2)
+      lllm       = tab_cntrl(3)
+      day_ref    = tab_cntrl(4)
+      annee_ref  = tab_cntrl(5)
+      rad        = tab_cntrl(6)
+      omeg       = tab_cntrl(7)
+      g          = tab_cntrl(8)
+      cpp        = tab_cntrl(9)
+      kappa      = tab_cntrl(10)
+      daysec     = tab_cntrl(11)
+      dtvr       = tab_cntrl(12)
+      etot0      = tab_cntrl(13)
+      ptot0      = tab_cntrl(14)
+      ztot0      = tab_cntrl(15)
+      stot0      = tab_cntrl(16)
+      ang0       = tab_cntrl(17)
+      pa         = tab_cntrl(18)
+      preff      = tab_cntrl(19)
+c
+      clon       = tab_cntrl(20)
+      clat       = tab_cntrl(21)
+      grossismx  = tab_cntrl(22)
+      grossismy  = tab_cntrl(23)
+c
+      IF ( tab_cntrl(24).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+c        dzoomx   = tab_cntrl(25)
+c        dzoomy   = tab_cntrl(26)
+c        taux     = tab_cntrl(28)
+c        tauy     = tab_cntrl(29)
+      ELSE
+        fxyhypb = . FALSE .
+        ysinus  = . FALSE .
+        IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. 
+      ENDIF
+
+      day_ini = tab_cntrl(30)
+      itau_dyn = tab_cntrl(31)
+c   .................................................................
+c
+c
+      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+      IF(   im.ne.iim           )  THEN
+          PRINT 1,im,iim
+          STOP
+      ELSE  IF( jm.ne.jjm       )  THEN
+          PRINT 2,jm,jjm
+          STOP
+      ELSE  IF( lllm.ne.llm     )  THEN
+          PRINT 3,lllm,llm
+          STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour rlatv"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "aire", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <aire> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <aire>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phis)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <temps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, time)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee <temps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ucov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ucov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ucov>"
+         CALL abort
+      ENDIF
+ 
+      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <vcov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, vcov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <vcov>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <teta> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, teta)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <teta>"
+         CALL abort
+      ENDIF
+
+
+      DO iq=1,nqtot
+        ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent"
+           PRINT*, "          Il est donc initialise a zero"
+           q(:,:,iq)=0.
+        ELSE
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq))
+#endif
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "dynetat0: Lecture echouee pour "//tname(iq)
+             CALL abort
+          ENDIF
+        ENDIF
+      ENDDO
+
+      ierr = NF_INQ_VARID (nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <masse> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, masse)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <masse>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ps)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_CLOSE(nid)
+
+       day_ini=day_ini+INT(time)
+       time=time-INT(time)
+
+  1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur  dtinteg =',i4//)
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dynetat0_loc.F
===================================================================
--- LMDZ5/trunk/libf/dynetat0_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/dynetat0_loc.F	(revision 1630)
@@ -0,0 +1,412 @@
+!
+! $Header$
+!
+      SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,
+     .                    teta,q,masse,ps,phis,time)
+      USE infotrac
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / L.Fairhead
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Lecture de l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "logic.h"
+
+c   Arguments:
+c   ----------
+
+      CHARACTER*(*) fichnom
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+      REAL teta(ijb_u:ije_u,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot),masse(ijb_u:ije_u,llm)
+      REAL ps(ijb_u:ije_u),phis(ijb_u:ije_u)
+
+      REAL time
+
+c   Variables 
+c
+      INTEGER length,iq
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid
+      REAL,ALLOCATABLE :: vcov_glo(:,:),ucov_glo(:,:),teta_glo(:,:)
+      REAL,ALLOCATABLE :: q_glo(:,:),masse_glo(:,:),ps_glo(:)
+      REAL,ALLOCATABLE :: phis_glo(:)
+
+c-----------------------------------------------------------------------
+c  Ouverture NetCDF du fichier etat initial
+
+      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier start.nc'
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+
+      im         = tab_cntrl(1)
+      jm         = tab_cntrl(2)
+      lllm       = tab_cntrl(3)
+      day_ref    = tab_cntrl(4)
+      annee_ref  = tab_cntrl(5)
+      rad        = tab_cntrl(6)
+      omeg       = tab_cntrl(7)
+      g          = tab_cntrl(8)
+      cpp        = tab_cntrl(9)
+      kappa      = tab_cntrl(10)
+      daysec     = tab_cntrl(11)
+      dtvr       = tab_cntrl(12)
+      etot0      = tab_cntrl(13)
+      ptot0      = tab_cntrl(14)
+      ztot0      = tab_cntrl(15)
+      stot0      = tab_cntrl(16)
+      ang0       = tab_cntrl(17)
+      pa         = tab_cntrl(18)
+      preff      = tab_cntrl(19)
+c
+      clon       = tab_cntrl(20)
+      clat       = tab_cntrl(21)
+      grossismx  = tab_cntrl(22)
+      grossismy  = tab_cntrl(23)
+c
+      IF ( tab_cntrl(24).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+c        dzoomx   = tab_cntrl(25)
+c        dzoomy   = tab_cntrl(26)
+c        taux     = tab_cntrl(28)
+c        tauy     = tab_cntrl(29)
+      ELSE
+        fxyhypb = . FALSE .
+        ysinus  = . FALSE .
+        IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. 
+      ENDIF
+
+      day_ini = tab_cntrl(30)
+      itau_dyn = tab_cntrl(31)
+c   .................................................................
+c
+c
+      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+      IF(   im.ne.iim           )  THEN
+          PRINT 1,im,iim
+          STOP
+      ELSE  IF( jm.ne.jjm       )  THEN
+          PRINT 2,jm,jjm
+          STOP
+      ELSE  IF( lllm.ne.llm     )  THEN
+          PRINT 3,lllm,llm
+          STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour rlatv"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "aire", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <aire> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <aire>"
+         CALL abort
+      ENDIF
+      
+      ALLOCATE(phis_glo(ip1jmp1))
+      
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phis_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+      phis(ijb_u:ije_u)=phis_glo(ijb_u:ije_u)
+      DEALLOCATE(phis_glo)
+
+      ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <temps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, time)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee <temps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ucov> est absent"
+         CALL abort
+      ENDIF
+      
+      ALLOCATE(ucov_glo(ip1jmp1,llm))
+      
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ucov_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ucov>"
+         CALL abort
+      ENDIF
+
+      ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
+      DEALLOCATE(ucov_glo)
+      ALLOCATE(vcov_glo(ip1jm,llm))
+      
+      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <vcov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, vcov_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <vcov>"
+         CALL abort
+      ENDIF
+      vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
+      DEALLOCATE(vcov_glo)
+      ALLOCATE(teta_glo(ip1jmp1,llm))
+
+      ierr = NF_INQ_VARID (nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <teta> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, teta_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <teta>"
+         CALL abort
+      ENDIF
+
+      teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
+      DEALLOCATE(teta_glo)
+      ALLOCATE(q_glo(ip1jmp1,llm))
+
+
+      DO iq=1,nqtot
+        ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent"
+           PRINT*, "          Il est donc initialise a zero"
+           q_glo(:,:)=0.
+        ELSE
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_glo)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, q_glo)
+#endif
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "dynetat0: Lecture echouee pour "//tname(iq)
+             CALL abort
+          ENDIF
+        ENDIF
+        q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
+      ENDDO
+
+      DEALLOCATE(q_glo)
+      ALLOCATE(masse_glo(ip1jmp1,llm))
+
+      ierr = NF_INQ_VARID (nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <masse> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, masse_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <masse>"
+         CALL abort
+      ENDIF
+      masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
+      DEALLOCATE(masse_glo)
+      ALLOCATE(ps_glo(ip1jmp1))
+
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ps_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+
+      ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
+      DEALLOCATE(ps_glo)
+
+      ierr = NF_CLOSE(nid)
+
+       day_ini=day_ini+INT(time)
+       time=time-INT(time)
+
+  1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur  dtinteg =',i4//)
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/dynredem.F
===================================================================
--- LMDZ5/trunk/libf/dynredem.F	(revision 1630)
+++ LMDZ5/trunk/libf/dynredem.F	(revision 1630)
@@ -0,0 +1,741 @@
+!
+! $Id: dynredem.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+      SUBROUTINE dynredem0(fichnom,iday_end,phis)
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE infotrac
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(ip1jmp1)
+      CHARACTER*(*) fichnom
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+
+c-----------------------------------------------------------------------
+      modname='dynredem0'
+
+#ifdef CPP_IOIPSL
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+#else
+! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
+      yyears0=0
+      mmois0=1
+      jjour0=1
+#endif        
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  =  REAL(iim)
+       tab_cntrl(2)  =  REAL(jjm)
+       tab_cntrl(3)  =  REAL(llm)
+       tab_cntrl(4)  =  REAL(day_ref)
+       tab_cntrl(5)  =  REAL(annee_ref)
+       tab_cntrl(6)  = rad
+       tab_cntrl(7)  = omeg
+       tab_cntrl(8)  = g
+       tab_cntrl(9)  = cpp
+       tab_cntrl(10) = kappa
+       tab_cntrl(11) = daysec
+       tab_cntrl(12) = dtvr
+       tab_cntrl(13) = etot0
+       tab_cntrl(14) = ptot0
+       tab_cntrl(15) = ztot0
+       tab_cntrl(16) = stot0
+       tab_cntrl(17) = ang0
+       tab_cntrl(18) = pa
+       tab_cntrl(19) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(24) = 1.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = taux
+       tab_cntrl(29) = tauy
+      ELSE
+       tab_cntrl(24) = 0.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = 0.
+       tab_cntrl(29) = 0.
+       IF( ysinus )  tab_cntrl(27) = 1.
+      ENDIF
+
+       tab_cntrl(30) =  REAL(iday_end)
+       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nqtot.GE.1) THEN
+      DO iq=1,nqtot
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+      ENDIF
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      RETURN
+      END
+      SUBROUTINE dynredem1(fichnom,time,
+     .                     vcov,ucov,teta,q,masse,ps)
+      USE infotrac
+      USE control_mod
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+
+      INTEGER l
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL q(ip1jmp1,llm,nqtot)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid, nid_trac, nvarid_trac
+      REAL trac_tmp(ip1jmp1,llm)      
+      INTEGER ierr, ierr_file 
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      modname = 'dynredem1'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable temps n est pas definie'
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
+#endif
+
+      IF (config_inca /= 'none') THEN
+! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc
+         ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
+         IF (ierr_file .NE.NF_NOERR) THEN
+            write(6,*)' Pb d''ouverture du fichier start_trac.nc'
+            write(6,*)' ierr = ', ierr_file 
+         ENDIF
+      END IF
+
+      IF(nqtot.GE.1) THEN
+      do iq=1,nqtot 
+
+         IF (config_inca == 'none') THEN
+            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+            IF (ierr .NE. NF_NOERR) THEN
+               PRINT*, "Variable  tname(iq) n est pas definie"
+               CALL abort
+            ENDIF
+#ifdef NC_DOUBLE
+            ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+            ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+        ELSE ! config_inca = 'chem' ou 'aero'
+! lecture de la valeur du traceur dans start_trac.nc
+           IF (ierr_file .ne. 2) THEN
+             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, tname(iq),"est absent de start_trac.nc"
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+#ifdef NC_DOUBLE
+                ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+                ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+                
+             ELSE
+                PRINT*, tname(iq), "est present dans start_trac.nc"
+#ifdef NC_DOUBLE
+               ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
+#else
+               ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp)
+#endif
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Lecture echouee pour", tname(iq)
+                   CALL abort
+                ENDIF
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+#ifdef NC_DOUBLE
+                ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp)
+#else
+                ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp)
+#endif
+               
+             ENDIF ! IF (ierr .NE. NF_NOERR)
+! fin lecture du traceur
+          ELSE                  ! si il n'y a pas de fichier start_trac.nc
+!             print *, 'il n y a pas de fichier start_trac'
+             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, "Variable  tname(iq) n est pas definie"
+                CALL abort
+             ENDIF
+#ifdef NC_DOUBLE
+             ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+             ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+          ENDIF ! (ierr_file .ne. 2)
+       END IF   ! config_inca
+      
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
+#endif
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/dynredem_loc.F
===================================================================
--- LMDZ5/trunk/libf/dynredem_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/dynredem_loc.F	(revision 1630)
@@ -0,0 +1,683 @@
+!
+! $Id: dynredem_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+      SUBROUTINE dynredem0_loc(fichnom,iday_end,phis)
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE parallel
+      USE mod_hallo
+      USE infotrac
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(ijb_u:ije_u)
+      CHARACTER*(*) fichnom
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+      REAL :: phis_glo(ip1jmp1)
+      
+      CALL Gather_field_u(phis,phis_glo,1)
+      
+      
+c-----------------------------------------------------------------------
+      if (mpi_rank==0) then
+      
+      modname='dynredem0_p'
+
+#ifdef CPP_IOIPSL
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+#else
+! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
+      yyears0=0
+      mmois0=1
+      jjour0=1
+#endif                
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  =  REAL(iim)
+       tab_cntrl(2)  =  REAL(jjm)
+       tab_cntrl(3)  =  REAL(llm)
+       tab_cntrl(4)  =  REAL(day_ref)
+       tab_cntrl(5)  =  REAL(annee_ref)
+       tab_cntrl(6)  = rad
+       tab_cntrl(7)  = omeg
+       tab_cntrl(8)  = g
+       tab_cntrl(9)  = cpp
+       tab_cntrl(10) = kappa
+       tab_cntrl(11) = daysec
+       tab_cntrl(12) = dtvr
+       tab_cntrl(13) = etot0
+       tab_cntrl(14) = ptot0
+       tab_cntrl(15) = ztot0
+       tab_cntrl(16) = stot0
+       tab_cntrl(17) = ang0
+       tab_cntrl(18) = pa
+       tab_cntrl(19) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(24) = 1.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = taux
+       tab_cntrl(29) = tauy
+      ELSE
+       tab_cntrl(24) = 0.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = 0.
+       tab_cntrl(29) = 0.
+       IF( ysinus )  tab_cntrl(27) = 1.
+      ENDIF
+
+       tab_cntrl(30) =  REAL(iday_end)
+       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis_glo)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+
+      DO iq=1,nqtot
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      endif  ! mpi_rank==0
+      RETURN
+      END
+      SUBROUTINE dynredem1_loc(fichnom,time,
+     .                     vcov,ucov,teta,q,masse,ps)
+      USE parallel
+      USE mod_hallo
+      USE infotrac
+      USE control_mod
+      USE dynredem_mod
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+
+      INTEGER l
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
+      REAL teta(ijb_u:ije_u,llm)                   
+      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
+      REAL q(ijb_u:ije_u,llm,nqtot)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid, nid_trac, nvarid_trac
+      REAL trac_tmp(ijb_u:ije_u,llm)      
+      INTEGER ierr, ierr_file
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+      REAL,SAVE,ALLOCATABLE :: ucov_glo(:,:),vcov_glo(:,:),teta_glo(:,:)
+      REAL,SAVE,ALLOCATABLE :: masse_glo(:,:),ps_glo(:),q_glo(:,:)
+      LOGICAL,SAVE :: exist_file
+      INTEGER,SAVE :: ierr_var
+      
+!      call Gather_Field(ucov,ip1jmp1,llm,0)
+!      call Gather_Field(vcov,ip1jm,llm,0)
+!      call Gather_Field(teta,ip1jmp1,llm,0)
+!      call Gather_Field(masse,ip1jmp1,llm,0)
+!      call Gather_Field(ps,ip1jmp1,1,0)
+      
+!      do iq=1,nqtot
+!        call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+ !     enddo
+      
+!$OMP MASTER      
+      if (mpi_rank==0) then
+      modname = 'dynredem1'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable temps n est pas definie'
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+      endif
+!$OMP END MASTER
+
+!     
+      CALL dynredem_write_u(nid,"ucov",ucov,llm)
+      CALL dynredem_write_v(nid,"vcov",vcov,llm)
+      CALL dynredem_write_u(nid,"teta",teta,llm)
+      CALL dynredem_write_u(nid,"masse",masse,llm)
+      CALL dynredem_write_u(nid,"ps",ps,1)
+
+      IF (config_inca == 'none') THEN
+        DO iq=1,nqtot
+          CALL dynredem_write_u(nid,tname(iq),q(:,:,iq),llm)
+        ENDDO
+      ELSE
+        
+!$OMP MASTER
+        INQUIRE(FILE="start_trac.nc", EXIST=exist_file) 
+        PRINT *, "EXIST", exist_file
+!$OMP END MASTER
+!$OMP BARRIER
+      
+        IF (exist_file) THEN
+!$OMP MASTER
+          ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
+          IF (ierr_file .NE.NF_NOERR) THEN
+            WRITE(6,*)' Pb d''ouverture du fichier start_trac.nc'
+            WRITE(6,*)' ierr = ', ierr_file 
+          ENDIF
+!$OMP END MASTER
+
+          DO iq=1,nqtot
+
+!$OMP MASTER      
+            ierr_var = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
+!$OMP END MASTER
+!$OMP BARRIER
+            IF (ierr == NF_NOERR) THEN
+              CALL dynredem_read_u(nid_trac,tname(iq),q(:,:,iq),llm) 
+            ENDIF
+            CALL dynredem_write_u(nid,tname(iq),q(:,:,iq),llm)  
+          ENDDO          
+          
+        ELSE ! pas de fichier start_tract
+          DO iq=1,nqtot
+            CALL dynredem_write_u(nid,tname(iq),q(:,:,iq),llm)
+          ENDDO
+        ENDIF 
+      ENDIF
+
+
+!$OMP MASTER
+      IF (mpi_rank==0) THEN
+        ierr = NF_CLOSE(nid)
+      ENDIF ! mpi_rank==0
+!$OMP END MASTER
+      
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/dynredem_mod.F90
===================================================================
--- LMDZ5/trunk/libf/dynredem_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/dynredem_mod.F90	(revision 1630)
@@ -0,0 +1,213 @@
+MODULE dynredem_mod
+
+
+
+
+
+CONTAINS
+
+  SUBROUTINE dynredem_write_u(ncid,id,var,ll)
+  USE dimensions
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+    INTEGER          :: ncid
+    CHARACTER(LEN=*) :: id
+    REAL             :: var(ijb_u:ije_u,ll)
+    REAL,ALLOCATABLE,SAVE  :: var_tmp(:,:)
+    REAL,ALLOCATABLE,SAVE  :: var_glo(:)
+    INTEGER          :: ll
+    INTEGER          :: count(4)
+    INTEGER          :: start(4)
+    INTEGER          :: l
+    INTEGER          :: nvarid
+    INTEGER          :: ierr
+    INCLUDE 'netcdf.inc'    
+    
+    count(:)=(/ iip1,jjp1,1,1 /)
+    start(:)=(/ 1,1,1,1 /)
+    
+!$OMP MASTER    
+   IF (mpi_rank==0) THEN
+     ierr = NF_INQ_VARID(ncid, id, nvarid)
+     IF (ierr .NE. NF_NOERR) THEN
+       PRINT*, "Variable "//id//" n est pas definie"
+       CALL abort
+     ENDIF
+   ENDIF
+!$OMP END MASTER
+ 
+    ll=size(var,2)
+
+!$OMP MASTER
+    ALLOCATE(var_tmp(ijb_u:ije_u,ll))
+    ALLOCATE(var_glo(ip1jmp1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,ll
+      var_tmp(:,l)=var(:,l)
+    ENDDO
+
+    DO l=1,ll
+      CALL gather_field_u(var_tmp(:,l),var_glo,1)
+       IF (mpi_rank==0) THEN
+   !$OMP MASTER
+        start(3)=l
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE (ncid,nvarid,start,count,var_glo)
+#else
+        ierr = NF_PUT_VARA_REAL (ncid,nvarid,start,count,var_glo)
+#endif
+   !$OMP END MASTER
+       ENDIF
+    ENDDO
+    
+  !$OMP BARRIER
+  !$OMP MASTER
+    DEALLOCATE(var_tmp)
+    DEALLOCATE(var_glo)
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE dynredem_write_u
+      
+  SUBROUTINE dynredem_write_v(ncid,id,var,ll)
+  USE dimensions
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+    INTEGER          :: ncid
+    CHARACTER(LEN=*) :: id
+    REAL             :: var(ijb_v:ije_v,ll)
+    REAL,ALLOCATABLE,SAVE  :: var_tmp(:,:)
+    REAL,ALLOCATABLE,SAVE  :: var_glo(:)
+    INTEGER          :: ll
+    INTEGER          :: count(4)
+    INTEGER          :: start(4)
+    INTEGER          :: l
+    INTEGER          :: nvarid
+    INTEGER          :: ierr
+    INCLUDE 'netcdf.inc'    
+    
+    count(:)=(/ iip1,jjm,1,1 /)
+    start(:)=(/ 1,1,1,1 /)
+    
+!$OMP MASTER    
+   IF (mpi_rank==0) THEN
+     ierr = NF_INQ_VARID(ncid, id, nvarid)
+     IF (ierr .NE. NF_NOERR) THEN
+       PRINT*, "Variable "//id//" n est pas definie"
+       CALL abort
+     ENDIF
+   ENDIF
+!$OMP END MASTER
+ 
+    ll=size(var,2)
+
+!$OMP MASTER
+    ALLOCATE(var_tmp(ijb_v:ije_v,ll))
+    ALLOCATE(var_glo(ip1jm))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,ll
+      var_tmp(:,l)=var(:,l)
+    ENDDO
+
+    DO l=1,ll
+      CALL gather_field_v(var_tmp(:,l),var_glo,1)
+       IF (mpi_rank==0) THEN
+   !$OMP MASTER
+        start(3)=l
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE (ncid,nvarid,start,count,var_glo)
+#else
+        ierr = NF_PUT_VARA_REAL (ncid,nvarid,start,count,var_glo)
+#endif
+   !$OMP END MASTER
+       ENDIF
+    ENDDO
+    
+  !$OMP BARRIER
+  !$OMP MASTER
+    DEALLOCATE(var_tmp)
+    DEALLOCATE(var_glo)
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE dynredem_write_v
+
+  SUBROUTINE dynredem_read_u(ncid,id,var,ll)
+  USE dimensions
+  USE parallel
+  USE mod_hallo
+  IMPLICIT NONE
+    INTEGER          :: ncid
+    CHARACTER(LEN=*) :: id
+    REAL             :: var(ijb_u:ije_u,ll)
+    REAL,ALLOCATABLE,SAVE  :: var_tmp(:,:)
+    REAL,ALLOCATABLE,SAVE  :: var_glo(:)
+    INTEGER          :: ll
+    INTEGER          :: count(4)
+    INTEGER          :: start(4)
+    INTEGER          :: l
+    INTEGER          :: nvarid
+    INTEGER          :: ierr
+    INCLUDE 'netcdf.inc'    
+    
+    count(:)=(/ iip1,jjp1,1,1 /)
+    start(:)=(/ 1,1,1,1 /)
+    
+!$OMP MASTER    
+   IF (mpi_rank==0) THEN
+     ierr = NF_INQ_VARID(ncid, id, nvarid)
+     IF (ierr .NE. NF_NOERR) THEN
+       PRINT*, "Variable "//id//" n est pas definie"
+       CALL abort
+     ENDIF
+   ENDIF
+!$OMP END MASTER
+ 
+    ll=size(var,2)
+
+!$OMP MASTER
+    ALLOCATE(var_tmp(ijb_u:ije_u,ll))
+    ALLOCATE(var_glo(ip1jmp1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+    DO l=1,ll
+       IF (mpi_rank==0) THEN
+   !$OMP MASTER
+        start(3)=l
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE (ncid,nvarid,start,count,var_glo)
+#else
+        ierr = NF_GET_VARA_REAL (ncid,nvarid,start,count,var_glo)
+#endif
+   !$OMP END MASTER
+       ENDIF
+       CALL scatter_field_u(var_glo,var_tmp(:,l),1)
+    ENDDO
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,ll
+      var(:,l)=var_tmp(:,l)
+    ENDDO
+    
+  !$OMP BARRIER
+  !$OMP MASTER
+    DEALLOCATE(var_tmp)
+    DEALLOCATE(var_glo)
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE dynredem_read_u    
+  
+END MODULE dynredem_mod   
+    
+    
Index: LMDZ5/trunk/libf/dynredem_p.F
===================================================================
--- LMDZ5/trunk/libf/dynredem_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/dynredem_p.F	(revision 1630)
@@ -0,0 +1,769 @@
+!
+! $Id: dynredem_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+      SUBROUTINE dynredem0_p(fichnom,iday_end,phis)
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE parallel
+      USE infotrac
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(ip1jmp1)
+      CHARACTER*(*) fichnom
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+c-----------------------------------------------------------------------
+      if (mpi_rank==0) then
+      
+      modname='dynredem0_p'
+
+#ifdef CPP_IOIPSL
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+#else
+! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
+      yyears0=0
+      mmois0=1
+      jjour0=1
+#endif                
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  =  REAL(iim)
+       tab_cntrl(2)  =  REAL(jjm)
+       tab_cntrl(3)  =  REAL(llm)
+       tab_cntrl(4)  =  REAL(day_ref)
+       tab_cntrl(5)  =  REAL(annee_ref)
+       tab_cntrl(6)  = rad
+       tab_cntrl(7)  = omeg
+       tab_cntrl(8)  = g
+       tab_cntrl(9)  = cpp
+       tab_cntrl(10) = kappa
+       tab_cntrl(11) = daysec
+       tab_cntrl(12) = dtvr
+       tab_cntrl(13) = etot0
+       tab_cntrl(14) = ptot0
+       tab_cntrl(15) = ztot0
+       tab_cntrl(16) = stot0
+       tab_cntrl(17) = ang0
+       tab_cntrl(18) = pa
+       tab_cntrl(19) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(24) = 1.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = taux
+       tab_cntrl(29) = tauy
+      ELSE
+       tab_cntrl(24) = 0.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = 0.
+       tab_cntrl(29) = 0.
+       IF( ysinus )  tab_cntrl(27) = 1.
+      ENDIF
+
+       tab_cntrl(30) =  REAL(iday_end)
+       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+
+      DO iq=1,nqtot
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      endif  ! mpi_rank==0
+      RETURN
+      END
+      SUBROUTINE dynredem1_p(fichnom,time,
+     .                     vcov,ucov,teta,q,masse,ps)
+      USE parallel
+      USE infotrac
+      USE control_mod
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+
+      INTEGER l
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL q(ip1jmp1,llm,nqtot)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid, nid_trac, nvarid_trac
+      REAL trac_tmp(ip1jmp1,llm)      
+      INTEGER ierr, ierr_file
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      logical exist_file
+
+      call Gather_Field(ucov,ip1jmp1,llm,0)
+      call Gather_Field(vcov,ip1jm,llm,0)
+      call Gather_Field(teta,ip1jmp1,llm,0)
+      call Gather_Field(masse,ip1jmp1,llm,0)
+      call Gather_Field(ps,ip1jmp1,1,0)
+      
+      do iq=1,nqtot
+        call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+      enddo
+      
+      
+      if (mpi_rank==0) then
+      
+      modname = 'dynredem1'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable temps n est pas definie'
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
+#endif
+
+      IF (config_inca /= 'none') THEN
+! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc
+         inquire(FILE="start_trac.nc", EXIST=exist_file) 
+         print *, "EXIST", exist_file
+         if (exist_file) then 
+            ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
+            IF (ierr_file .NE.NF_NOERR) THEN
+               write(6,*)' Pb d''ouverture du fichier start_trac.nc'
+               write(6,*)' ierr = ', ierr_file 
+            ENDIF
+         else
+            ierr_file = 2
+         endif
+      END IF
+
+      do iq=1,nqtot 
+
+         IF (config_inca == 'none') THEN
+            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+            IF (ierr .NE. NF_NOERR) THEN
+               PRINT*, "Variable  tname(iq) n est pas definie"
+               CALL abort
+            ENDIF
+#ifdef NC_DOUBLE
+            ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+            ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+        ELSE ! config_inca = 'chem' ou 'aero'
+! lecture de la valeur du traceur dans start_trac.nc
+           IF (ierr_file .ne. 2) THEN
+             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, tname(iq),"est absent de start_trac.nc"
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+#ifdef NC_DOUBLE
+                ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+                ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+                
+             ELSE
+                PRINT*, tname(iq), "est present dans start_trac.nc"
+#ifdef NC_DOUBLE
+               ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
+#else
+               ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp)
+#endif
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Lecture echouee pour", tname(iq)
+                   CALL abort
+                ENDIF
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+#ifdef NC_DOUBLE
+                ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp)
+#else
+                ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp)
+#endif
+               
+             ENDIF ! IF (ierr .NE. NF_NOERR)
+! fin lecture du traceur
+          ELSE                  ! si il n'y a pas de fichier start_trac.nc
+!             print *, 'il n y a pas de fichier start_trac'
+             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, "Variable  tname(iq) n est pas definie"
+                CALL abort
+             ENDIF
+#ifdef NC_DOUBLE
+             ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+             ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+          ENDIF ! (ierr_file .ne. 2)
+       END IF   ! config_inca
+      
+      ENDDO
+
+
+
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
+#endif
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+      endif ! mpi_rank==0
+      
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/ener.h
===================================================================
--- LMDZ5/trunk/libf/ener.h	(revision 1630)
+++ LMDZ5/trunk/libf/ener.h	(revision 1630)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'ener.h'
+
+      COMMON/ener/ang0,etot0,ptot0,ztot0,stot0,                          &
+     &            ang,etot,ptot,ztot,stot,rmsdpdt ,                      &
+     &            rmsv,gtot(llmm1)
+
+      REAL ang0,etot0,ptot0,ztot0,stot0,                                 &
+     &     ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot
+
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/enercin.F
===================================================================
--- LMDZ5/trunk/libf/enercin.F	(revision 1630)
+++ LMDZ5/trunk/libf/enercin.F	(revision 1630)
@@ -0,0 +1,98 @@
+!
+! $Header$
+!
+      SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i
+
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = iip2, ip1jm, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+
+      DO 3 i = 1, iim
+      ecinni(i) = vcov(    i  ,  l) * vcont(    i    ,l) * aire(   i   )
+      ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+   3  CONTINUE
+
+      ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+      ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+      DO 4 ij = 1,iip1
+      ecin(   ij     , l ) = ecinpn
+      ecin( ij+ ip1jm, l ) = ecinps
+   4  CONTINUE
+
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/enercin_loc.F
===================================================================
--- LMDZ5/trunk/libf/enercin_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/enercin_loc.F	(revision 1630)
@@ -0,0 +1,122 @@
+      SUBROUTINE enercin_loc ( vcov, ucov, vcont, ucont, ecin )
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ijb_v:ije_v,llm ),vcont( ijb_v:ije_v,llm )
+      REAL ucov( ijb_u:ije_u,llm ),ucont( ijb_u:ije_u,llm )
+      REAL ecin( ijb_u:ije_u,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i,ijb,ije
+
+      EXTERNAL    SSUM
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      IF (pole_nord) ijb=ij_begin+iip1
+      IF (pole_sud)  ije=ij_end-iip1
+      
+      DO 1  ij = ijb, ije -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = ijb, ije, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+      IF (pole_nord) THEN
+    
+        DO  i = 1, iim
+         ecinni(i) = vcov(    i  ,  l) * 
+     *               vcont(    i    ,l) * aire(   i   )
+        ENDDO
+
+        ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+
+        DO ij = 1,iip1
+          ecin(   ij     , l ) = ecinpn
+        ENDDO
+   
+      ENDIF
+
+      IF (pole_sud) THEN
+    
+        DO  i = 1, iim
+         ecinsi(i) = vcov(i+ip1jmi1,l)* 
+     *               vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+        ENDDO
+
+        ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+        DO ij = 1,iip1
+          ecin( ij+ ip1jm, l ) = ecinps
+        ENDDO
+   
+      ENDIF
+
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/etat0_netcdf.F
===================================================================
--- LMDZ5/trunk/libf/etat0_netcdf.F	(revision 1630)
+++ LMDZ5/trunk/libf/etat0_netcdf.F	(revision 1630)
@@ -0,0 +1,817 @@
+!
+! $Id: etat0_netcdf.F 1379 2010-05-06 12:19:18Z lguez $
+!
+c
+c
+      SUBROUTINE etat0_netcdf (interbar, masque)
+#ifdef CPP_EARTH        
+      USE startvar
+      USE ioipsl
+      USE dimphy
+      USE control_mod
+      USE infotrac
+      USE fonte_neige_mod
+      USE pbl_surface_mod
+      USE phys_state_var_mod
+      USE filtreg_mod
+      use regr_lat_time_climoz_m, only: regr_lat_time_climoz
+      use conf_phys_m, only: conf_phys
+!     For parameterization of ozone chemistry:
+      use regr_lat_time_coefoz_m, only: regr_lat_time_coefoz
+      use press_coefoz_m, only: press_coefoz
+      use regr_pr_o3_m, only: regr_pr_o3
+#endif
+!#endif of #ifdef CPP_EARTH
+      use netcdf, only: nf90_open, NF90_NOWRITE, nf90_close
+      !
+      IMPLICIT NONE
+      !
+#include "dimensions.h"
+#include "paramet.h"
+      !
+      !
+!      INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, 
+!     .KLON=KFDIA-KIDIA+1,KLEV=llm
+      !
+#ifdef CPP_EARTH    
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "temps.h"
+#endif
+!#endif of #ifdef CPP_EARTH
+      ! arguments:
+      LOGICAL interbar
+      REAL :: masque(iip1,jjp1)
+
+#ifdef CPP_EARTH
+      ! local variables:
+      REAL :: latfi(klon), lonfi(klon)
+      REAL :: orog(iip1,jjp1), rugo(iip1,jjp1)
+      REAL :: psol(iip1, jjp1), phis(iip1, jjp1)
+      REAL :: p3d(iip1, jjp1, llm+1)
+      REAL :: uvent(iip1, jjp1, llm)
+      REAL :: vvent(iip1, jjm, llm)
+      REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm)
+      REAL :: qsat(iip1, jjp1, llm)
+      REAL,ALLOCATABLE :: q3d(:, :, :,:)
+      REAL :: tsol(klon), qsol(klon), sn(klon)
+!!      REAL :: tsolsrf(klon,nbsrf)
+      real qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) 
+      REAL :: albe(klon,nbsrf), evap(klon,nbsrf)
+      REAL :: alblw(klon,nbsrf)
+      REAL :: tsoil(klon,nsoilmx,nbsrf) 
+      REAL :: frugs(klon,nbsrf), agesno(klon,nbsrf)
+      REAL :: rugmer(klon)
+      REAL :: qd(iip1, jjp1, llm)
+      REAL :: run_off_lic_0(klon)
+      ! declarations pour lecture glace de mer
+      REAL :: rugv(klon)
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+      REAL :: champint(iim, jjp1)
+      !
+
+      CHARACTER(len=80) :: varname
+      !
+      INTEGER :: i,j, ig, l, ji,ii1,ii2
+      REAL :: xpi
+      !
+      REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm)
+      REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1)
+      REAL :: workvar(iip1,jjp1,llm)
+      !
+      REAL ::  prefkap, unskap
+      !
+      real :: time_step,t_ops,t_wrt
+
+#include "comdissnew.h"
+#include "serre.h"
+#include "clesphys.h"
+
+      INTEGER  ::        longcles
+      PARAMETER      ( longcles  = 20 )
+      REAL :: clesphy0 ( longcles       )
+      REAL :: p(iip1,jjp1,llm)
+      INTEGER :: itau, iday
+      REAL :: masse(iip1,jjp1,llm)
+      REAL :: xpn,xps,xppn(iim),xpps(iim)
+      real :: time
+      REAL :: phi(ip1jmp1,llm)
+      REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL :: w(ip1jmp1,llm)
+      REAL ::phystep
+CC      REAL :: rugsrel(iip1*jjp1)
+      REAL :: fder(klon)
+!!      real zrel(iip1*jjp1),chmin,chmax
+
+!!      CHARACTER(len=80) :: visu_file
+      INTEGER :: visuid
+
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+      integer :: isst(klon-2)
+      real zx_tmp_2d(iim,jjp1)
+
+      REAL :: dummy
+
+      logical              :: ok_newmicro
+      integer              :: iflag_radia
+      logical              :: ok_journe, ok_mensuel, ok_instan, ok_hf
+      logical              :: ok_LES
+      LOGICAL              :: ok_ade, ok_aie, aerosol_couple, new_aod
+      INTEGER              :: flag_aerosol
+      REAL                 :: bl95_b0, bl95_b1
+      real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut
+      real                 :: tau_ratqs
+      integer              :: iflag_cldcon
+      integer              :: iflag_ratqs
+      integer :: iflag_coupl
+      integer :: iflag_clos
+      integer :: iflag_wake
+      integer :: iflag_thermals,nsplit_thermals
+      real    :: tau_thermals
+      integer :: iflag_thermals_ed,iflag_thermals_optflux
+      REAL      :: solarlong0
+      real :: seuil_inversion
+      real :: alp_offset
+      logical found
+
+      integer  read_climoz ! read ozone climatology
+C     Allowed values are 0, 1 and 2
+C     0: do not read an ozone climatology
+C     1: read a single ozone climatology that will be used day and night
+C     2: read two ozone climatologies, the average day and night
+C     climatology and the daylight climatology
+
+      !
+      !   Constantes 
+      !
+      pi     = 4. * ATAN(1.)
+      rad    = 6371229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      !
+      preff     = 101325.
+      pa        =  50000.
+      unskap = 1./kappa
+      !
+      jmp1    = jjm + 1
+      !
+      !    Construct a grid
+      !
+
+!      CALL defrun_new(99,.TRUE.,clesphy0)
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+      call conf_phys(  ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, &
+     &                 solarlong0,seuil_inversion,                      &
+     &                 fact_cldcon, facttemps,ok_newmicro,iflag_radia,  &
+     &                 iflag_cldcon,                                    &
+     &                 iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs,        &
+     &                 ok_ade, ok_aie, aerosol_couple,                  &
+     &                 flag_aerosol, new_aod,                           &
+     &                 bl95_b0, bl95_b1,                                &
+     &                 iflag_thermals,nsplit_thermals,tau_thermals,     &
+     &                 iflag_thermals_ed,iflag_thermals_optflux,        &
+     &                 iflag_coupl,iflag_clos,iflag_wake, read_climoz,  &
+     &                 alp_offset)
+
+! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value)
+      co2_ppm0 = co2_ppm
+
+      dtvr   = daysec/REAL(day_step)
+      print*,'dtvr',dtvr
+
+      CALL iniconst()
+      CALL inigeom()
+
+! Initialisation pour traceurs
+      call infotrac_init
+      ALLOCATE(q3d(iip1, jjp1, llm, nqtot))
+
+      CALL inifilr()
+      CALL phys_state_var_init(read_climoz)
+      !
+      latfi(1) = ASIN(1.0)
+      DO j = 2, jjm
+        DO i = 1, iim
+          latfi((j-2)*iim+1+i)=  rlatu(j)
+        ENDDO
+      ENDDO
+      latfi(klon) = - ASIN(1.0)
+      !
+      lonfi(1) = 0.0
+      DO j = 2, jjm
+        DO i = 1, iim
+          lonfi((j-2)*iim+1+i) =  rlonv(i)
+        ENDDO
+      ENDDO
+      lonfi(klon) = 0.0
+      !
+      xpi = 2.0 * ASIN(1.0)
+      DO ig = 1, klon
+        latfi(ig) = latfi(ig) * 180.0 / xpi
+        lonfi(ig) = lonfi(ig) * 180.0 / xpi
+      ENDDO
+      !
+      rlat(1) = ASIN(1.0)
+      DO j = 2, jjm
+        DO i = 1, iim
+          rlat((j-2)*iim+1+i)=  rlatu(j)
+        ENDDO
+      ENDDO
+      rlat(klon) = - ASIN(1.0)
+      !
+      rlon(1) = 0.0
+      DO j = 2, jjm
+        DO i = 1, iim
+          rlon((j-2)*iim+1+i) =  rlonv(i)
+        ENDDO
+      ENDDO
+      rlon(klon) = 0.0
+      !
+      xpi = 2.0 * ASIN(1.0)
+      DO ig = 1, klon
+        rlat(ig) = rlat(ig) * 180.0 / xpi
+        rlon(ig) = rlon(ig) * 180.0 / xpi
+      ENDDO
+      !
+      
+
+
+C
+C En cas de simulation couplee, lecture du masque ocean issu du modele ocean
+C utilise pour calculer les poids et pour assurer l'adequation entre les
+C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque 
+C a partir du fichier relief
+C
+
+      write(*,*)'Essai de lecture masque ocean'
+      iret = nf90_open("o2a.nc", NF90_NOWRITE, nid_o2a)
+      if (iret .ne. 0) then
+        write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve'
+        write(*,*)'Run force'
+        varname = 'masque'
+        masque(:,:) = 0.0
+        CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, masque,
+     $       0.0, jjm ,rlonu,rlatv , interbar )
+        WRITE(*,*) 'MASQUE construit : Masque'
+        WRITE(*,'(97I1)') nINT(masque(:,:))
+        call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq)
+        WHERE (zmasq(1 : klon) .LT. EPSFRA)
+            zmasq(1 : klon) = 0.
+        END WHERE 
+        WHERE (1. - zmasq(1 : klon) .LT. EPSFRA)
+            zmasq(1 : klon) = 1.
+        END WHERE 
+      else
+        couple = .true.
+        iret = nf90_close(nid_o2a)
+        call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp
+     $    , nid_o2a)
+        if (iml_omask /= iim .or. jml_omask /= jjp1) then
+          write(*,*)'Dimensions non compatibles pour masque ocean'
+          write(*,*)'iim = ',iim,' iml_omask = ',iml_omask
+          write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask
+          stop
+        endif
+        ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(dlon_omask(iml_omask), stat=iret)
+        ALLOCATE(dlat_omask(jml_omask), stat=iret)
+        ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret)
+        CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp
+     $    , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid)
+        CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, 
+     $      ttm_tmp, 1, 1, ocetmp)
+        CALL flinclo(fid)
+        dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1)
+        dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask)
+        ocemask = ocetmp
+        if (dlat_omask(1) < dlat_omask(jml_omask)) then
+          do j = 1, jml_omask
+            ocemask(:,j) = ocetmp(:,jml_omask-j+1)
+          enddo
+        endif 
+C
+C passage masque ocean a la grille physique
+C
+        write(*,*)'ocemask '
+        write(*,'(96i1)')int(ocemask)
+        ocemask_fi(1) = ocemask(1,1)
+        do j = 2, jjm
+          do i = 1, iim
+            ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j)
+          enddo
+        enddo
+        ocemask_fi(klon) = ocemask(1,jjp1)
+        zmasq = 1. - ocemask_fi
+      endif
+
+      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+
+      varname = 'relief'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      orog(:,:) = 0.0
+       CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, orog,
+     $     0.0 , jjm ,rlonu,rlatv , interbar, masque )
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Relief'
+!      WRITE(*,'(49I1)') INT(orog(:,:))
+      !
+      varname = 'rugosite'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      rugo(:,:) = 0.0
+       CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, rugo,
+     $     0.0 , jjm, rlonu,rlatv , interbar )
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' 
+!      WRITE(*,'(49I1)') INT(rugo(:,:)*10)
+      !
+C
+C on initialise les sous surfaces
+C
+      pctsrf=0.
+c
+      varname = 'psol'
+      psol(:,:) = 0.0
+      CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, psol,
+     $     0.0 , jjm ,rlonu,rlatv , interbar )
+      !
+      !  Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM 
+      !  anyway.
+      !
+!      WRITE(*,*) 'PSOL :', psol(10,20)
+!      WRITE(*,*) ap(:), bp(:)
+      CALL pression(ip1jmp1, ap, bp, psol, p3d)
+!      WRITE(*,*) 'P3D :', p3d(10,20,:)
+      CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar)
+!      WRITE(*,*) 'PK:', pk(10,20,:)
+      !
+      !
+      !
+      prefkap =  preff  ** kappa
+!      WRITE(*,*) 'unskap, cpp,  preff :', unskap, cpp,  preff
+      DO l = 1, llm
+        DO j=1,jjp1
+          DO i =1, iip1
+            pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+           ENDDO
+        ENDDO
+      ENDDO
+      !
+!      WRITE(*,*) 'PLS :', pls(10,20,:)
+      !
+      varname = 'surfgeo'
+      phis(:,:) = 0.0
+      CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, phis,
+     $     0.0 , jjm ,rlonu,rlatv, interbar )
+      !
+      varname = 'u'
+      uvent(:,:,:) = 0.0
+      CALL startget_dyn(varname, rlonu, rlatu, pls, workvar, uvent, 0.,
+     $     rlonv, rlatv, interbar )
+      !  
+      varname = 'v'
+      vvent(:,:,:) = 0.0
+      CALL startget_dyn(varname, rlonv, rlatv, pls(:, :jjm, :),
+     . workvar(:, :jjm, :), vvent, 0., rlonu, rlatu(:jjm), interbar )
+      !
+      varname = 't'
+      t3d(:,:,:) = 0.0
+      CALL startget_dyn(varname, rlonv, rlatu, pls, workvar, t3d, 0.,
+     $     rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)),
+     .                          maxval(t3d(:,:,:))
+      varname = 'tpot'
+      tpot(:,:,:) = 0.0
+      CALL startget_dyn(varname, rlonv, rlatu, pls, pk, tpot, 0., rlonu,
+     $     rlatv, interbar)
+      !
+      WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)),
+     .                          maxval(t3d(:,:,:))
+      WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)),
+     .                          maxval(pls(:,:,:))
+
+c Calcul de l'humidite a saturation
+      print*,'avant q_sat'
+      call q_sat(llm*jjp1*iip1,t3d,pls,qsat)
+      print*,'apres q_sat'
+
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      !
+CC      WRITE(*,*) 'QSAT :', qsat(10,20,:)
+      !
+      varname = 'q'
+      qd(:,:,:) = 0.0
+      q3d(:,:,:,:) = 0.0
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      CALL startget_dyn(varname, rlonv, rlatu, pls, qsat, qd, 0., rlonu,
+     $     rlatv , interbar )
+      q3d(:,:,:,1) = qd(:,:,:)
+      !
+!     Parameterization of ozone chemistry:
+C     Look for ozone tracer:
+      i = 1
+      DO
+         found = tname(i)=="O3" .OR. tname(i)=="o3"
+         if (found .or. i == nqtot) exit
+         i = i + 1
+      end do
+      if (found) then
+         call regr_lat_time_coefoz
+         call press_coefoz
+         call regr_pr_o3(p3d, q3d(:, :, :, i))
+C     Convert from mole fraction to mass fraction:
+         q3d(:, :, :, i) = q3d(:, :, :, i)  * 48. / 29.
+      end if
+
+!     Ozone climatology:
+      if (read_climoz >= 1) call regr_lat_time_climoz(read_climoz)
+
+      varname = 'tsol'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      tsol(:) = 0.0
+      CALL startget_phys1d(varname, iip1, jjp1, rlonv, rlatu, klon,
+     $     tsol, 0.0, jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'TSOL construit :'
+!      WRITE(*,'(48I3)') INT(TSOL(2:klon)-273)
+      !
+      varname = 'qsol'
+      qsol(:) = 0.0
+      CALL startget_phys1d(varname, iip1, jjp1, rlonv, rlatu, klon,
+     $     qsol, 0.0, jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'snow'
+      sn(:) = 0.0
+      CALL startget_phys1d(varname, iip1, jjp1, rlonv, rlatu, klon, sn,
+     $     0.0, jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'rads'
+      radsol(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,
+     $     0.0, jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'rugmer'
+      rugmer(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,
+     $     0.0, jjm, rlonu, rlatv , interbar )
+      !
+!      varname = 'agesno'
+!      agesno(:) = 0.0
+!      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0,
+!     .     jjm, rlonu, rlatv , interbar )
+
+      varname = 'zmea'
+      zmea(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+
+      varname = 'zstd'
+      zstd(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zsig'
+      zsig(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zgam'
+      zgam(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zthe'
+      zthe(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zpic'
+      zpic(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zval'
+      zval(:) = 0.0
+      CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+c
+cc      rugsrel(:) = 0.0
+cc      IF(ok_orodr)  THEN
+cc        DO i = 1, iip1* jjp1
+cc         rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. )
+cc        ENDDO
+cc      ENDIF
+
+
+C
+C lecture du fichier glace de terre pour fixer la fraction de terre 
+C et de glace de terre
+C
+      CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp
+     $    , fid)
+      ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(dlon_lic(iml_lic), stat=iret)
+      ALLOCATE(dlat_lic(jml_lic), stat=iret)
+      ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret)
+      CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp
+     $    , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid)
+      CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp
+     $    , 1, 1, fraclic)
+      CALL flinclo(fid)
+C
+C interpolation sur la grille T du modele
+C
+      WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', 
+     $    iml_lic, jml_lic
+c
+C sil les coordonnees sont en degres, on les transforme
+C
+      IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) )  THEN
+          lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180.
+      ENDIF 
+      IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN 
+          lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180.
+      ENDIF 
+
+      dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1)
+      dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) 
+C
+      CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic
+     $    ,iim, jjp1,
+     $    rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1))
+cx$$$      flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1)
+      flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1)
+C
+C passage sur la grille physique
+C
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp,
+     $    pctsrf(1:klon, is_lic))
+C adequation avec le maque terre/mer
+c      zmasq(157) = 0.
+      WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) 
+          pctsrf(1 : klon, is_lic) = 0. 
+      END WHERE
+      WHERE (zmasq( 1 : klon) .LT. EPSFRA) 
+          pctsrf(1 : klon, is_lic) = 0.
+      END WHERE 
+      pctsrf(1 : klon, is_ter) = zmasq(1 : klon)
+      DO ji = 1, klon
+        IF (zmasq(ji) .GT. EPSFRA) THEN 
+            IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN
+                pctsrf(ji, is_lic) = zmasq(ji)
+                pctsrf(ji, is_ter) = 0.
+            ELSE 
+                pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic)
+                IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN
+                    pctsrf(ji,is_ter) = 0.
+                    pctsrf(ji, is_lic) = zmasq(ji)
+                ENDIF 
+            ENDIF 
+        ENDIF 
+      END DO 
+C
+C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0)
+C
+      pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon))
+
+
+      WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA)
+          pctsrf(1 : klon, is_oce) = 0.
+      END WHERE 
+
+      if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon)
+
+      isst = 0
+      where (pctsrf(2:klon-1,is_oce) >0.) isst = 1
+C
+C verif que somme des sous surface = 1
+C
+      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf),dim=2))-1.0) 
+     $    .GT. EPSFRA)
+      IF (ji .NE. 0) THEN
+          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+      ENDIF 
+
+!      where (pctsrf(1:klon, is_ter) >= .5) 
+!        pctsrf(1:klon, is_ter) = 1.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 1.
+!      endwhere
+!      where (pctsrf(1:klon, is_lic) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 1.
+!        zmasq = 1.
+!      endwhere
+!      where (pctsrf(1:klon, is_oce) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 1.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 0.
+!      endwhere
+!      where (pctsrf(1:klon, is_sic) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 1.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 0.
+!      endwhere
+!      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+C
+C verif que somme des sous surface = 1
+C
+!      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) 
+!     $    .GT. EPSFRA)
+!      IF (ji .NE. 0) THEN
+!          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+!     ENDIF 
+
+      CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d)
+      write(*,*)'zmasq = '
+      write(*,'(96i1)')nint(zx_tmp_2d)
+      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+      WRITE(*,*) 'MASQUE construit : Masque'
+      WRITE(*,'(97I1)') nINT(masque(:,:))
+
+
+
+C Calcul intermediaire
+c 
+      CALL massdair( p3d, masse  )
+c
+
+      print *,' ALPHAX ',alphax
+
+      DO  l = 1, llm
+        DO  i    = 1, iim
+          xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+          xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+        ENDDO
+          xpn      = SUM(xppn)/apoln
+          xps      = SUM(xpps)/apols
+        DO i   = 1, iip1
+          masse(   i   ,   1     ,  l )   = xpn
+          masse(   i   ,   jjp1  ,  l )   = xps
+        ENDDO
+      ENDDO
+      q3d(iip1,:,:,:) = q3d(1,:,:,:)
+      phis(iip1,:) = phis(1,:)
+
+C Ecriture
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+      print*,'sortie inidissip'
+      itau = 0
+      itau_dyn = 0
+      itau_phy = 0
+      iday = dayref +itau/day_step
+      time = real(itau-(iday-dayref)*day_step)/day_step
+c     
+      IF(time.GT.1)  THEN
+       time = time - 1
+       iday = iday + 1
+      ENDIF
+      day_ref = dayref
+      annee_ref = anneeref
+
+      CALL geopot  ( ip1jmp1, tpot  , pk , pks,  phis  , phi   )
+      print*,'sortie geopot'
+      
+      CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis ,
+     *                phi,w, pbaru,pbarv,time+iday-dayref   )
+       print*,'sortie caldyn0'     
+      CALL dynredem0("start.nc",dayref,phis)
+      print*,'sortie dynredem0'
+      CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,masse ,
+     .                            psol)
+      print*,'sortie dynredem1' 
+C
+C Ecriture etat initial physique
+C
+      write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad
+      phystep   = dtvr * REAL(iphysiq)
+      radpas    = NINT (86400./phystep/ REAL(nbapp_rad) )
+      write(*,*)'phystep =', phystep, radpas
+cIM : lecture de co2_ppm & solaire ds physiq.def
+c     co2_ppm   = 348.0
+c     solaire   = 1365.0
+
+c
+c Initialisation 
+c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs
+c
+      ftsol(:,is_ter) = tsol
+      ftsol(:,is_lic) = tsol
+      ftsol(:,is_oce) = tsol
+      ftsol(:,is_sic) = tsol
+      snsrf(:,is_ter) = sn
+      snsrf(:,is_lic) = sn
+      snsrf(:,is_oce) = sn
+      snsrf(:,is_sic) = sn
+      falb1(:,is_ter) = 0.08
+      falb1(:,is_lic) = 0.6
+      falb1(:,is_oce) = 0.5
+      falb1(:,is_sic) = 0.6
+      falb2 = falb1
+      evap(:,:) = 0.
+      qsolsrf(:,is_ter) = 150
+      qsolsrf(:,is_lic) = 150
+      qsolsrf(:,is_oce) = 150.
+      qsolsrf(:,is_sic) = 150.
+      do i = 1, nbsrf
+        do j = 1, nsoilmx
+          tsoil(:,j,i) = tsol
+        enddo
+      enddo
+      rain_fall = 0.; snow_fall = 0.
+      solsw = 165.
+      sollw = -53.
+      t_ancien = 273.15
+      q_ancien = 0.
+      agesno = 0.
+c
+      frugs(1:klon,is_oce) = rugmer(1:klon)
+      frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0)
+      frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0)
+      frugs(1:klon,is_sic) = 0.001
+      fder = 0.0
+      clwcon = 0.0
+      rnebcon = 0.0
+      ratqs = 0.0
+      run_off_lic_0 = 0.0 
+      rugoro = 0.0
+
+c
+c Avant l'appel a phyredem, on initialize les modules de surface
+c avec les valeurs qui vont etre ecrit dans startphy.nc
+c
+      dummy = 1.0
+      pbl_tke(:,:,:) = 1.e-8 
+      zmax0(:) = 40.
+      f0(:) = 1.e-5
+      ema_work1(:,:) = 0.
+      ema_work2(:,:) = 0.
+      wake_deltat(:,:) = 0.
+      wake_deltaq(:,:) = 0.
+      wake_s(:) = 0.
+      wake_cstar(:) = 0.
+      wake_fip(:) = 0.
+      wake_pe = 0.
+      fm_therm = 0.
+      entr_therm = 0.
+      detr_therm = 0.
+
+      call fonte_neige_init(run_off_lic_0)
+      call pbl_surface_init(qsol, fder, snsrf, qsolsrf,
+     $     evap, frugs, agesno, tsoil)
+
+      call phyredem("startphy.nc")
+
+
+
+C     Sortie Visu pour les champs dynamiques
+cc      if (1.eq.0 ) then
+cc      print*,'sortie visu'
+cc      time_step = 1.
+cc      t_ops = 2.
+cc      t_wrt = 2.
+cc      itau = 2.
+cc      visu_file='Etat0_visu.nc'
+cc      CALL initdynav(visu_file,dayref,anneeref,time_step,
+cc     .              t_ops, t_wrt, visuid)
+cc      CALL writedynav(visuid, itau,vvent ,
+cc     .                uvent,tpot,pk,phi,q3d,masse,psol,phis)
+cc      else
+         print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0'
+cc      endif
+      print*,'entree histclo'
+      CALL histclo
+
+#endif 
+!#endif of #ifdef CPP_EARTH
+      RETURN
+      !
+      END SUBROUTINE etat0_netcdf
Index: LMDZ5/trunk/libf/exner_hyb.F
===================================================================
--- LMDZ5/trunk/libf/exner_hyb.F	(revision 1630)
+++ LMDZ5/trunk/libf/exner_hyb.F	(revision 1630)
@@ -0,0 +1,114 @@
+!
+! $Header$
+!
+      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+c
+      
+      unpl2k    = 1.+ 2.* kappa
+c
+      DO   ij  = 1, ngrid
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+
+      DO  ij   = 1, iim
+        ppn(ij) = aire(   ij   ) * pks(  ij     )
+        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+      ENDDO
+      xpn      = SSUM(iim,ppn,1) /apoln
+      xps      = SSUM(iim,pps,1) /apols
+
+      DO ij   = 1, iip1
+        pks(   ij     )  =  xpn
+        pks( ij+ip1jm )  =  xps
+      ENDDO
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+      DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+        DO ij = 1, ngrid
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c
+      ENDDO
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+      DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+        DO   ij   = 1, ngrid
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+      ENDDO
+c
+c
+      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/exner_hyb_loc.F
===================================================================
--- LMDZ5/trunk/libf/exner_hyb_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/exner_hyb_loc.F	(revision 1630)
@@ -0,0 +1,164 @@
+      SUBROUTINE  exner_hyb_loc(ngrid, ps, p,alpha,beta, pks,pk,pkf)
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      USE parallel
+      USE mod_filtreg_p
+      USE write_field_loc
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
+      REAL pkf(ijb_u:ije_u,llm)
+      REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
+      REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ije,ijb,jje,jjb
+c
+c$OMP BARRIER           
+      unpl2k    = 1.+ 2.* kappa
+c
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij  = ijb, ije
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+c$OMP ENDDO
+c Synchro OPENMP ici
+
+c$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+        ENDDO
+      endif
+c$OMP END MASTER
+c$OMP BARRIER
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+c$OMP DO SCHEDULE(STATIC)
+      DO     ij      = ijb,ije
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c$OMP ENDDO NOWAIT
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+c$OMP DO SCHEDULE(STATIC)
+        DO ij = ijb, ije
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c$OMP ENDDO NOWAIT
+c
+      ENDDO
+
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij   = ijb, ije
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c$OMP ENDDO NOWAIT
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+c$OMP DO SCHEDULE(STATIC)
+        DO   ij   = ijb, ije
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+c$OMP ENDDO NOWAIT        
+      ENDDO
+c
+c
+c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      DO l = 1, llm
+c$OMP DO SCHEDULE(STATIC)
+         DO   ij   = ijb, ije
+           pkf(ij,l)=pk(ij,l)
+         ENDDO
+c$OMP ENDDO NOWAIT             
+      ENDDO
+
+c$OMP BARRIER
+      
+      jjb=jj_begin
+      jje=jj_end
+#ifdef DEBUG_IO    
+      call WriteField_u('pkf',pkf)
+#endif
+      CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm,
+     &                 2, 1, .TRUE., 1 )
+#ifdef DEBUG_IO    
+      call WriteField_u('pkf',pkf)
+#endif      
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/exner_hyb_p.F
===================================================================
--- LMDZ5/trunk/libf/exner_hyb_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/exner_hyb_p.F	(revision 1630)
@@ -0,0 +1,153 @@
+      SUBROUTINE  exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ije,ijb,jje,jjb
+c
+c$OMP BARRIER           
+      unpl2k    = 1.+ 2.* kappa
+c
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij  = ijb, ije
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+c$OMP ENDDO
+c Synchro OPENMP ici
+
+c$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+        ENDDO
+      endif
+c$OMP END MASTER
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+c$OMP DO SCHEDULE(STATIC)
+      DO     ij      = ijb,ije
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c$OMP ENDDO NOWAIT
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+c$OMP DO SCHEDULE(STATIC)
+        DO ij = ijb, ije
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c$OMP ENDDO NOWAIT
+c
+      ENDDO
+
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij   = ijb, ije
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c$OMP ENDDO NOWAIT
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+c$OMP DO SCHEDULE(STATIC)
+        DO   ij   = ijb, ije
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+c$OMP ENDDO NOWAIT        
+      ENDDO
+c
+c
+c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      DO l = 1, llm
+c$OMP DO SCHEDULE(STATIC)
+         DO   ij   = ijb, ije
+           pkf(ij,l)=pk(ij,l)
+         ENDDO
+c$OMP ENDDO NOWAIT             
+      ENDDO
+
+c$OMP BARRIER
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/exner_milieu_loc.F
===================================================================
--- LMDZ5/trunk/libf/exner_milieu_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/exner_milieu_loc.F	(revision 1630)
@@ -0,0 +1,226 @@
+!
+! $Id $
+!
+      SUBROUTINE  exner_milieu_loc ( ngrid, ps, p,beta, pks, pk, pkf )
+c
+c     Auteurs :  F. Forget , Y. Wanherdrick
+c P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c    .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c     WARNING : CECI est une version speciale de exner_hyb originale
+c               Utilise dans la version martienne pour pouvoir 
+c               tourner avec des coordonnees verticales complexe
+c              => Il ne verifie PAS la condition la proportionalite en 
+c              energie totale/ interne / potentielle (F.Forget 2001)
+c    ( voir note de Fr.Hourdin )  ,
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
+      REAL pkf(ijb_u:ije_u,llm)
+      REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
+      REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL dum1
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ije,ijb,jje,jjb
+      logical,save :: firstcall=.true.
+!$OMP THREADPRIVATE(firstcall) 
+      character(len=*),parameter :: modname="exner_milieu_p"
+
+      ! Sanity check
+      if (firstcall) then
+        ! check that vertical discretization is compatible
+        ! with this routine
+        if (disvert_type.ne.2) then
+          call abort_gcm(modname,
+     &     "this routine should only be called if disvert_type==2",42)
+        endif
+        
+        ! sanity checks for Shallow Water case (1 vertical layer)
+        if (llm.eq.1) then
+          if (kappa.ne.1) then
+            call abort_gcm(modname,
+     &      "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+            call abort_gcm(modname,
+     &      "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+        endif ! of if (llm.eq.1)
+
+        firstcall=.false.
+      endif ! of if (firstcall)
+      
+c$OMP BARRIER
+
+! Specific behaviour for Shallow Water (1 vertical layer) case
+      if (llm.eq.1) then
+              
+        ! Compute pks(:),pk(:),pkf(:)
+        ijb=ij_begin
+        ije=ij_end
+!$OMP DO SCHEDULE(STATIC)
+        DO ij=ijb, ije
+          pks(ij)=(cpp/preff)*ps(ij)
+          pk(ij,1) = .5*pks(ij)
+          pkf(ij,1)=pk(ij,1)
+        ENDDO
+!$OMP ENDDO
+
+!$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+          pk(ij,1) = .5*pks(ij)
+          pkf(ij,1)=pk(ij,1)
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+          pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
+          pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
+        ENDDO
+      endif
+!$OMP END MASTER
+
+        jjb=jj_begin
+        jje=jj_end
+        CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+
+        ! our work is done, exit routine
+        return
+      endif ! of if (llm.eq.1)
+
+!!!! General case:
+
+c     -------------
+c     Calcul de pks
+c     -------------
+   
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij  = ijb, ije
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+c$OMP ENDDO
+c Synchro OPENMP ici
+
+c$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+        ENDDO
+      endif
+c$OMP END MASTER
+c
+c
+c    .... Calcul de pk  pour la couche l 
+c    --------------------------------------------
+c
+      dum1 = cpp * (2*preff)**(-kappa) 
+      DO l = 1, llm-1
+c$OMP DO SCHEDULE(STATIC)
+        DO   ij   = ijb, ije
+         pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+        ENDDO
+c$OMP ENDDO NOWAIT        
+      ENDDO
+
+c    .... Calcul de pk  pour la couche l = llm ..
+c    (on met la meme distance (en log pression)  entre Pk(llm)
+c    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij   = ijb, ije
+         pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+      ENDDO
+c$OMP ENDDO NOWAIT        
+
+
+c    calcul de pkf
+c    -------------
+c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      DO l = 1, llm
+c$OMP DO SCHEDULE(STATIC)
+         DO   ij   = ijb, ije
+           pkf(ij,l)=pk(ij,l)
+         ENDDO
+c$OMP ENDDO NOWAIT             
+      ENDDO
+
+c$OMP BARRIER
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+c    EST-CE UTILE ?? : calcul de beta
+c    --------------------------------
+      DO l = 2, llm
+c$OMP DO SCHEDULE(STATIC)
+        DO   ij   = ijb, ije
+          beta(ij,l) = pk(ij,l) / pk(ij,l-1)   
+        ENDDO
+c$OMP ENDDO NOWAIT             
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/exner_milieu_p.F
===================================================================
--- LMDZ5/trunk/libf/exner_milieu_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/exner_milieu_p.F	(revision 1630)
@@ -0,0 +1,224 @@
+!
+! $Id $
+!
+      SUBROUTINE  exner_milieu_p ( ngrid, ps, p,beta, pks, pk, pkf )
+c
+c     Auteurs :  F. Forget , Y. Wanherdrick
+c P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c    .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c     WARNING : CECI est une version speciale de exner_hyb originale
+c               Utilise dans la version martienne pour pouvoir 
+c               tourner avec des coordonnees verticales complexe
+c              => Il ne verifie PAS la condition la proportionalite en 
+c              energie totale/ interne / potentielle (F.Forget 2001)
+c    ( voir note de Fr.Hourdin )  ,
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL dum1
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ije,ijb,jje,jjb
+      logical,save :: firstcall=.true.
+!$OMP THREADPRIVATE(firstcall) 
+      character(len=*),parameter :: modname="exner_milieu_p"
+
+      ! Sanity check
+      if (firstcall) then
+        ! check that vertical discretization is compatible
+        ! with this routine
+        if (disvert_type.ne.2) then
+          call abort_gcm(modname,
+     &     "this routine should only be called if disvert_type==2",42)
+        endif
+        
+        ! sanity checks for Shallow Water case (1 vertical layer)
+        if (llm.eq.1) then
+          if (kappa.ne.1) then
+            call abort_gcm(modname,
+     &      "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+            call abort_gcm(modname,
+     &      "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+        endif ! of if (llm.eq.1)
+
+        firstcall=.false.
+      endif ! of if (firstcall)
+      
+c$OMP BARRIER
+
+! Specific behaviour for Shallow Water (1 vertical layer) case
+      if (llm.eq.1) then
+              
+        ! Compute pks(:),pk(:),pkf(:)
+        ijb=ij_begin
+        ije=ij_end
+!$OMP DO SCHEDULE(STATIC)
+        DO ij=ijb, ije
+          pks(ij)=(cpp/preff)*ps(ij)
+          pk(ij,1) = .5*pks(ij)
+          pkf(ij,1)=pk(ij,1)
+        ENDDO
+!$OMP ENDDO
+
+!$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+          pk(ij,1) = .5*pks(ij)
+          pkf(ij,1)=pk(ij,1)
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+          pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
+          pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
+        ENDDO
+      endif
+!$OMP END MASTER
+
+        jjb=jj_begin
+        jje=jj_end
+        CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+
+        ! our work is done, exit routine
+        return
+      endif ! of if (llm.eq.1)
+
+!!!! General case:
+
+c     -------------
+c     Calcul de pks
+c     -------------
+   
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij  = ijb, ije
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+c$OMP ENDDO
+c Synchro OPENMP ici
+
+c$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+        ENDDO
+      endif
+c$OMP END MASTER
+c
+c
+c    .... Calcul de pk  pour la couche l 
+c    --------------------------------------------
+c
+      dum1 = cpp * (2*preff)**(-kappa) 
+      DO l = 1, llm-1
+c$OMP DO SCHEDULE(STATIC)
+        DO   ij   = ijb, ije
+         pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+        ENDDO
+c$OMP ENDDO NOWAIT        
+      ENDDO
+
+c    .... Calcul de pk  pour la couche l = llm ..
+c    (on met la meme distance (en log pression)  entre Pk(llm)
+c    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+c$OMP DO SCHEDULE(STATIC)
+      DO   ij   = ijb, ije
+         pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+      ENDDO
+c$OMP ENDDO NOWAIT        
+
+
+c    calcul de pkf
+c    -------------
+c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      DO l = 1, llm
+c$OMP DO SCHEDULE(STATIC)
+         DO   ij   = ijb, ije
+           pkf(ij,l)=pk(ij,l)
+         ENDDO
+c$OMP ENDDO NOWAIT             
+      ENDDO
+
+c$OMP BARRIER
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+c    EST-CE UTILE ?? : calcul de beta
+c    --------------------------------
+      DO l = 2, llm
+c$OMP DO SCHEDULE(STATIC)
+        DO   ij   = ijb, ije
+          beta(ij,l) = pk(ij,l) / pk(ij,l-1)   
+        ENDDO
+c$OMP ENDDO NOWAIT             
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/extrapol.F
===================================================================
--- LMDZ5/trunk/libf/extrapol.F	(revision 1630)
+++ LMDZ5/trunk/libf/extrapol.F	(revision 1630)
@@ -0,0 +1,200 @@
+!
+! $Id: extrapol.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+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 99999 j = 1, kylat
+      DO 99999 i = 1, kxlon
+      IF (pfild(i,j).GT. 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 .EQ. 1) ideb = 4
+         IF (j .EQ. kylat) ifin = 6
+C
+C* Account for periodicity in longitude
+C
+         IF (ldper) THEN 
+            IF (i .EQ. kxlon) THEN
+               ix(3) = 1
+               ix(6) = 1
+               ix(9) = 1
+            ELSE IF (i .EQ. 1) THEN
+               ix(1) = kxlon
+               ix(4) = kxlon
+               ix(7) = kxlon
+            ENDIF
+         ELSE
+            IF (i .EQ. 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 .EQ. 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 .EQ. 1 .OR. i .EQ. 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 .EQ. 1) ideb = 3
+               IF (j .EQ. kylat) ifin = 4
+            ENDIF
+         ENDIF ! end for ldper test
+C
+C* Find unmasked neighbors
+C
+         DO 230 k = ideb, ifin
+            zmask(k) = 0.
+            ilon = ix(k)
+            jlat = jy(k)
+            IF (pfild(ilon,jlat) .LT. zwmsk) THEN
+               zmask(k) = 1.
+               inbor = inbor + 1
+            ENDIF
+ 230     CONTINUE
+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 .GE. 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
+99999 CONTINUE
+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) .GT. zwmsk) idoit = idoit + 1
+         pfild(i,j) = pwork(i,j)
+      ENDDO
+      ENDDO
+c
+      IF (idoit .ne. 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: LMDZ5/trunk/libf/filtreg_p.F
===================================================================
--- LMDZ5/trunk/libf/filtreg_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/filtreg_p.F	(revision 1630)
@@ -0,0 +1,400 @@
+
+
+      SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, 
+     &     ifiltre, iaire, griscal ,iter)
+      USE Parallel, 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.EQ.1.or.ifiltre.EQ.-1) 
+     &     STOP'Pas de transformee simple dans cette version'
+      
+      IF( iter.EQ. 2 )  THEN
+         PRINT *,' Pas d iteration du filtre dans cette version !'
+     &        , ' Utiliser old_filtreg et repasser !'
+         STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+         PRINT *,' Cette routine ne calcule le filtre inverse que '
+     &        , ' sur la grille des scalaires !'
+         STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     &        , ' corriger et repasser !'
+         STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+            PRINT  1111
+            STOP
+         ELSE
+c     
+            IF( iaire.EQ.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.NE.jjm )  THEN
+            PRINT  2222
+            STOP
+         ELSE
+c
+            IF( iaire.EQ.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.EQ.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.EQ.1 )      THEN
+               
+               IF( ifiltre.EQ.-2 )   THEN
+                  DO j = jdfil,jffil
+                     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)
+                  ENDDO
+                  
+               ELSE IF ( griscal )     THEN
+                  DO j = jdfil,jffil
+                     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)
+                  ENDDO
+                  
+               ELSE 
+                  DO j = jdfil,jffil
+                     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)
+                  ENDDO
+                  
+               ENDIF
+               
+            ELSE
+               
+               IF( ifiltre.EQ.-2 )   THEN
+                  DO j = jdfil,jffil
+                     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)
+                  ENDDO
+                  
+               ELSE IF ( griscal )     THEN
+                  
+                  DO j = jdfil,jffil
+                     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)
+                  ENDDO
+                  
+               ELSE 
+                  
+                  DO j = jdfil,jffil
+                     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)
+                  ENDDO
+                  
+               ENDIF
+               
+            ENDIF
+!     c     
+            IF( ifiltre.EQ.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. EQ. -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.EQ. 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: LMDZ5/trunk/libf/flumass.F
===================================================================
--- LMDZ5/trunk/libf/flumass.F	(revision 1630)
+++ LMDZ5/trunk/libf/flumass.F	(revision 1630)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
+     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
+     * pbarv( ip1jm,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+
+      REAL       SSUM
+
+
+      DO  5 l = 1,llm
+
+      DO  1 ij = iip2,ip1jm
+      pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1  CONTINUE
+
+      DO 3 ij = 1,ip1jm
+      pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      sairen = SSUM( iim,  aire(   1     ), 1 )
+      saireun= SSUM( iim, aireu(   1     ), 1 )
+      saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+      saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+      DO 20 l = 1,llm
+
+      ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+
+      pbaru(    1   ,l )=   pbarv(    1     ,l ) - ctn * aire(    1    )
+      pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 )
+
+      DO 11 i = 2,iim
+      pbaru(    i    ,l ) = pbaru(   i - 1   ,l )    +
+     *                      pbarv(    i      ,l ) - ctn * aire(   i    )
+
+      pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l )    -
+     *                      pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm)
+  11  CONTINUE
+      DO 12 i = 1,iim
+      apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+      apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+  12  CONTINUE
+      ctn0 = -SSUM( iim,apbarun,1 )/saireun
+      cts0 = -SSUM( iim,apbarus,1 )/saireus
+      DO 14 i = 1,iim
+      pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+      pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+  14  CONTINUE
+
+      pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+      pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+  20  CONTINUE
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/flumass_loc.F
===================================================================
--- LMDZ5/trunk/libf/flumass_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/flumass_loc.F	(revision 1630)
@@ -0,0 +1,152 @@
+      SUBROUTINE flumass_loc(massebx,masseby,vcont,ucont,pbaru,pbarv)
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ijb_u:ije_u,llm ),masseby( ijb_v:ije_v,llm ) ,
+     * vcont( ijb_v:ije_v,llm ),ucont( ijb_u:ije_u,llm ),
+     * pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+      INTEGER ijb,ije
+      
+      EXTERNAL   SSUM
+      REAL       SSUM
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO  5 l = 1,llm
+
+        ijb=ij_begin
+        ije=ij_end+iip1
+      
+        if (pole_nord) ijb=ij_begin+iip1
+        if (pole_sud)  ije=ij_end-iip1
+        
+        DO  1 ij = ijb,ije
+          pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1    CONTINUE
+
+        ijb=ij_begin-iip1
+        ije=ij_end+iip1
+      
+        if (pole_nord) ijb=ij_begin
+        if (pole_sud)  ije=ij_end-iip1
+        
+        DO 3 ij = ijb,ije
+          pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3    CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      IF (pole_nord) THEN
+     
+        sairen = SSUM( iim,  aire(   1     ), 1 )
+        saireun= SSUM( iim, aireu(   1     ), 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+        DO l = 1,llm
+ 
+          ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      
+          pbaru(1,l)=pbarv(1,l) - ctn * aire(1)
+        
+          DO i = 2,iim
+            pbaru(i,l) = pbaru(i- 1,l )    +
+     *                   pbarv(i,l) - ctn * aire(i )
+          ENDDO
+        
+          DO i = 1,iim
+            apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+          ENDDO
+      
+          ctn0 = -SSUM( iim,apbarun,1 )/saireun
+        
+          DO i = 1,iim
+            pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+          ENDDO
+       
+          pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+        
+        ENDDO
+c$OMP END DO NOWAIT              
+
+      ENDIF
+
+      
+      IF (pole_sud) THEN
+  
+        saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+        saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+        DO  l = 1,llm
+ 
+          cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+          pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1)
+   
+          DO i = 2,iim
+            pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l)    -
+     *                          pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
+          ENDDO
+        
+          DO i = 1,iim
+            apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+          ENDDO
+
+          cts0 = -SSUM( iim,apbarus,1 )/saireus
+
+          DO i = 1,iim
+            pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+          ENDDO
+
+          pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+       
+        ENDDO
+c$OMP END DO NOWAIT         
+      ENDIF
+      
+      RETURN
+      END
Index: LMDZ5/trunk/libf/friction_loc.F
===================================================================
--- LMDZ5/trunk/libf/friction_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/friction_loc.F	(revision 1630)
@@ -0,0 +1,143 @@
+!
+! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c=======================================================================
+      SUBROUTINE friction_loc(ucov,vcov,pdt)
+      USE parallel
+      USE control_mod
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c
+c   Objet:
+c   ------
+c
+c  ***********
+c    Friction
+c  ***********
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+
+      REAL pdt
+      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)
+      REAL ucov( iip1,jjb_u:jje_u,llm ),vcov( iip1,jjb_v:jje_v,llm )
+      INTEGER  i,j
+      REAL cfric
+      parameter (cfric=1.e-5)
+      integer :: jjb,jje
+
+
+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
+
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/friction_p.F
===================================================================
--- LMDZ5/trunk/libf/friction_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/friction_p.F	(revision 1630)
@@ -0,0 +1,143 @@
+!
+! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c=======================================================================
+      SUBROUTINE friction_p(ucov,vcov,pdt)
+      USE parallel
+      USE control_mod
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c
+c   Objet:
+c   ------
+c
+c  ***********
+c    Friction
+c  ***********
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+
+      REAL pdt
+      REAL modv(iip1,jjp1),zco,zsi
+      REAL vpn,vps,upoln,upols,vpols,vpoln
+      REAL u2(iip1,jjp1),v2(iip1,jjm)
+      REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm )
+      INTEGER  i,j
+      REAL cfric
+      parameter (cfric=1.e-5)
+      integer :: jjb,jje
+
+
+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
+
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/fxhyp.F
===================================================================
--- LMDZ5/trunk/libf/fxhyp.F	(revision 1630)
+++ LMDZ5/trunk/libf/fxhyp.F	(revision 1630)
@@ -0,0 +1,448 @@
+!
+! $Id: fxhyp.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
+
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+c    Calcule les longitudes et derivees dans la grille du GCM pour une
+c     fonction f(x) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
+c     dzoom  etant  la distance totale de la zone du zoom
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
+c
+c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
+c   ********************************************************************
+
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+       LOGICAL scal180
+       PARAMETER ( scal180 = .TRUE. )
+
+c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
+c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
+c      sinon scal180 = .FALSE.
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,dzooma,tau,grossism
+
+c    ......   arguments  de  sortie  ......
+
+       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
+     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
+
+c     .... variables locales  ....
+c
+       REAL   dzoom
+       REAL*8 xlon(iip1),xprimm(iip1),xuv
+       REAL*8 xtild(0:nmax2)
+       REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
+       REAL*8 Xf(0:nmax2),xxpr(0:nmax2)
+       REAL*8 xvrai(iip1),xxprim(iip1) 
+       REAL*8 pi,depi,epsilon,xzoom,fa,fb
+       REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2
+       INTEGER i,it,ik,iter,ii,idif,ii1,ii2
+       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL*8 champmin,champmax,decalx
+       INTEGER is2
+       SAVE is2
+
+       REAL*8 heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-3
+       xzoom    = xzoomdeg * pi/180. 
+c
+           decalx   = .75
+       IF( grossism.EQ.1..AND.scal180 )  THEN
+           decalx   = 1.
+       ENDIF
+
+       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
+c
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * depi
+       ELSEIF( dzooma.LT. 25. ) THEN
+         WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) xzoom,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        xtild(i) = - pi + REAL(i) * depi /nmax2
+       ENDDO
+
+       DO i = nmax, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fhyp ( i ) = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fhyp ( i )  =   1.
+                ENDIF
+            ELSE
+                    fhyp ( i )  =  TANH ( fa/fb )
+            ENDIF
+         ENDIF
+        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
+        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+
+       ffdx = 0.
+
+       DO i = nmax +1,nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fxm   = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fxm   =   1.
+                ENDIF
+            ELSE
+                    fxm   =  TANH ( fa/fb )
+            ENDIF
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm  =  1.
+       IF ( xmoy.EQ. pi )  fxm  = -1.
+
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT
+       ENDIF
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = nmax, nmax2
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i =  nmax+1, nmax2
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+       Xf(0) = - pi
+
+       DO i =  nmax +1, nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm =  1.
+       IF ( xmoy.EQ. pi )  fxm = -1.
+       xxpr(i)    = beta + ( grossism - beta ) * fxm
+
+       ENDDO
+
+       DO i = nmax+1, nmax2
+        xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1, 4
+
+       IF( ik.EQ.1 )        THEN
+         xuv =  -0.25
+       ELSE IF ( ik.EQ.2 )  THEN
+         xuv =   0.
+       ELSE IF ( ik.EQ.3 )  THEN
+         xuv =   0.50
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+      xo1   = 0.
+
+      ii1=1
+      ii2=iim
+      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
+        ii1 = 2 
+        ii2 = iim+1
+      ENDIF
+      DO 1500 i = ii1, ii2
+
+      xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim) 
+
+      Xfi    = xlon2
+c
+      DO 250 it =  nmax2,0,-1
+      IF( Xfi.GE.Xf(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+
+350   CONTINUE
+
+c    ......  Calcul de   Xf(xi)    ...... 
+c
+      xi  = xtild(it)
+
+      IF(it.EQ.nmax2)  THEN
+       it       = nmax2 -1
+       Xf(it+1) = pi
+      ENDIF
+c  .....................................................................
+c
+c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
+c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
+c          et (Xf(it+1),xtild(it+1) )
+
+       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
+     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
+
+       Xf1     = Xf(it)
+       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
+
+       DO 500 iter = 1,300
+        xi = xi - ( Xf1 - Xfi )/ Xprimin
+
+        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
+         xo1      = xi
+         xi2      = xi * xi
+         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
+         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
+550   CONTINUE
+
+       xxprim(i) = depi/ ( REAL(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
+
+1500   CONTINUE
+
+
+       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
+         xvrai(1)    = xvrai(iip1)-depi
+         xxprim(1)   = xxprim(iip1)
+       ENDIF
+       DO i = 1 , iim
+        xlon(i)     = xvrai(i)
+        xprimm(i)   = xxprim(i)
+       ENDDO
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
+        ENDIF
+       ENDDO
+c
+c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
+c   ........................................................................
+
+       champmin =  1.e12
+       champmax = -1.e12
+       DO i = 1, iim
+        champmin = MIN( champmin,xvrai(i) )
+        champmax = MAX( champmax,xvrai(i) )
+       ENDDO
+
+      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
+                GO TO 1600
+      ELSE
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
+ 80       CONTINUE
+          is2 = i
+          ENDIF
+
+          IF( is2.NE. 1 )  THEN
+            DO ii = is2 , iim
+             xlon  (ii-is2+1) = xvrai(ii)
+             xprimm(ii-is2+1) = xxprim(ii)
+            ENDDO
+            DO ii = 1 , is2 -1
+             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
+             xprimm(ii+iim-is2+1) = xxprim(ii) 
+            ENDDO
+          ENDIF
+        ELSE 
+          IF( ik.EQ.1 )  THEN
+           DO i = iim,1,-1
+             IF( xvrai(i).LE. pi ) GO TO 90
+           ENDDO
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+           idif = iim -is2
+           DO ii = 1, is2
+            xlon  (ii+idif) = xvrai(ii)
+            xprimm(ii+idif) = xxprim(ii)
+           ENDDO
+           DO ii = 1, idif
+            xlon (ii)  = xvrai (ii+is2) - depi
+            xprimm(ii) = xxprim(ii+is2) 
+           ENDDO
+         ENDIF
+      ENDIF
+c
+c     .........   Fin  de la reorganisation   ............................
+
+ 1600    CONTINUE
+
+
+         xlon  ( iip1)  = xlon(1) + depi
+         xprimm( iip1 ) = xprimm (1 )
+       
+         DO i = 1, iim+1
+         xvrai(i) = xlon(i)*180./pi
+         ENDDO
+
+         IF( ik.EQ.1 )  THEN
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim +1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.2 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.3)   THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.4 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+
+         ENDIF
+
+5000    CONTINUE
+c
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+18     FORMAT(/)
+24     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
+68     FORMAT(1x,7f9.2)
+566    FORMAT(1x,7f9.4)
+
+       RETURN
+       END
Index: LMDZ5/trunk/libf/fxy.F
===================================================================
--- LMDZ5/trunk/libf/fxy.F	(revision 1630)
+++ LMDZ5/trunk/libf/fxy.F	(revision 1630)
@@ -0,0 +1,69 @@
+!
+! $Id: fxy.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+      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"
+#include "serre.h"
+#include "comconst.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: LMDZ5/trunk/libf/fxyhyper.F
===================================================================
--- LMDZ5/trunk/libf/fxyhyper.F	(revision 1630)
+++ LMDZ5/trunk/libf/fxyhyper.F	(revision 1630)
@@ -0,0 +1,139 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy  ,   
+     ,                       xzoom, grossx, dzoomx,taux  ,
+     , rlatu,yprimu,rlatv,yprimv,rlatu1,  yprimu1,  rlatu2,  yprimu2  , 
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       IMPLICIT NONE
+c
+c      Auteur :  P. Le Van .
+c
+c      d'apres  formulations de R. Sadourny .
+c
+c
+c     Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp )
+c            par des  fonctions  a tangente hyperbolique .
+c
+c     Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom
+c                      et  yzoom )   :  
+c
+c     a) le grossissement du zoom  :  grossy  ( en y ) et grossx ( en x )
+c     b) l' extension     du zoom  :  dzoomy  ( en y ) et dzoomx ( en x )
+c     c) la raideur de la transition du zoom  :   taux et tauy   
+c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+
+c   .....  Arguments  ...
+c
+       REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy
+       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)
+       REAL(KIND=8)  dxmin, dxmax , dymin, dymax
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy  , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  dymin,dymax                                               )
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax         )
+
+
+        DO i = 1, iip1
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         STOP 13
+       ENDIF
+c
+       IF(rlatu2(j).LE.rlatu(j+1))  THEN
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FY **** '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Latitudes  '
+        WRITE(6,*) ' *********** '
+        WRITE(6,18)
+        WRITE(6,3)  dymin, dymax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Longitudes  '
+        WRITE(6,*) ' ************ '
+        WRITE(6,18)
+        WRITE(6,3)  dxmin, dxmax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+        WRITE(6,18)
+c
+3      Format(1x, ' Au centre du zoom , la longueur de la maille est',
+     ,  ' d environ ',f8.2 ,' degres  ',
+     , ' alors que la maille en dehors de la zone du zoom est d environ
+     , ', f8.2,' degres ' )
+18      FORMAT(/)
+
+       RETURN
+       END
+
Index: LMDZ5/trunk/libf/fxysinus.F
===================================================================
--- LMDZ5/trunk/libf/fxysinus.F	(revision 1630)
+++ LMDZ5/trunk/libf/fxysinus.F	(revision 1630)
@@ -0,0 +1,69 @@
+!
+! $Id: fxysinus.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+
+      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"
+#include "comconst.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: LMDZ5/trunk/libf/fyhyp.F
===================================================================
--- LMDZ5/trunk/libf/fyhyp.F	(revision 1630)
+++ LMDZ5/trunk/libf/fyhyp.F	(revision 1630)
@@ -0,0 +1,378 @@
+!
+! $Id: fyhyp.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau  ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  champmin,champmax                                            ) 
+
+cc    ...  Version du 01/04/2001 ....
+
+       IMPLICIT NONE
+c
+c    ...   Auteur :  P. Le Van  ... 
+c
+c    .......    d'apres  formulations  de R. Sadourny  .......
+c
+c     Calcule les latitudes et derivees dans la grille du GCM pour une
+c     fonction f(y) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc)
+c     dzoom  etant  la distance totale de la zone du zoom ( en radians )
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom   
+c
+c
+c N.B : Il vaut mieux avoir : grossism * dzoom  <  pi/2  (radians) ,en lati.
+c      ********************************************************************
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzooma,tau 
+c         ( rentres  par  run.def )
+
+c     .......  arguments  de sortie   .......
+c
+       REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+
+c
+c     .....     champs  locaux    .....
+c
+     
+       REAL   dzoom
+       REAL(KIND=8) ylat(jjp1), yprim(jjp1)
+       REAL(KIND=8) yuv
+       REAL(KIND=8) yt(0:nmax2)
+       REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2)
+       SAVE Ytprim, yt,Yf
+       REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2)
+       REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm
+       REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax
+       REAL(KIND=8) yfi,Yf1,ffdy
+       REAL(KIND=8) ypn,deply,y00
+       SAVE y00, deply
+
+       INTEGER i,j,it,ik,iter,jlat
+       INTEGER jpn,jjpn
+       SAVE jpn
+       REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m
+       REAL(KIND=8) fa(0:nmax2),fb(0:nmax2)
+       REAL y0min,y0max
+
+       REAL(KIND=8)     heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       pis2     = pi/2.
+       pisjm    = pi/ REAL(jjm)
+       epsilon  = 1.e-3
+       y0       =  yzoomdeg * pi/180. 
+
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * pi
+       ELSEIF( dzooma.LT. 12. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,18)
+       WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) y0,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        yt(i) = - pis2  + REAL(i)* pi /nmax2
+       ENDDO
+
+       heavyy0m = heavyside( -y0 )
+       heavyy0  = heavyside(  y0 )
+       y0min    = 2.*y0*heavyy0m - pis2
+       y0max    = 2.*y0*heavyy0  + pis2
+
+       fa = 999.999
+       fb = 999.999
+       
+       DO i = 0, nmax2 
+        IF( yt(i).LT.y0 )  THEN
+         fa (i) = tau*  (yt(i)-y0+dzoom/2. )
+         fb(i) =   (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) )
+        ELSEIF ( yt(i).GT.y0 )  THEN
+         fa(i) =   tau *(y0-yt(i)+dzoom/2. )
+         fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) 
+       ENDIF
+        
+       IF( 200.* fb(i) .LT. - fa(i) )   THEN
+         fhyp ( i) = - 1.
+       ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fhyp ( i) =   1.
+       ELSE  
+         fhyp(i) =  TANH ( fa(i)/fb(i) )
+       ENDIF
+
+       IF( yt(i).EQ.y0 )  fhyp(i) = 1.
+       IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT
+
+       ENDIF
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax2
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+
+c   .....  Calcul  de  Yf     ........
+
+       Yf(0) = - pis2
+       DO i = 1, nmax2
+        yypr(i)    = beta + ( grossism - beta ) * fxm(i)
+       ENDDO
+
+       DO i=1,nmax2
+        Yf(i)   = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) )
+       ENDDO
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1,4
+
+       IF( ik.EQ.1 )  THEN
+         yuv  = 0.
+         jlat = jjm + 1
+       ELSE IF ( ik.EQ.2 )  THEN
+         yuv  = 0.5
+         jlat = jjm 
+       ELSE IF ( ik.EQ.3 )  THEN
+         yuv  = 0.25
+         jlat = jjm 
+       ELSE IF ( ik.EQ.4 )  THEN
+         yuv  = 0.75
+         jlat = jjm 
+       ENDIF
+c
+       yo1   = 0.
+       DO 1500 j =  1,jlat
+        yo1   = 0.
+        ylon2 =  - pis2 + pisjm * ( REAL(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
+       DO 250 it =  nmax2,0,-1
+        IF( yfi.GE.Yf(it))  GO TO 350
+250    CONTINUE
+       it = 0
+350    CONTINUE
+
+       yi = yt(it)
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = pis2
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1),   
+     ,                  yt(it),yt(it+1) ,   a0,a1,a2,a3   )      
+
+       Yf1     = Yf(it)
+       Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi
+
+       DO 500 iter = 1,300
+         yi = yi - ( Yf1 - yfi )/ Yprimin
+
+        IF( ABS(yi-yo1).LE.epsilon)  GO TO 550
+         yo1      = yi
+         yi2      = yi * yi
+         Yf1      = a0 +  a1 * yi +     a2 * yi2  +     a3 * yi2 * yi
+         Yprimin  =       a1      + 2.* a2 *  yi  + 3.* a3 * yi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
+550   CONTINUE
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
+
+1500    CONTINUE
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         WRITE(6,*) ' PBS. avec  rlat(',j+1,') plus petit que rlat(',j,
+     ,  ')'
+         STOP 3
+        ENDIF
+       ENDDO
+
+       WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2'
+     , ,' et  pi/2 '
+c
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 
+          DO j = jlat,1,-1
+           IF( yvrai(j).LE. ypn ) GO TO 1502
+          ENDDO
+1502     CONTINUE
+
+         jpn   = j
+         y00   = yvrai(jpn)
+         deply = pis2 -  y00
+        ENDIF
+
+         DO  j = 1, jjm +1 - jpn
+           ylatt (j)  = -pis2 - y00  + yvrai(jpn+j-1)
+           yprimm(j)  = yprim(jpn+j-1)
+         ENDDO
+
+         jjpn  = jpn
+         IF( jlat.EQ. jjm ) jjpn = jpn -1
+
+         DO j = 1,jjpn 
+          ylatt (j + jjm+1 -jpn) = yvrai(j) + deply
+          yprimm(j + jjm+1 -jpn) = yprim(j)
+         ENDDO
+
+c      ***********   Fin de la reorganisation     *************
+c
+ 1600   CONTINUE
+
+       DO j = 1, jlat
+          ylat(j) =  ylatt( jlat +1 -j )
+         yprim(j) = yprimm( jlat +1 -j )
+       ENDDO
+  
+        DO j = 1, jlat
+         yvrai(j) = ylat(j)*180./pi
+        ENDDO
+
+        IF( ik.EQ.1 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U   apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 2 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*) ' YLAT   en V  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*)' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 3 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U + 0.75  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT en U + 0.25  apres ( en  deg. ) '
+c         WRITE(6,68)(yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,68) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+
+        ENDIF
+
+5000   CONTINUE
+c
+        WRITE(6,18)
+c
+c  .....     fin de la boucle  do 5000 .....
+
+        DO j = 1, jjm
+         ylat(j) = rrlatu(j) - rrlatu(j+1)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO j = 1, jjm
+         champmin = MIN( champmin, ylat(j) )
+         champmax = MAX( champmax, ylat(j) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+24     FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3)
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: LMDZ5/trunk/libf/gcm.F
===================================================================
--- LMDZ5/trunk/libf/gcm.F	(revision 1630)
+++ LMDZ5/trunk/libf/gcm.F	(revision 1630)
@@ -0,0 +1,521 @@
+!
+! $Id: gcm.F 1316 2010-02-22 14:51:12Z acozic $
+!
+c
+c
+      PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+
+      USE mod_const_mpi, ONLY: init_const_mpi
+      USE parallel
+      USE infotrac
+      USE mod_interface_dyn_phys
+      USE mod_hallo
+      USE Bands
+      USE getparam
+      USE filtreg_mod
+      USE control_mod
+
+! Ehouarn: for now these only apply to Earth:
+#ifdef CPP_EARTH
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+      USE mod_phys_lmdz_omp_data, ONLY: klon_omp 
+      USE dimphy
+      USE comgeomphy
+#endif
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+c  ... Possibilite de choisir le schema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "tracstoke.h"
+#include "indicesol.h"
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+      SAVE  clesphy0
+
+
+
+      REAL zdtvr
+c      INTEGER nbetatmoy, nbetatdem,nbetat
+      INTEGER nbetatmoy, nbetatdem
+
+c   variables dynamiques
+      REAL,ALLOCATABLE,SAVE  :: vcov(:,:),ucov(:,:) ! vents covariants
+      REAL,ALLOCATABLE,SAVE  :: teta(:,:)     ! temperature potentielle 
+      REAL, ALLOCATABLE,SAVE :: q(:,:,:)      ! champs advectes
+      REAL,ALLOCATABLE,SAVE  :: ps(:)         ! pression  au sol
+c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+c      REAL pks(ip1jmp1)                      ! exner au  sol
+c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL,ALLOCATABLE,SAVE  :: masse(:,:)    ! masse d'air
+      REAL,ALLOCATABLE,SAVE  :: phis(:)       ! geopotentiel au sol
+c      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+c      REAL w(ip1jmp1,llm)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL time_0
+
+      LOGICAL lafin
+c      INTEGER ij,iq,l,i,j
+      INTEGER i,j
+
+
+      real time_step, t_wrt, t_ops
+
+
+      LOGICAL call_iniphys
+      data call_iniphys/.true./
+
+c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+c+jld variables test conservation energie
+c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+c      REAL dhecdt(ip1jmp1,llm)
+c      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+c      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+c      CHARACTER (len=15) :: ztit
+c-jld 
+
+
+      character (len=80) :: dynhist_file, dynhistave_file
+      character (len=20) :: modname
+      character (len=80) :: abort_message
+! locales pour gestion du temps
+      INTEGER :: an, mois, jour
+      REAL :: heure
+
+
+c-----------------------------------------------------------------------
+c    variables pour l'initialisation de la physique :
+c    ------------------------------------------------
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx)
+      REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
+      
+      INTEGER :: ierr
+
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      abort_message = 'last timestep reached'
+      modname = 'gcm'
+      descript = 'Run GCM LMDZ'
+      lafin    = .FALSE.
+      dynhist_file = 'dyn_hist'
+      dynhistave_file = 'dyn_hist_ave'
+
+
+
+c----------------------------------------------------------------------
+c  lecture des fichiers gcm.def ou run.def
+c  ---------------------------------------
+c
+! Ehouarn: dump possibility of using defrun
+!#ifdef CPP_IOIPSL
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+!#else
+!      CALL defrun( 99, .TRUE. , clesphy0 )
+!#endif
+c
+c
+c------------------------------------
+c   Initialisation partie parallele
+c------------------------------------
+      CALL init_const_mpi
+
+      call init_parallel
+      call ini_getparam("out.def")
+      call Read_Distrib
+! Ehouarn : temporarily (?) keep this only for Earth
+      if (planet_type.eq."earth") then
+#ifdef CPP_EARTH
+        CALL Init_Phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys)
+#endif
+      endif ! of if (planet_type.eq."earth")
+      CALL set_bands
+#ifdef CPP_EARTH
+! Ehouarn: For now only Earth physics is parallel
+      CALL Init_interface_dyn_phys
+#endif
+      CALL barrier
+
+      if (mpi_rank==0) call WriteBands
+      call Set_Distrib(distrib_caldyn)
+
+c$OMP PARALLEL
+      call Init_Mod_hallo
+c$OMP END PARALLEL
+
+! Ehouarn : temporarily (?) keep this only for Earth
+      if (planet_type.eq."earth") then
+#ifdef CPP_EARTH
+c$OMP PARALLEL
+      call InitComgeomphy
+c$OMP END PARALLEL 
+#endif
+      endif ! of if (planet_type.eq."earth")
+
+c-----------------------------------------------------------------------
+c   Choix du calendrier
+c   -------------------
+
+c      calend = 'earth_365d'
+
+#ifdef CPP_IOIPSL
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360d')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+      else if (calend == 'earth_365d') then
+        call ioconf_calendar('noleap')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+      else if (calend == 'earth_366d') then
+        call ioconf_calendar('gregorian')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
+      else
+        abort_message = 'Mauvais choix de calendrier'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#endif
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         call init_const_lmdz(
+     $        nbtr,anneeref,dayref,
+     $        iphysiq,day_step,nday, 
+     $        nbsrf, is_oce,is_sic,
+     $        is_ter,is_lic)
+
+         call init_inca_para(
+     $        iim,jjm+1,llm,klon_glo,mpi_size,
+     $        distrib_phys,COMM_LMDZ)
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des traceurs
+c   ---------------------------
+c  Choix du nombre de traceurs et du schema pour l'advection
+c  dans fichier traceur.def, par default ou via INCA
+      call infotrac_init
+
+c Allocation de la tableau q : champs advectes   
+      ALLOCATE(ucov(ijb_u:ije_u,llm))
+      ALLOCATE(vcov(ijb_v:ije_v,llm))
+      ALLOCATE(teta(ijb_u:ije_u,llm))
+      ALLOCATE(masse(ijb_u:ije_u,llm))
+      ALLOCATE(ps(ijb_u:ije_u))
+      ALLOCATE(phis(ijb_u:ije_u))
+      ALLOCATE(q(ijb_u:ije_u,llm,nqtot))
+
+c-----------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+
+c  lecture du fichier start.nc
+      if (read_start) then
+      ! we still need to run iniacademic to initialize some
+      ! constants & fields, if we run the 'newtonian' case:
+        if (iflag_phys.eq.2) then
+          CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+        endif
+!#ifdef CPP_IOIPSL
+        if (planet_type.eq."earth") then
+#ifdef CPP_EARTH
+! Load an Earth-format start file
+         CALL dynetat0_loc("start.nc",vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+#endif
+        endif ! of if (planet_type.eq."earth")
+c       write(73,*) 'ucov',ucov
+c       write(74,*) 'vcov',vcov
+c       write(75,*) 'teta',teta
+c       write(76,*) 'ps',ps
+c       write(77,*) 'q',q
+
+      endif ! of if (read_start)
+
+c le cas echeant, creation d un etat initial
+      IF (prt_level > 9) WRITE(lunout,*)
+     .              'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
+      if (.not.read_start) then
+         CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+      endif
+
+c-----------------------------------------------------------------------
+c   Lecture des parametres de controle pour la simulation :
+c   -------------------------------------------------------
+c  on recalcule eventuellement le pas de temps
+
+      IF(MOD(day_step,iperiod).NE.0) THEN
+        abort_message = 
+     .  'Il faut choisir un nb de pas par jour multiple de iperiod'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      IF(MOD(day_step,iphysiq).NE.0) THEN
+        abort_message = 
+     * 'Il faut choisir un nb de pas par jour multiple de iphysiq'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      zdtvr    = daysec/REAL(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         WRITE(lunout,*)
+     .    'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+C
+C on remet le calendrier à zero si demande
+c
+      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+        write(lunout,*)
+     .  'GCM: Attention les dates initiales lues dans le fichier'
+        write(lunout,*)
+     .  ' restart ne correspondent pas a celles lues dans '
+        write(lunout,*)' gcm.def'
+	write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+	write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+        if (raz_date .ne. 1) then
+          write(lunout,*)
+     .    'GCM: On garde les dates du fichier restart'
+        else
+          annee_ref = anneeref
+          day_ref = dayref
+          day_ini = dayref
+          itau_dyn = 0
+          itau_phy = 0
+          time_0 = 0.
+          write(lunout,*)
+     .   'GCM: On reinitialise a la date lue dans gcm.def'
+        endif
+      ELSE
+        raz_date = 0
+      endif
+
+#ifdef CPP_IOIPSL
+      mois = 1
+      heure = 0.
+      call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
+      jH_ref = jD_ref - int(jD_ref)
+      jD_ref = int(jD_ref)
+
+      call ioconf_startdate(INT(jD_ref), jH_ref)
+
+      write(lunout,*)'DEBUG'
+      write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
+      write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
+      call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
+      write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
+      write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
+#else
+! Ehouarn: we still need to define JD_ref and JH_ref
+! and since we don't know how many days there are in a year
+! we set JD_ref to 0 (this should be improved ...)
+      jD_ref=0
+      jH_ref=0
+#endif
+
+c  nombre d'etats dans les fichiers demarrage et histoire
+      nbetatdem = nday / iecri
+      nbetatmoy = nday / periodav + 1
+
+c-----------------------------------------------------------------------
+c   Initialisation des constantes dynamiques :
+c   ------------------------------------------
+      dtvr = zdtvr
+      CALL iniconst
+
+c-----------------------------------------------------------------------
+c   Initialisation de la geometrie :
+c   --------------------------------
+      CALL inigeom
+
+c-----------------------------------------------------------------------
+c   Initialisation du filtre :
+c   --------------------------
+      CALL inifilr
+c
+c-----------------------------------------------------------------------
+c   Initialisation de la dissipation :
+c   ----------------------------------
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+
+c-----------------------------------------------------------------------
+c   Initialisation de la physique :
+c   -------------------------------
+      IF (call_iniphys.and.iflag_phys.eq.1) THEN
+         latfi(1)=rlatu(1)
+         lonfi(1)=0.
+         zcufi(1) = cu(1)
+         zcvfi(1) = cv(1)
+         DO j=2,jjm
+            DO i=1,iim
+               latfi((j-2)*iim+1+i)= rlatu(j)
+               lonfi((j-2)*iim+1+i)= rlonv(i)
+               zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i)
+               zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i)
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)
+         lonfi(ngridmx)= 0.
+         zcufi(ngridmx) = cu(ip1jm+1)
+         zcvfi(ngridmx) = cv(ip1jm-iim)
+         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+
+         WRITE(lunout,*)
+     .       'GCM: WARNING!!! vitesse verticale nulle dans la physique'
+! Earth:
+         if (planet_type.eq."earth") then
+#ifdef CPP_EARTH
+         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys ,
+     ,                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp     )
+#endif
+         endif ! of if (planet_type.eq."earth")
+         call_iniphys=.false.
+      ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1))
+
+
+c-----------------------------------------------------------------------
+c   Initialisation des dimensions d'INCA :
+c   --------------------------------------
+      IF (config_inca /= 'none') THEN
+!$OMP PARALLEL
+#ifdef INCA
+         CALL init_inca_dim(klon_omp,llm,iim,jjm,
+     $        rlonu,rlatu,rlonv,rlatv)
+#endif
+!$OMP END PARALLEL
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des I/O :
+c   ------------------------
+
+
+      day_end = day_ini + nday
+      WRITE(lunout,300)day_ini,day_end
+ 300  FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)
+
+#ifdef CPP_IOIPSL
+      call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
+      write (lunout,301)jour, mois, an
+      call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
+      write (lunout,302)jour, mois, an
+ 301  FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
+ 302  FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
+#endif
+
+      if (planet_type.eq."earth") then
+        CALL dynredem0_loc("restart.nc", day_end, phis)
+      endif
+
+      ecripar = .TRUE.
+
+#ifdef CPP_IOIPSL
+      if ( 1.eq.1) then
+      time_step = zdtvr
+      t_ops = iecri * daysec
+      t_wrt = iecri * daysec
+!      CALL inithist_p(dynhist_file,day_ref,annee_ref,time_step,
+!     .              t_ops, t_wrt, histid, histvid)
+
+      IF (ok_dyn_ave) THEN 
+         t_ops = iperiod * time_step
+         t_wrt = periodav * daysec
+         CALL initdynav_loc(day_ref,annee_ref,time_step,t_ops,t_wrt)
+      END IF
+      dtav = iperiod*dtvr/daysec
+      endif
+
+
+#endif
+! #endif of #ifdef CPP_IOIPSL
+
+c  Choix des frequences de stokage pour le offline
+c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
+      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
+      istphy=istdyn/iphysiq     
+
+
+c
+c-----------------------------------------------------------------------
+c   Integration temporelle du modele :
+c   ----------------------------------
+
+c       write(78,*) 'ucov',ucov
+c       write(78,*) 'vcov',vcov
+c       write(78,*) 'teta',teta
+c       write(78,*) 'ps',ps
+c       write(78,*) 'q',q
+
+c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logic/)
+      CALL leapfrog_loc(ucov,vcov,teta,ps,masse,phis,q,clesphy0,
+     .              time_0)
+c$OMP END PARALLEL
+
+      OPEN(unit=5487,file='ok_lmdz',status='replace')
+      WRITE(5487,*) 'ok_lmdz'
+      CLOSE(5487)
+      END
+
Index: LMDZ5/trunk/libf/geopot.F
===================================================================
--- LMDZ5/trunk/libf/geopot.F	(revision 1630)
+++ LMDZ5/trunk/libf/geopot.F	(revision 1630)
@@ -0,0 +1,64 @@
+!
+! $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"
+#include "comvert.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   1  ij  = 1, ngrid
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+   1  CONTINUE
+
+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: LMDZ5/trunk/libf/geopot_loc.F
===================================================================
--- LMDZ5/trunk/libf/geopot_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/geopot_loc.F	(revision 1630)
@@ -0,0 +1,66 @@
+      SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
+      USE parallel
+      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"
+#include "comvert.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: LMDZ5/trunk/libf/geopot_p.F
===================================================================
--- LMDZ5/trunk/libf/geopot_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/geopot_p.F	(revision 1630)
@@ -0,0 +1,66 @@
+      SUBROUTINE geopot_p ( ngrid, teta, pk, pks, phis, phi )
+      USE parallel
+      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"
+#include "comvert.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,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: LMDZ5/trunk/libf/getparam.F90
===================================================================
--- LMDZ5/trunk/libf/getparam.F90	(revision 1630)
+++ LMDZ5/trunk/libf/getparam.F90	(revision 1630)
@@ -0,0 +1,118 @@
+!
+! $Id: getparam.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE getparam
+#ifdef CPP_IOIPSL
+   USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+   USE ioipsl_getincom
+#endif
+
+   INTERFACE getpar
+     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml
+   END INTERFACE
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+  USE parallel
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted')
+    
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+  USE parallel
+    !
+    IMPLICIT NONE
+    !
+      IF (mpi_rank==0) CLOSE(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+  USE parallel
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+    
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+  USE parallel
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) comment
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+    
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+  USE parallel
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+       
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: LMDZ5/trunk/libf/gr_dyn_fi.F
===================================================================
--- LMDZ5/trunk/libf/gr_dyn_fi.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_dyn_fi.F	(revision 1630)
@@ -0,0 +1,38 @@
+!
+! $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.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+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: LMDZ5/trunk/libf/gr_dyn_fi_p.F
===================================================================
--- LMDZ5/trunk/libf/gr_dyn_fi_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_dyn_fi_p.F	(revision 1630)
@@ -0,0 +1,49 @@
+!
+! $Id: gr_dyn_fi_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
+#ifdef CPP_EARTH
+! Interface with parallel physics,
+! for now this routine only works with Earth physics
+      USE mod_interface_dyn_phys
+      USE dimphy
+      USE PARALLEL
+      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,ig,l
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+c      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+c   traitement des poles
+c   traitement des point normaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,nfield    
+       DO ig=1,klon
+         i=index_i(ig)
+         j=index_j(ig)
+         pfi(ig,l)=pdyn(i,j,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#else
+      write(lunout,*) "gr_fi_dyn_p : This routine should not be called",
+     &   "without parallelized physics"
+      stop
+#endif
+! of #ifdef CPP_EARTH
+      RETURN
+      END
Index: LMDZ5/trunk/libf/gr_ecrit_fi.F
===================================================================
--- LMDZ5/trunk/libf/gr_ecrit_fi.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_ecrit_fi.F	(revision 1630)
@@ -0,0 +1,32 @@
+!
+! $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: LMDZ5/trunk/libf/gr_fi_dyn.F
===================================================================
--- LMDZ5/trunk/libf/gr_fi_dyn.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_fi_dyn.F	(revision 1630)
@@ -0,0 +1,40 @@
+!
+! $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: LMDZ5/trunk/libf/gr_fi_dyn_p.F
===================================================================
--- LMDZ5/trunk/libf/gr_fi_dyn_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_fi_dyn_p.F	(revision 1630)
@@ -0,0 +1,61 @@
+!
+! $Id: gr_fi_dyn_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
+#ifdef CPP_EARTH
+! Interface with parallel physics,
+! for now this routine only works with Earth physics
+      USE mod_interface_dyn_phys
+      USE dimphy
+      use parallel
+      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   -------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO ifield=1,nfield
+
+        do ig=1,klon
+          i=index_i(ig)
+          j=index_j(ig)
+          pdyn(i,j,ifield)=pfi(ig,ifield)
+          if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield)
+	enddo
+
+c   traitement des poles
+      if (pole_nord) then
+        do i=1,im
+	  pdyn(i,1,ifield)=pdyn(1,1,ifield)
+	enddo
+      endif
+       
+      if (pole_sud) then
+        do i=1,im
+	  pdyn(i,jm,ifield)=pdyn(1,jm,ifield)
+	enddo
+      endif
+      
+      ENDDO
+c$OMP END DO NOWAIT
+#else
+      write(lunout,*) "gr_fi_dyn_p : This routine should not be called",
+     &   "without parallelized physics"
+      stop
+#endif
+! of #ifdef CPP_EARTH
+      RETURN
+      END
Index: LMDZ5/trunk/libf/gr_int_dyn.F
===================================================================
--- LMDZ5/trunk/libf/gr_int_dyn.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_int_dyn.F	(revision 1630)
@@ -0,0 +1,49 @@
+!
+! $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 .eq. 1) then
+            champdyn(i, j) = polenord
+          else if (j .eq. 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: LMDZ5/trunk/libf/gr_u_scal.F
===================================================================
--- LMDZ5/trunk/libf/gr_u_scal.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_u_scal.F	(revision 1630)
@@ -0,0 +1,60 @@
+!
+! $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: LMDZ5/trunk/libf/gr_u_scal_loc.F
===================================================================
--- LMDZ5/trunk/libf/gr_u_scal_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_u_scal_loc.F	(revision 1630)
@@ -0,0 +1,75 @@
+!
+! $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
+      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: LMDZ5/trunk/libf/gr_u_scal_p.F
===================================================================
--- LMDZ5/trunk/libf/gr_u_scal_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_u_scal_p.F	(revision 1630)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_u_scal_p(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
+      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
+      INTEGER :: ijb,ije
+
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      
+      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
+
+cym      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+      ijb=ij_begin
+      ije=ij_end
+
+      DO l=1,nx
+         DO ij=ijb,ije-iip1+1,iip1
+	   x_scal(ij,l)=x_scal(ij+iip1-1,l)
+	 ENDDO
+      ENDDO
+      RETURN
+      
+      END
Index: LMDZ5/trunk/libf/gr_v_scal.F
===================================================================
--- LMDZ5/trunk/libf/gr_v_scal.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_v_scal.F	(revision 1630)
@@ -0,0 +1,64 @@
+!
+! $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: LMDZ5/trunk/libf/gr_v_scal_loc.F
===================================================================
--- LMDZ5/trunk/libf/gr_v_scal_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_v_scal_loc.F	(revision 1630)
@@ -0,0 +1,85 @@
+!
+! $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
+      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: LMDZ5/trunk/libf/gr_v_scal_p.F
===================================================================
--- LMDZ5/trunk/libf/gr_v_scal_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/gr_v_scal_p.F	(revision 1630)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_v_scal_p(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
+      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
+      INTEGER :: ijb,ije
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      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
+      
+      if (pole_nord) then
+        DO l=1,nx
+           DO ij=1,iip1
+              x_scal(ij,l)=0.
+           ENDDO
+        ENDDO
+      endif
+    
+      if (pole_sud) then
+        DO l=1,nx
+           DO ij=ip1jm+1,ip1jmp1
+              x_scal(ij,l)=0.
+           ENDDO
+        ENDDO
+      endif
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/grad.F
===================================================================
--- LMDZ5/trunk/libf/grad.F	(revision 1630)
+++ LMDZ5/trunk/libf/grad.F	(revision 1630)
@@ -0,0 +1,44 @@
+!
+! $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 6 l = 1,klevel
+c
+      DO 2  ij = 1, ip1jmp1 - 1
+      pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = iip1, ip1jmp1, iip1
+      pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      DO 4 ij = 1,ip1jm
+      pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/grad_loc.F
===================================================================
--- LMDZ5/trunk/libf/grad_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/grad_loc.F	(revision 1630)
@@ -0,0 +1,53 @@
+      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
+      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 6 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      DO 2  ij = ijb, ije - 1
+        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = ijb+iip1-1, ije, iip1
+        pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4 ij = ijb,ije
+        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/grad_p.F
===================================================================
--- LMDZ5/trunk/libf/grad_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/grad_p.F	(revision 1630)
@@ -0,0 +1,53 @@
+      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
+      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 6 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      DO 2  ij = ijb, ije - 1
+        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = ijb+iip1-1, ije, iip1
+        pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4 ij = ijb,ije
+        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/gradiv.F
===================================================================
--- LMDZ5/trunk/libf/gradiv.F	(revision 1630)
+++ LMDZ5/trunk/libf/gradiv.F	(revision 1630)
@@ -0,0 +1,57 @@
+!
+! $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"
+#include "logic.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 10 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 5  l = 1, klevel
+      DO 3 ij = 1, ip1jmp1
+      gdx( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+      DO 4 ij = 1, ip1jm
+      gdy( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/gradiv2.F
===================================================================
--- LMDZ5/trunk/libf/gradiv2.F	(revision 1630)
+++ LMDZ5/trunk/libf/gradiv2.F	(revision 1630)
@@ -0,0 +1,79 @@
+!
+! $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.GT.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: LMDZ5/trunk/libf/gradiv2_loc.F
===================================================================
--- LMDZ5/trunk/libf/gradiv2_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/gradiv2_loc.F	(revision 1630)
@@ -0,0 +1,149 @@
+      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
+      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)  :: 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.GT.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: LMDZ5/trunk/libf/gradiv2_mod.F90
===================================================================
--- LMDZ5/trunk/libf/gradiv2_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/gradiv2_mod.F90	(revision 1630)
@@ -0,0 +1,39 @@
+MODULE gradiv2_mod
+
+  REAL,POINTER,SAVE ::  gdx( :,: )
+  REAL,POINTER,SAVE ::  gdy( :,: )
+  REAL,POINTER,SAVE ::  div( :,: )
+  
+CONTAINS
+
+  SUBROUTINE gradiv2_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(gdx,llm,d)
+    CALL allocate_v(gdy,llm,d)
+    CALL allocate_u(div,llm,d)
+
+    
+  END SUBROUTINE gradiv2_allocate
+  
+  SUBROUTINE gradiv2_switch_dissip(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(gdx,distrib_dissip,dist)
+    CALL switch_v(gdy,distrib_dissip,dist)
+    CALL switch_u(div,distrib_dissip,dist)
+
+
+  END SUBROUTINE gradiv2_switch_dissip
+  
+END MODULE gradiv2_mod  
Index: LMDZ5/trunk/libf/gradiv2_p.F
===================================================================
--- LMDZ5/trunk/libf/gradiv2_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/gradiv2_p.F	(revision 1630)
@@ -0,0 +1,147 @@
+      SUBROUTINE gradiv2_p(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
+      USE times
+      USE Write_field_p
+      USE mod_hallo
+      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,SAVE ::  gdx( ip1jmp1,llm ),  gdy( ip1jm,llm )
+      REAL   gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL,SAVE :: div(ip1jmp1,llm)
+      REAL      :: tmp_div2(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      INTEGER :: ijb,ije,jjb,jje
+      Type(Request)  :: 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(gdy,ip1jm,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_p( klevel, gdx,   gdy , div )
+c      call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
+
+      IF( ld.GT.1 )   THEN
+c$OMP BARRIER
+       call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+	CALL laplacien_p ( 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(div,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+
+c$OMP BARRIER
+
+         CALL laplacien_gam ( 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,jje, jjp1, klevel, 2, 1, .TRUE., 1 )
+c       call exchange_Hallo(div,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+       call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+
+c$OMP BARRIER
+
+
+       CALL  grad_p  ( 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: LMDZ5/trunk/libf/gradiv_p.F
===================================================================
--- LMDZ5/trunk/libf/gradiv_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/gradiv_p.F	(revision 1630)
@@ -0,0 +1,109 @@
+      SUBROUTINE gradiv_p(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+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     
+      USE parallel
+      USE times
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE :: gdx( ip1jmp1,llm ),   gdy( ip1jm,llm )
+
+      REAL gdx_out( ip1jmp1,klevel ),   gdy_out( ip1jm,klevel )
+
+      REAL,SAVE ::  div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+      INTEGER ijb,ije,jjb,jje
+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
+      DO 10 iter = 1,ld
+
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(gdy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER      
+c$OMP BARRIER
+
+      CALL  diverg_p( klevel,  gdx , gdy, div          )
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2,1, .true.,2 )
+      
+c      call exchange_Hallo(div,ip1jmp1,llm,0,1)
+
+c$OMP BARRIER
+c$OMP MASTER       
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(div,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL    grad_p( klevel,  div, gdx, gdy           )
+c
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 5  l = 1, klevel
+      
+      if(pole_sud) ije=ij_end
+      DO 3 ij = ijb, ije
+        gdx_out( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+   
+      if(pole_sud) ije=ij_end-iip1
+      DO 4 ij = ijb, ije
+        gdy_out( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/gradsdef.h
===================================================================
--- LMDZ5/trunk/libf/gradsdef.h	(revision 1630)
+++ LMDZ5/trunk/libf/gradsdef.h	(revision 1630)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+      integer nfmx,imx,jmx,lmx,nvarmx
+      parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000)
+
+      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
+
+      integer imd(imx),jmd(jmx),lmd(lmx)
+      integer iid(imx),jid(jmx)
+      integer ifd(imx),jfd(jmx)
+      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
+
+      integer nvar(nfmx),ivar(nfmx)
+      logical firsttime(nfmx)
+
+      character*10 var(nvarmx,nfmx),fichier(nfmx)
+      character*40 title(nfmx),tvar(nvarmx,nfmx)
+
+      common/gradsdef/xd,yd,zd,dtime,
+     s   imd,jmd,lmd,iid,jid,ifd,jfd,
+     s   unit,irec,nvar,ivar,itime,nld,firsttime,
+     s   var,fichier,title,tvar
Index: LMDZ5/trunk/libf/grid_atob.F
===================================================================
--- LMDZ5/trunk/libf/grid_atob.F	(revision 1630)
+++ LMDZ5/trunk/libf/grid_atob.F	(revision 1630)
@@ -0,0 +1,971 @@
+!
+! $Id: grid_atob.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Aucune ponderation est consideree (voir grille_p)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+      REAL distans(2200*1100)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+c Calculer les limites des zones des nouveaux points
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c Determiner la zone sur laquelle chaque ancien point se trouve
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               number(ii,jj) = number(ii,jj) + 1.0
+               sortie(ii,jj) = sortie(ii,jj) + entree(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c Si aucun ancien point tombe sur une zone, c'est un probleme
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+      SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Consideration de la distance des points (voir grille_m)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(200),d(200)
+      REAL number(400,200)
+      INTEGER indx(400,200), indy(400,200)
+      REAL dist(400,200), distsom(400,200)
+c
+      IF (imar.GT.400 .OR. jmar.GT.200) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+      IF (imdep.GT.400 .OR. jmdep.GT.200) THEN
+         PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep
+         CALL ABORT
+      ENDIF
+c
+c calculer les bords a et b de la nouvelle grille
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+c
+c calculer les bords c et d de la nouvelle grille
+c
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+c
+c trouver les indices (indx,indy) de la nouvelle grille sur laquelle
+c un point de l'ancienne grille est tombe.
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               indx(i,j) = ii
+               indy(i,j) = jj
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c faire une verification
+c
+
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN
+            PRINT*, 'Probleme grave,i,j,indx,indy=',
+     .              i,j,indx(i,j),indy(i,j)
+            CALL abort
+         ENDIF
+      ENDDO
+      ENDDO
+
+c
+c calculer la distance des anciens points avec le nouveau point,
+c on prend ensuite une sorte d'inverse pour ponderation.
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         distsom(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2
+     .                     +(ydata(j)-y(indy(i,j)))**2 )
+         distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j))
+     .                                  + dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1.
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j))
+      ENDDO
+      ENDDO
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j))
+     .                                 + entree(i,j) * dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j))
+     .                                 + dist(i,j)
+      ENDDO
+      ENDDO
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+      SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief,
+     .                    imar, jmar, x, y, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique
+c                           un champ indicateur (masque) terre/ocean
+c                           terre:1; ocean:0
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL relief(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL num_tot(2200,1100), num_oce(2200,1100)
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_oce(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+               IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) )
+     .             num_oce(ii,jj) = num_oce(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+c
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN
+              mask(i,j) = 0.
+           ELSE
+              mask(i,j) = 1.
+           ENDIF
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c
+c
+
+
+      SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une
+c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur
+c fixe (0.001m).
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar), mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_tot(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              sortie(ii,jj)  = sortie(ii,jj) + LOG(entree(i,j))
+              num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+       IF (NINT(mask(i,j)).EQ.1) THEN
+         IF (num_tot(i,j) .GT. 0.0) THEN
+            sortie(i,j) = sortie(i,j) / num_tot(i,j)
+            sortie(i,j) = EXP(sortie(i,j))
+         ELSE
+            PRINT*, 'probleme,i,j=', i,j
+ccc            CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+       ELSE
+         sortie(i,j) = 0.001
+       ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+
+      SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01,
+     .                    imar, jmar, x, y, frac_ice)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la
+c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace
+c (entre 0 et 1) dans une grille plus grossiere.
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL glace01(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL frac_ice(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400), num_ice(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_ice(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+             num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+              IF (NINT(glace01(i,j)).EQ.1 ) 
+     .       num_ice(ii,jj) = num_ice(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF (num_ice(i,j).GT.0.001) THEN
+            frac_ice(i,j) = num_ice(i,j) / num_tot(i,j)
+           ELSE
+              frac_ice(i,j) = 0.0
+           ENDIF
+         ELSE
+           PRINT*, 'probleme,i,j=', i,j
+ccc           CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN
+            frac_ice(i,j) = 1.0
+         ELSE
+            frac_ice(i,j) = 0.0
+         ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+      SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief,
+     .                    immod, jmmod, xmod, ymod, rugs)
+c=======================================================================
+c Calculer la longueur de rugosite liee au relief en utilisant
+c l'ecart-type dans une maille de 1x1
+C=======================================================================
+      IMPLICIT none
+c
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      REAL amin, AMAX
+c
+      INTEGER imrel, jmrel
+      REAL xrel(imrel),yrel(jmrel)
+      REAL relief(imrel,jmrel)
+c
+      INTEGER immod, jmmod
+      REAL xmod(immod),ymod(jmmod)
+      REAL rugs(immod,jmmod)
+c
+      INTEGER imtmp, jmtmp
+      PARAMETER (imtmp=360,jmtmp=180)
+      REAL xtmp(imtmp), ytmp(jmtmp)
+      REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp)
+      REAL zzzz
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+c
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+c
+      IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN
+         PRINT*, 'immod ou jmmod trop grand', immod, jmmod
+         CALL ABORT
+      ENDIF
+c
+c Calculs intermediares:
+c
+      xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0
+      DO i = 2, imtmp
+         xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp)
+      ENDDO
+      DO i = 1, imtmp
+         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+      ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0
+      DO j = 2, jmtmp
+         ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp)
+      ENDDO
+      DO j = 1, jmtmp
+         ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+c
+      a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0
+      b(1) = (xtmp(1)+xtmp(2))/2.0
+      DO i = 2, imtmp-1
+         a(i) = b(i-1)
+         b(i) = (xtmp(i)+xtmp(i+1))/2.0
+      ENDDO
+      a(imtmp) = b(imtmp-1)
+      b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0
+
+      c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0
+      d(1) = (ytmp(1)+ytmp(2))/2.0
+      DO j = 2, jmtmp-1
+         c(j) = d(j-1)
+         d(j) = (ytmp(j)+ytmp(j+1))/2.0
+      ENDDO
+      c(jmtmp) = d(jmtmp-1)
+      d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0
+
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         number(i,j) = 0.0
+         cham1tmp(i,j) = 0.0
+         cham2tmp(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imtmp
+      DO jj = 1, jmtmp
+        DO i = 1, imrel
+         IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmrel
+          IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j)
+              cham2tmp(ii,jj) = cham2tmp(ii,jj) 
+     .                              + relief(i,j)*relief(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         IF (number(i,j) .GT. 0.001) THEN
+         cham1tmp(i,j) = cham1tmp(i,j) / number(i,j)
+         cham2tmp(i,j) = cham2tmp(i,j) / number(i,j)
+         zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2
+         if (zzzz .lt. 0.0) then
+           if (zzzz .gt. -7.5) then
+             zzzz = 0.0
+             print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0'
+           else
+              stop 'Pb rugsoro, zzzz <-7.5'
+           endif
+         endif
+         cham2tmp(i,j) = SQRT(zzzz)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = cham2tmp(1,1)
+      AMAX = cham2tmp(1,1)
+      DO j = 1, jmtmp
+      DO i = 1, imtmp
+         IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j)
+         IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type 1x1:', amin, AMAX
+c
+c
+c
+      a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0
+      b(1) = (xmod(1)+xmod(2))/2.0
+      DO i = 2, immod-1
+         a(i) = b(i-1)
+         b(i) = (xmod(i)+xmod(i+1))/2.0
+      ENDDO
+      a(immod) = b(immod-1)
+      b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0
+
+      c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0
+      d(1) = (ymod(1)+ymod(2))/2.0
+      DO j = 2, jmmod-1
+         c(j) = d(j-1)
+         d(j) = (ymod(j)+ymod(j+1))/2.0
+      ENDDO
+      c(jmmod) = d(jmmod-1)
+      d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         number(i,j) = 0.0
+         rugs(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, immod
+      DO jj = 1, jmmod
+        DO i = 1, imtmp
+         IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmtmp
+          IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              rugs(ii,jj) = rugs(ii,jj)
+     .                       + LOG(MAX(0.001_8,cham2tmp(i,j)))
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         IF (number(i,j) .GT. 0.001) THEN
+         rugs(i,j) = rugs(i,j) / number(i,j)
+         rugs(i,j) = EXP(rugs(i,j))
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imtmp*jmtmp,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imtmp*jmtmp
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imtmp + 1
+         i_proche = ij_proche - (j_proche-1)*imtmp
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche)))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type du modele:', amin, AMAX
+c
+      DO j = 1, jmmod
+      DO i = 1, immod
+         rugs(i,j) = rugs(i,j) / AMAX * 20.0
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Longueur de rugosite du modele:', amin, AMAX
+c
+      RETURN
+      END
+c
+      SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance)
+c
+c Auteur: Laurent Li (le 30 decembre 1996)
+c
+c Ce programme calcule la distance minimale (selon le grand cercle)
+c entre deux points sur la terre
+c
+c Input:
+      INTEGER im, jm ! dimensions
+      REAL rf_lon ! longitude du point de reference (degres)
+      REAL rf_lat ! latitude du point de reference (degres)
+      REAL rlon(im), rlat(jm) ! longitude et latitude des points
+c
+c Output:
+      REAL distance(im,jm) ! distances en metre
+c
+      REAL rlon1, rlat1
+      REAL rlon2, rlat2
+      REAL dist
+      REAL pa, pb, p, pi
+c
+      REAL radius
+      PARAMETER (radius=6371229.)
+c
+      pi = 4.0 * ATAN(1.0)
+c
+      DO 9999 j = 1, jm
+      DO 9999 i = 1, im
+c
+      rlon1=rf_lon
+      rlat1=rf_lat
+      rlon2=rlon(i)
+      rlat2=rlat(j)
+      pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a
+      pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b
+      p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens)
+c
+      dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p))
+      dist = radius * dist
+      distance(i,j) = dist
+c
+ 9999 CONTINUE
+c
+      END
Index: LMDZ5/trunk/libf/grid_noro.F
===================================================================
--- LMDZ5/trunk/libf/grid_noro.F	(revision 1630)
+++ LMDZ5/trunk/libf/grid_noro.F	(revision 1630)
@@ -0,0 +1,524 @@
+!
+! $Id: grid_noro.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+      SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata,
+     .             imar, jmar, x, y,
+     .             zphi,zmea,zstd,zsig,zgam,zthe,
+     .             zpic,zval,mask)
+c=======================================================================
+c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead)
+c
+c      Compute the Parameters of the SSO scheme as described in
+c      LOTT & MILLER (1997) and LOTT(1999).
+c      Target points are on a rectangular grid:
+c      iim+1 latitudes including North and South Poles;
+c      jjm+1 longitudes, with periodicity jjm+1=1.
+c      aux poles.  At the poles the fields value is repeated
+c      jjm+1 time.
+c      The parameters a,b,c,d represent the limite of the target
+c      gridpoint region. The means over this region are calculated
+c      from USN data, ponderated by a weight proportional to the 
+c      surface occupated by the data inside the model gridpoint area.
+c      In most circumstances, this weight is the ratio between the
+c      surface of the USN gridpoint area and the surface of the
+c      model gridpoint area. 
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X and Y input field
+c        xdata, ydata: coordinates X and Y input field
+c        zdata: Input field
+c        In this version it is assumed that the entry data come from
+c        the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080.
+c OUTPUT:
+c        imar, jmar: dimensions X and Y Output field
+c        x, y: ccordinates  X and Y Output field.
+c             zmea:  Mean orographie   
+c             zstd:  Standard deviation
+c             zsig:  Slope
+c             zgam:  Anisotropy
+c             zthe:  Orientation of the small axis
+c             zpic:  Maximum altitude
+c             zval:  Minimum altitude
+C=======================================================================
+
+      IMPLICIT INTEGER (I,J)
+      IMPLICIT REAL(X,Z) 
+      
+	  parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5)
+#include "dimensions.h"
+	  REAL xusn(iusn+2*iext),yusn(jusn+2)	
+      REAL zusn(iusn+2*iext,jusn+2)
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL zdata(imdep,jmdep)
+c
+      INTEGER imar, jmar
+  
+C INTERMEDIATE FIELDS  (CORRELATIONS OF OROGRAPHY GRADIENT)
+
+      REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1)
+      REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1)
+      REAL weight(iim+1,jjm+1)
+
+C CORRELATIONS OF USN OROGRAPHY GRADIENTS
+
+      REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2)
+      REAL zxtzyusn(iusn+2*iext,jusn+2)
+      REAL x(imar+1),y(jmar),zphi(imar+1,jmar)
+      REAL zmea(imar+1,jmar),zstd(imar+1,jmar)
+      REAL zmea0(imar+1,jmar) ! GK211005 (CG)
+      REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar)
+      REAL zpic(imar+1,jmar),zval(imar+1,jmar)
+cxxx PB     integer mask(imar+1,jmar)
+      real mask(imar+1,jmar), mask_tmp(imar+1,jmar)
+      real num_tot(2200,1100),num_lan(2200,1100)
+c
+      REAL a(2200),b(2200),c(1100),d(1100)
+      logical masque_lu
+c
+      print *,' parametres de l orographie a l echelle sous maille' 
+      xpi=acos(-1.)
+      rad    = 6 371 229.
+      zdeltay=2.*xpi/REAL(jusn)*rad
+c
+c utilise-t'on un masque lu?
+c
+      masque_lu = .true.
+      if (maxval(mask) == -99999 .and. minval(mask) == -99999) then
+        masque_lu= .false.
+        masque = 0.0
+      endif
+      write(*,*)'Masque lu', masque_lu
+c
+c  quelques tests de dimensions:
+c    
+c
+      if(iim.ne.imar) STOP 'Problem dim. x'
+      if(jjm.ne.jmar-1) STOP 'Problem dim. y'
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar or jmar too big', imar, jmar
+         CALL ABORT
+      ENDIF
+
+      IF(imdep.ne.iusn.or.jmdep.ne.jusn)then
+         print *,' imdep or jmdep bad dimensions:',imdep,jmdep
+         call abort
+      ENDIF
+
+      IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN
+        print *,' imar or jmar bad dimensions:',imar,jmar
+        call abort
+      ENDIF
+
+
+c      print *,'xdata:',xdata
+c      print *,'ydata:',ydata
+c      print *,'x:',x
+c      print *,'y:',y
+c
+C  EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT
+C  BOUNDARIES:
+c
+      DO j=1,jusn
+        yusn(j+1)=ydata(j)
+      DO i=1,iusn
+        zusn(i+iext,j+1)=zdata(i,j)
+        xusn(i+iext)=xdata(i)
+      ENDDO
+      DO i=1,iext
+        zusn(i,j+1)=zdata(iusn-iext+i,j)
+        xusn(i)=xdata(iusn-iext+i)-2.*xpi
+        zusn(iusn+iext+i,j+1)=zdata(i,j)
+        xusn(iusn+iext+i)=xdata(i)+2.*xpi
+      ENDDO
+      ENDDO
+
+        yusn(1)=ydata(1)+(ydata(1)-ydata(2))
+        yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1))
+       DO i=1,iusn/2+iext
+        zusn(i,1)=zusn(i+iusn/2,2)
+        zusn(i+iusn/2+iext,1)=zusn(i,2)
+        zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1)
+        zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1)
+       ENDDO
+c  
+c COMPUTE LIMITS OF MODEL GRIDPOINT AREA
+C     ( REGULAR GRID)
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar+1) = b(imar)
+      b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+c
+c  initialisations:
+c
+      DO i = 1, imar+1
+      DO j = 1, jmar
+         weight(i,j) = 0.0
+         zxtzx(i,j)  = 0.0
+         zytzy(i,j)  = 0.0
+         zxtzy(i,j)  = 0.0
+         ztz(i,j)    = 0.0
+         zmea(i,j)   = 0.0
+         zpic(i,j)  =-1.E+10
+         zval(i,j)  = 1.E+10
+      ENDDO
+      ENDDO
+c
+c  COMPUTE SLOPES CORRELATIONS ON USN GRID
+c
+         DO j = 1,jusn+2 
+         DO i = 1, iusn+2*iext
+            zytzyusn(i,j)=0.0
+            zxtzxusn(i,j)=0.0
+            zxtzyusn(i,j)=0.0
+         ENDDO
+         ENDDO
+
+
+         DO j = 2,jusn+1 
+            zdeltax=zdeltay*cos(yusn(j))
+         DO i = 2, iusn+2*iext-1
+            zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2
+            zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2
+            zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay
+     *                   *(zusn(i+1,j)-zusn(i-1,j))/zdeltax
+         ENDDO
+         ENDDO
+c
+c  SUMMATION OVER GRIDPOINT AREA
+c 
+      zleny=xpi/REAL(jusn)*rad
+      xincr=xpi/2./REAL(jusn)
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+       num_tot(ii,jj)=0.
+       num_lan(ii,jj)=0.
+c        PRINT *,' iteration ii jj:',ii,jj
+         DO j = 2,jusn+1 
+c         DO j = 3,jusn 
+            zlenx=zleny*cos(yusn(j))
+            zdeltax=zdeltay*cos(yusn(j))
+            zbordnor=(c(jj)-yusn(j)+xincr)*rad
+            zbordsud=(yusn(j)-d(jj)+xincr)*rad
+            weighy=AMAX1(0.,
+     *             amin1(zbordnor,zbordsud,zleny))
+         IF(weighy.ne.0)THEN
+         DO i = 2, iusn+2*iext-1
+            zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j))
+            zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j))
+            weighx=AMAX1(0.,
+     *             amin1(zbordest,zbordoue,zlenx))
+            IF(weighx.ne.0)THEN
+            num_tot(ii,jj)=num_tot(ii,jj)+1.0
+            if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
+            weight(ii,jj)=weight(ii,jj)+weighx*weighy
+            zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy
+            zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy
+            zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy
+            ztz(ii,jj)  =ztz(ii,jj)  +zusn(i,j)*zusn(i,j)*weighx*weighy
+c mean
+            zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy
+c peacks
+            zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j))
+c valleys
+            zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j))
+            ENDIF
+         ENDDO
+         ENDIF
+         ENDDO
+       ENDDO
+       ENDDO
+c
+c  COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND
+C  LOTT (1999) SSO SCHEME.
+c
+      zllmmea=0.
+      zllmstd=0.
+      zllmsig=0.
+      zllmgam=0.
+      zllmpic=0.
+      zllmval=0.
+      zllmthe=0.
+      zminthe=0.
+c     print 100,' '
+c100  format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') 
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Mask
+cXXX           if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then
+cXXX             mask(ii,jj)=1
+cXXX           else
+cXXX             mask(ii,jj)=0
+cXXX           ENDIF
+             if (.not. masque_lu) then
+               mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj)
+             endif
+c  Mean Orography:
+           zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj)
+           zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj)
+           zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj)
+           zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj)
+           ztz(ii,jj)  =ztz(ii,jj)/weight(ii,jj)
+c  Standard deviation:
+           zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2))
+         ELSE
+            PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+       ENDDO
+       ENDDO
+
+C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES:
+
+       DO ii = 1, imar+1
+         zxtzx(ii,1)=zxtzx(ii,2)
+         zxtzx(ii,jmar)=zxtzx(ii,jmar-1)
+         zxtzy(ii,1)=zxtzy(ii,2)
+         zxtzy(ii,jmar)=zxtzy(ii,jmar-1)
+         zytzy(ii,1)=zytzy(ii,2)
+         zytzy(ii,jmar)=zytzy(ii,jmar-1)
+       ENDDO
+
+C  FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME.
+
+C  FIRST FILTER, MOVING AVERAGE OVER 9 POINTS.
+
+       zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee
+       CALL MVA9(zmea,iim+1,jjm+1)
+       CALL MVA9(zstd,iim+1,jjm+1)
+       CALL MVA9(zpic,iim+1,jjm+1)
+       CALL MVA9(zval,iim+1,jjm+1)
+       CALL MVA9(zxtzx,iim+1,jjm+1)
+       CALL MVA9(zxtzy,iim+1,jjm+1) 
+       CALL MVA9(zytzy,iim+1,jjm+1)
+CXXX   Masque prenant en compte maximum de terre
+CXXX  On seuil a 10% de terre de terre car en dessous les parametres de surface n'on
+CXXX pas de sens (PB)
+       mask_tmp= 0.0
+       WHERE(mask .GE. 0.1) mask_tmp = 1.
+
+       DO ii = 1, imar
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Coefficients K, L et M:
+           xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2.
+           xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2.
+           xm=zxtzy(ii,jj)
+           xp=xk-sqrt(xl**2+xm**2)
+           xq=xk+sqrt(xl**2+xm**2)
+           xw=1.e-8
+           if(xp.le.xw) xp=0.
+           if(xq.le.xw) xq=xw
+           if(abs(xm).le.xw) xm=xw*sign(1.,xm)
+c slope: 
+cXXX           zsig(ii,jj)=sqrt(xq)*mask(ii,jj)
+cXXXc isotropy:
+cXXX           zgam(ii,jj)=xp/xq*mask(ii,jj)
+cXXXc angle theta:
+cXXX           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj)
+cXXX           zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+cXXX           zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+cXXX           zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj)
+cXXX           zval(ii,jj)=zval(ii,jj)*mask(ii,jj)
+cXXX           zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj)
+CXX* PB modif pour maque de terre fractionnaire
+c slope: 
+           zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj)
+c isotropy:
+           zgam(ii,jj)=xp/xq*mask_tmp(ii,jj)
+c angle theta:
+           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj)
+           ! GK211005 (CG) ne pas forcement lisser la topo
+           ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj)
+           !
+           zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj)
+           zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj)
+           zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj)
+c          print 101,ii,jj,
+c    *           zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj),
+c    *           zthe(ii,jj)
+c101  format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1)     
+         ELSE
+c           PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+      zllmmea=AMAX1(zmea(ii,jj),zllmmea)
+      zllmstd=AMAX1(zstd(ii,jj),zllmstd)
+      zllmsig=AMAX1(zsig(ii,jj),zllmsig)
+      zllmgam=AMAX1(zgam(ii,jj),zllmgam)
+      zllmthe=AMAX1(zthe(ii,jj),zllmthe)
+      zminthe=amin1(zthe(ii,jj),zminthe)
+      zllmpic=AMAX1(zpic(ii,jj),zllmpic)
+      zllmval=AMAX1(zval(ii,jj),zllmval)
+       ENDDO
+       ENDDO
+      print *,'  MEAN ORO:',zllmmea
+      print *,'  ST. DEV.:',zllmstd
+      print *,'  PENTE:',zllmsig
+      print *,' ANISOTROP:',zllmgam
+      print *,'  ANGLE:',zminthe,zllmthe	
+      print *,'  pic:',zllmpic
+      print *,'  val:',zllmval
+      
+C
+c gamma and theta a 1. and 0. at poles
+c
+      DO jj=1,jmar
+      zmea(imar+1,jj)=zmea(1,jj)
+      zphi(imar+1,jj)=zphi(1,jj)
+      zpic(imar+1,jj)=zpic(1,jj)
+      zval(imar+1,jj)=zval(1,jj)
+      zstd(imar+1,jj)=zstd(1,jj)
+      zsig(imar+1,jj)=zsig(1,jj)
+      zgam(imar+1,jj)=zgam(1,jj)
+      zthe(imar+1,jj)=zthe(1,jj)
+      ENDDO
+
+
+      zmeanor=0.0
+      zmeasud=0.0
+      zstdnor=0.0
+      zstdsud=0.0
+      zsignor=0.0
+      zsigsud=0.0
+      zweinor=0.0
+      zweisud=0.0
+      zpicnor=0.0
+      zpicsud=0.0                                   
+      zvalnor=0.0
+      zvalsud=0.0 
+
+      DO ii=1,imar
+      zweinor=zweinor+              weight(ii,   1)
+      zweisud=zweisud+              weight(ii,jmar)
+      zmeanor=zmeanor+zmea(ii,   1)*weight(ii,   1)
+      zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar)
+      zstdnor=zstdnor+zstd(ii,   1)*weight(ii,   1)
+      zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar)
+      zsignor=zsignor+zsig(ii,   1)*weight(ii,   1)
+      zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar)
+      zpicnor=zpicnor+zpic(ii,   1)*weight(ii,   1)
+      zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar)
+      zvalnor=zvalnor+zval(ii,   1)*weight(ii,   1)
+      zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar)
+      ENDDO
+
+      DO ii=1,imar+1
+      zmea(ii,   1)=zmeanor/zweinor
+      zmea(ii,jmar)=zmeasud/zweisud
+      zphi(ii,   1)=zmeanor/zweinor
+      zphi(ii,jmar)=zmeasud/zweisud
+      zpic(ii,   1)=zpicnor/zweinor
+      zpic(ii,jmar)=zpicsud/zweisud
+      zval(ii,   1)=zvalnor/zweinor
+      zval(ii,jmar)=zvalsud/zweisud
+      zstd(ii,   1)=zstdnor/zweinor
+      zstd(ii,jmar)=zstdsud/zweisud
+      zsig(ii,   1)=zsignor/zweinor
+      zsig(ii,jmar)=zsigsud/zweisud
+      zgam(ii,   1)=1.
+      zgam(ii,jmar)=1.
+      zthe(ii,   1)=0.
+      zthe(ii,jmar)=0.
+      ENDDO
+
+      RETURN
+      END
+
+      SUBROUTINE MVA9(X,IMAR,JMAR)
+
+C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
+
+      PARAMETER (ISMo=300,JSMo=200)
+      REAL X(IMAR,JMAR),XF(ISMo,JSMo)
+      real WEIGHTpb(-1:1,-1:1)
+
+      if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)'
+      if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)'
+      
+      SUM=0.
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2))
+          SUM=SUM+WEIGHTpb(IS,JS)
+        ENDDO
+      ENDDO
+      
+c     WRITE(*,*) 'MVA9 ', IMAR, JMAR
+c     WRITE(*,*) 'MVA9 ', WEIGHTpb
+c     WRITE(*,*) 'MVA9 SUM ', SUM
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        DO I=2,IMAR-1
+          XF(I,J)=0.
+          DO IS=-1,1
+            DO JS=-1,1
+              XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS)
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        XF(1,J)=0.
+        IS=IMAR-1
+        DO JS=-1,1 
+          XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS)
+        ENDDO
+        DO IS=0,1 
+          DO JS=-1,1 
+            XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS)
+          ENDDO
+        ENDDO
+        XF(IMAR,J)=XF(1,J)
+      ENDDO
+
+      DO I=1,IMAR
+        XF(I,1)=XF(I,2)
+        XF(I,JMAR)=XF(I,JMAR-1)
+      ENDDO
+
+      DO I=1,IMAR
+        DO J=1,JMAR
+          X(I,J)=XF(I,J)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
Index: LMDZ5/trunk/libf/grilles_gcm_netcdf.F
===================================================================
--- LMDZ5/trunk/libf/grilles_gcm_netcdf.F	(revision 1630)
+++ LMDZ5/trunk/libf/grilles_gcm_netcdf.F	(revision 1630)
@@ -0,0 +1,305 @@
+!
+! $Id: grilles_gcm_netcdf.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+
+      PROGRAM create_fausse_var
+C
+      IMPLICIT NONE
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+
+      real temp(iim+1,jjm+1)
+#include "netcdf.inc"
+
+c Attributs netcdf sortie
+        character*64 fich_out
+        integer*4 ncid_out,rcode_out
+        integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid
+        integer*4 out_varid
+        integer*4 out_lonudim,out_lonvdim
+        integer*4 out_latudim,out_latvdim,out_dim(3)
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      integer start(4),count(4)
+
+	integer status,i,j
+        real rlatudeg(jjp1),rlatvdeg(jjm)
+        real rlonudeg(iip1),rlonvdeg(iip1)
+
+      real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
+      real acoslat,dxkm,dykm,resol(iip1,jjp1)
+
+#include "serre.h"
+#include "fxyprim.h"
+
+      print*,'OK0'
+
+      rad = 6400000
+      omeg = 7.272205e-05
+      g = 9.8
+      kappa = 0.285716
+      daysec = 86400
+      cpp = 1004.70885
+
+      preff = 101325.
+      pa= 50000.
+
+c     open(99,file='run.def',status='old',form='formatted')
+c     CALL defrun_new( 99, .TRUE.,clesphy0 )
+c     close(99)
+
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+      CALL iniconst
+      CALL inigeom
+
+
+      print*,'OK1'
+      do j=1,jjp1
+         rlatudeg(j)=rlatu(j)*180./pi
+      enddo
+      do j=1,jjm
+         rlatvdeg(j)=rlatv(j)*180./pi
+      enddo
+
+      do i=1,iip1
+         rlonudeg(i)=rlonu(i)*180./pi + 360.
+         rlonvdeg(i)=rlonv(i)*180./pi + 360.
+      enddo
+
+
+      print*,'OK2'
+c  2 ----- OUVERTURE DE LA SORTIE NETCDF
+c ---------------------------------------------------
+c CREATION OUTPUT
+c ouverture fichier netcdf de sortie out
+        fich_out='grilles_gcm.nc'
+
+        status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out)
+        status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
+        status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
+        status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
+        status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
+
+
+      print*,'OK3'
+c   Longitudes en u
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim,
+     %  out_lonuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',
+     %  9,'Longitude en u')
+
+c   Longitudes en v
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim,
+     %  out_lonvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name',
+     %  9,'Longitude en v')
+
+c   Latitude en u
+        status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim,
+     %  out_latuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name',
+     %  8,'Latitude en u')
+
+c  Latitude en v
+        status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim,
+     %  out_latvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name',
+     %  8,'Latitude en v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonudim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+c   ecriture de la grille v
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latvdim
+        status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+
+      print*,'OK4'
+        status=NF_ENDDEF(ncid_out)
+c 5) ----- FERMETURE DES FICHIERS NETCDF------------------
+c --------------------------------------------------------
+c 3-b- Ecriture de la grille pour la sortie
+c rajoute l'ecriture de la grille
+
+#ifdef NC_DOUBLE
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#else
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#endif
+
+        start(1)=1
+        start(2)=1
+        start(3)=1
+        start(4)=1
+
+        count(1)=iim+1
+        count(2)=jjm+1
+        count(3)=1
+        count(4)=1
+
+        do j=1,jjm+1
+           do i=1,iim+1
+              temp(i,j)=mod(i,2)+mod(j,2)
+           enddo
+        enddo
+
+#ifdef NC_DOUBLE
+        status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start,
+     s  count,temp)
+#else
+        status=NF_PUT_VARA_REAL(ncid_out,out_varid,start,
+     s  count,temp)
+#endif
+
+
+c fermeture du fichier netcdf
+        call ncclos(ncid_out,rcode_out)
+        write(*,*) 'Fermeture: ',fich_out
+
+
+      print*,'OK5'
+c   Ecriture grads
+      open (20,file='grille.dat',form='unformatted',access='direct'
+     s      ,recl=4*ip1jmp1)
+      write(20,rec=1) (( REAL(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
+      write(20,rec=2) (( REAL(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
+      do j=2,jjm
+         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
+c        dlat2(j)=180.*fyprim( REAL(j))/pi
+      enddo
+      do i=2,iip1
+         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
+c        dlon2(i)=180.*fxprim( REAL(i))/pi
+      enddo
+      do j=2,jjm
+         dykm=(rlatv(j)-rlatv(j-1))*6400.
+         acoslat=6400.*cos(rlatu(j))
+         do i=2,iip1
+            dxkm=acoslat*(rlonu(i)-rlonu(i-1))
+            resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm)
+         enddo
+         resol(1,j)=resol(iip1,j)
+      enddo
+      write(20,rec=3) resol
+      dlon1(1)=dlon1(iip1)
+      dlon2(1)=dlon2(iip1)
+      write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=5) ((dlon1(i)*pi/180.*0.001*
+     s   cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1)
+      write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1)
+      write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1)
+      write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1)
+
+      print*,'I, LON, DX (km)'
+      do i=1,iip1
+         print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001*
+     s   cos(clat*pi/180.)*rad
+      enddo
+      print*,'J, LAT, DY (km)'
+      do j=1,jjp1
+         print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad
+      enddo
+
+      open (21,file='grille.ctl',form='formatted')
+
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      write(21,'(a5,1x,a40)')
+     &       'DSET ','^grille.dat'
+
+      write(21,'(a12)') 'UNDEF 1.0E30'
+      write(21,'(a5,1x,a40)') 'TITLE ','grille'
+      call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF')
+      call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF')
+      call formcoord(21,1,0.,1.,.false.,'ZDEF')
+      write(21,'(a4,i10,a30)')
+     &       'TDEF ',1,' LINEAR 23OCT1994 3hr '
+      write(21,'(a4,2x,i5)') 'VARS',9
+      write(21,'(a18)') 'grille 0 99 grille'
+      write(21,'(a18)') 'gril   0 99 gril  '
+      write(21,'(a29)') 'resol   0 99 resolution (km)  '
+      write(21,'(a18)') 'dlon1  0 99 dlon1 '
+      write(21,'(a20)') 'dx     0 99 dx (km) '
+      write(21,'(a18)') 'dlon2  0 99 dlon2 '
+      write(21,'(a18)') 'dlat1  0 99 dlat1 '
+      write(21,'(a20)') 'dy     0 99 dy (km) '
+      write(21,'(a18)') 'dlat2  0 99 dlat2 '
+      write(21,'(a7)') 'ENDVARS'
+
+
+
+
+
+      print*,'OK6'
+	end
+
+
+
+        subroutine handle_err(status)
+#include "netcdf.inc"
+
+
+        integer status
+        print *,'handle code err: ',NF_NOERR
+        IF (status.NE.nf_noerr) THEN
+                print *,NF_STRERROR(status)
+                stop 'stopped'
+        ENDIF
+        END
+
Index: LMDZ5/trunk/libf/groupe_loc.F
===================================================================
--- LMDZ5/trunk/libf/groupe_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/groupe_loc.F	(revision 1630)
@@ -0,0 +1,135 @@
+      subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      USE parallel
+      USE Write_field_loc
+      USE groupe_mod
+      implicit none
+
+c   sous-programme servant a fitlrer les champs de flux de masse aux
+c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+c   et a mesure qu'on se rapproche du pole.
+c
+c   en entree: pext, pbaru et pbarv
+c
+c   en sortie:  pbarum,pbarvm et wm.
+c
+c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+c   pas besoin de w en entree.
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "comvert.h"
+
+      integer ngroup
+      parameter (ngroup=3)
+
+
+      real pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm)
+      real pext(iip1,jjb_u:jje_u,llm)
+
+      real pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm)
+      real wm(iip1,jjb_u:jje_u,llm)
+
+
+      real uu
+
+      integer i,j,l
+
+      logical firstcall
+      save firstcall
+c$OMP THREADPRIVATE(firstcall)
+
+      data firstcall/.true./
+      integer ijb,ije,jjb,jje
+      
+      if (firstcall) then
+         if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point'
+         firstcall=.false.
+      endif
+
+c   Champs 1D
+
+      call convflu_loc(pbaru,pbarv,llm,zconvm)
+
+c
+c      call scopy(ijp1llm,zconvm,1,zconvmm,1)
+c      call scopy(ijmllm,pbarv,1,pbarvm,1)
+      
+      jjb=jj_begin
+      jje=jj_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
+      enddo
+c$OMP END DO NOWAIT
+
+      call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm)
+      
+      jjb=jj_begin-1
+      jje=jj_end
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
+      enddo
+c$OMP END DO NOWAIT
+
+#ifdef DEBUG_IO    
+      CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
+#endif
+      call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm)
+#ifdef DEBUG_IO    
+      CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
+#endif
+c   Champs 3D
+   
+      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
+            uu=pbaru(iim,j,l)
+            do i=1,iim
+               uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+               pbarum(i,j,l)=uu
+c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+c    *                      yflu(i,j,l)-yflu(i,j-1,l)
+            enddo
+            pbarum(iip1,j,l)=pbarum(1,j,l)
+         enddo
+      enddo
+c$OMP END DO NOWAIT
+c    integration de la convergence de masse de haut  en bas ......
+   
+      jjb=jj_begin
+      jje=jj_end
+
+c$OMP BARRIER
+c$OMP MASTER      
+      do  l = llm-1,1,-1
+          do j=jjb,jje
+             do i=1,iip1
+                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+             enddo
+          enddo
+      enddo
+
+      if (.not. pole_sud) then
+        zconvmm(:,jj_end+1,:)=0
+cym	wm(:,jj_end+1,:)=0
+      endif
+      
+c$OMP END MASTER
+c$OMP BARRIER      
+
+      CALL vitvert_loc(zconvmm,wm)
+
+      return
+      end
+
Index: LMDZ5/trunk/libf/groupe_mod.F90
===================================================================
--- LMDZ5/trunk/libf/groupe_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/groupe_mod.F90	(revision 1630)
@@ -0,0 +1,40 @@
+MODULE groupe_mod
+
+  REAL,POINTER,SAVE :: zconvm(:,:,:)
+  REAL,POINTER,SAVE :: zconvmm(:,:,:)
+  
+CONTAINS
+
+  SUBROUTINE groupe_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE infotrac
+  USE advtrac_mod, ONLY : advtrac_allocate 
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+
+    d=>distrib_caldyn
+    CALL allocate2d_u(zconvm,llm,d)
+    CALL allocate2d_u(zconvmm,llm,d)
+
+
+  END SUBROUTINE groupe_allocate
+  
+  SUBROUTINE groupe_switch_caldyn(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch2d_u(zconvm,distrib_caldyn,dist)
+    CALL switch2d_u(zconvmm,distrib_caldyn,dist)
+
+  END SUBROUTINE groupe_switch_caldyn
+  
+
+  
+END MODULE groupe_mod  
Index: LMDZ5/trunk/libf/groupeun_loc.F
===================================================================
--- LMDZ5/trunk/libf/groupeun_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/groupeun_loc.F	(revision 1630)
@@ -0,0 +1,201 @@
+      SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
+      USE parallel
+      USE Write_Field_p
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.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
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.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: LMDZ5/trunk/libf/guide_loc_mod.F90
===================================================================
--- LMDZ5/trunk/libf/guide_loc_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/guide_loc_mod.F90	(revision 1630)
@@ -0,0 +1,1967 @@
+!
+! $Id$
+!
+MODULE guide_loc_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam
+  USE Write_Field_loc
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
+  USE parallel
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+  
+  INTEGER,SAVE,PRIVATE :: ijbu,ijbv,ijeu,ijev,ijnu,ijnv
+  INTEGER,SAVE,PRIVATE :: jjbu,jjbv,jjeu,jjev,jjnu,jjnv
+
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+    
+    USE control_mod
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    
+! Sauvegarde du for�age
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+        iguide_sav=day_step/iguide_sav
+    ELSE
+        iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
+    IF (iguide_int.EQ.0) THEN
+        iguide_int=1
+    ELSEIF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
+    ! Pour compatibilite avec ancienne version avec guide_modele
+    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
+    IF (guide_modele) THEN
+        guide_plevs=1
+    ENDIF
+    ! Fin raccord
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_plevs.EQ.1) then
+       if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+    elseif (guide_plevs.EQ.2) then
+       if (ncidpl.EQ.-99) rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
+    elseif (guide_u) then
+       if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+    elseif (guide_v) then
+       if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+    elseif (guide_T) then
+       if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+    elseif (guide_Q) then
+       if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        print *,'Guide: probleme lecture niveaux pression'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    print *,'Guide: nombre niveaux vert. nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='pb in allocation guide'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ijb_v:ije_v), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjb_v:jje_v,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ijb_v:ije_v,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjb_v:jje_v,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ijb_v:ije_v,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_plevs.EQ.2) THEN
+        ALLOCATE(pnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(pnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        pnat1=0.;pnat2=0.;
+    ENDIF
+
+    IF (guide_P.OR.guide_plevs.EQ.1) THEN
+        ALLOCATE(psnat1(iip1,jjb_u:jje_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjb_u:jje_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ijb_u:ije_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ijb_u:ije_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_plevs.EQ.2) pnat1=pnat2
+    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+    use parallel
+    USE control_mod
+    
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+
+    ! Variables entree
+    INTEGER,                           INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ijb_u:ije_u,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ijb_v:ije_v,llm), INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ijb_u:ije_u),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ijb_u:ije_u,llm) :: f_add ! var aux: champ de guidage
+    ! Variables pour fonction Exner (P milieu couche)
+    REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: pk, pkf
+    REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: alpha, beta
+    REAL, DIMENSION (iip1,jjb_u:jje_u)        :: pks    
+    REAL                               :: unskap
+    REAL, DIMENSION (ijb_u:ije_u,llmp1)    :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+!$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test)
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+!$OMP THREADPRIVATE(factt)
+    
+    INTEGER       :: i,j,l
+   
+!$OMP MASTER    
+    ijbu=ij_begin ; ijeu=ij_end ; ijnu=ijeu-ijbu+1  
+    jjbu=jj_begin ; jjeu=jj_end ; jjnu=jjeu-jjbu+1 
+    ijbv=ij_begin ; ijev=ij_end ; ijnv=ijev-ijbv+1   
+    jjbv=jj_begin ; jjev=jj_end ; jjnv=jjev-jjbv+1 
+    IF (pole_sud) THEN
+      ijev=ij_end-iip1
+      jjev=jj_end-1
+      ijnv=ijev-ijbv+1
+      jjnv=jjev-jjbv+1 
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+      
+     PRINT *,'---> on rentre dans guide_main'
+!    CALL AllGather_Field(ucov,ip1jmp1,llm)
+!    CALL AllGather_Field(vcov,ip1jm,llm)
+!    CALL AllGather_Field(teta,ip1jmp1,llm)
+!    CALL AllGather_Field(ps,ip1jmp1,1)
+!    CALL AllGather_Field(q,ip1jmp1,llm)
+    
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+
+    IF (first) THEN
+        first=.FALSE.
+!$OMP MASTER
+        CALL guide_init 
+!$OMP END MASTER
+!$OMP BARRIER
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+!$OMP MASTER
+        call tau2alpha(3,iip1,jjnb_v ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjnb_u,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjnb_u,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjnb_u,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjnb_u,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
+            enddo
+        endif
+!$OMP END MASTER
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov(ijbu:ijeu,:)=ugui2(ijbu:ijeu,:)
+            IF (guide_v) vcov(ijbv:ijev,:)=ugui2(ijbv:ijev,:)
+            IF (guide_T) teta(ijbu:ijeu,:)=tgui2(ijbu:ijeu,:)
+            IF (guide_Q) q(ijbu:ijeu,:)=qgui2(ijbu:ijeu,:)
+            IF (guide_P) THEN
+                ps(ijbu:ijeu)=psgui2(ijbu:ijeu)
+                CALL pression_loc(ijnb_u,ap,bp,ps,p)
+                CALL massdair_loc(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+        IF (guide_u) THEN
+!+tard            CALL writefield_u('unat',unat1)
+            CALL writefield_u('ucov',ucov)
+        ENDIF
+        IF (guide_T) THEN
+!+tard            CALL writefield_p('tnat',tnat1)
+            CALL writefield_u('teta',teta)
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/REAL(iguide_read)
+      ELSE
+          tau=REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+              write(*,*)'deuxieme passage de advreel a itau=',itau
+              stop
+          ELSE
+              IF (guide_v) vnat1(:,jjbv:jjev,:)=vnat2(:,jjbv:jjev,:)
+              IF (guide_u) unat1(:,jjbu:jjeu,:)=unat2(:,jjbu:jjeu,:)
+              IF (guide_T) tnat1(:,jjbu:jjeu,:)=tnat2(:,jjbu:jjeu,:)
+              IF (guide_Q) qnat1(:,jjbu:jjeu,:)=qnat2(:,jjbu:jjeu,:)
+              IF (guide_plevs.EQ.2) pnat1(:,jjbu:jjeu,:)=pnat2(:,jjbu:jjeu,:)
+              IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjbu:jjeu)=psnat2(:,jjbu:jjeu)
+              step_rea=step_rea+1
+              itau_test=itau
+              print*,'Lecture fichiers guidage, pas ',step_rea, &
+                    'apres ',count_no_rea,' non lectures'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) THEN
+!       Calcul niveaux pression milieu de couches 
+	CALL pression_loc( ijnb_u, ap, bp, ps, p )
+	if (disvert_type==1) then
+          CALL exner_hyb_loc(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
+	else
+          CALL exner_milieu_loc(ip1jmp1,ps,p,beta,pks,pk,pkf)
+        endif
+        unskap=1./kappa
+	DO l = 1, llm
+	    DO j=jjbu,jjeu
+		DO i =1, iip1
+		    p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+		ENDDO
+	    ENDDO
+	ENDDO
+        CALL guide_out("P",jjp1,llm,p,1.)
+    ENDIF
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add(ijbu:ijeu,:)=(1.-tau)*ugui1(ijbu:ijeu,:)+tau*ugui2(ijbu:ijeu,:)
+        else
+           f_add(ijbu:ijeu,:)=(1.-tau)*ugui1(ijbu:ijeu,:)+tau*ugui2(ijbu:ijeu,:)-ucov(ijbu:ijeu,:)
+        endif 
+
+        if (guide_zon) CALL guide_zonave_u(1,llm,f_add)
+        CALL guide_addfield_u(llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("U",jjp1,llm,f_add(:,:),factt)
+        ucov(ijbu:ijeu,:)=ucov(ijbu:ijeu,:)+f_add(ijbu:ijeu,:)
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add(ijbu:ijeu,:)=(1.-tau)*tgui1(ijbu:ijeu,:)+tau*tgui2(ijbu:ijeu,:)
+        else
+           f_add(ijbu:ijeu,:)=(1.-tau)*tgui1(ijbu:ijeu,:)+tau*tgui2(ijbu:ijeu,:)-teta(ijbu:ijeu,:)
+        endif 
+        if (guide_zon) CALL guide_zonave_u(2,llm,f_add)
+        CALL guide_addfield_u(llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("T",jjp1,llm,f_add(:,:),factt)
+        teta(ijbu:ijeu,:)=teta(ijbu:ijeu,:)+f_add(ijbu:ijeu,:)
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)
+        else
+           f_add(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)-ps(ijbu:ijeu)
+        endif 
+        if (guide_zon) CALL guide_zonave_u(2,1,f_add(ijb_u:ije_u,1))
+        CALL guide_addfield_u(1,f_add(ijb_u:ije_u,1),alpha_P)
+        IF (f_out) CALL guide_out("SP",jjp1,1,f_add(1:ip1jmp1,1),factt)
+        ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_add(ijbu:ijeu,1)
+        CALL pression_loc(ijnb_u,ap,bp,ps,p)
+        CALL massdair_loc(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add(ijbu:ijeu,:)=(1.-tau)*qgui1(ijbu:ijeu,:)+tau*qgui2(ijbu:ijeu,:)
+        else
+           f_add(ijbu:ijeu,:)=(1.-tau)*qgui1(ijbu:ijeu,:)+tau*qgui2(ijbu:ijeu,:)-q(ijbu:ijeu,:)
+        endif 
+        if (guide_zon) CALL guide_zonave_u(2,llm,f_add)
+        CALL guide_addfield_u(llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("Q",jjp1,llm,f_add(:,:),factt)
+        q(ijbu:ijeu,:)=q(ijbu:ijeu,:)+f_add(ijbu:ijeu,:)
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(ijbv:ijev,:)=(1.-tau)*vgui1(ijbv:ijev,:)+tau*vgui2(ijbv:ijev,:)
+        else
+           f_add(ijbv:ijev,:)=(1.-tau)*vgui1(ijbv:ijev,:)+tau*vgui2(ijbv:ijev,:)-vcov(ijbv:ijev,:)
+        endif 
+        
+        if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_add(ijb_v:ije_v,:))
+        CALL guide_addfield_v(llm,f_add(ijb_v:ije_v,:),alpha_v)
+        IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:),factt)
+        vcov(ijbv:ijev,:)=vcov(ijbv:ijev,:)+f_add(ijbv:ijev,:)
+    endif
+
+  END SUBROUTINE guide_main
+
+
+  SUBROUTINE guide_addfield_u(vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(ijb_u:ije_u),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    DO l=1,vsize
+      field(ijbu:ijeu,l)=alpha(ijbu:ijeu)*field(ijbu:ijeu,l)*alpha_pcor(l)
+    ENDDO
+
+  END SUBROUTINE guide_addfield_u
+
+
+  SUBROUTINE guide_addfield_v(vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(ijb_v:ije_v),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    DO l=1,vsize
+      field(ijbv:ijev,l)=alpha(ijbv:ijev)*field(ijbv:ijev,l)*alpha_pcor(l)
+    ENDDO
+
+  END SUBROUTINE guide_addfield_v
+  
+!=======================================================================
+
+  SUBROUTINE guide_zonave_u(typ,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (jjb_u:jje_u,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    
+      DO l=1,vsize
+      ! Compute zonal average
+
+!correction bug ici
+! ---> a verifier
+! ym         DO j=jjbv,jjev
+         DO j=jjbu,jjeu
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjbu,jjeu
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+
+  END SUBROUTINE guide_zonave_u
+
+
+  SUBROUTINE guide_zonave_v(typ,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (jjb_v:jjev,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjbv,jjev
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjbv,jjev
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+
+
+  END SUBROUTINE guide_zonave_v
+  
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+  USE parallel
+  USE mod_hallo
+  USE Bands
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comgeom2.h"
+  include "comconst.h"
+
+  REAL, DIMENSION (iip1,jjb_u:jje_u),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjb_u:jje_u,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjb_v:jje_v,llm)     :: plvnc       !niveaux pression modele
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llmp1)  :: p           ! pression intercouches 
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: pbarx 
+  REAL, DIMENSION (iip1,jjb_v:jje_v,llm)     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: pk, pkf
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: alpha, beta
+  REAL, DIMENSION (iip1,jjb_u:jje_u)        :: pks    
+  REAL                               :: unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ijb_u:ije_u,llm)      :: qsat
+  !Variables intermediaires interpolation
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm)    :: zu1,zu2 
+  REAL, DIMENSION (iip1,jjb_v:jje_v,llm)     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  TYPE(Request) :: Req  
+
+    print *,'Guide: conversion variables guidage'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage (pour T et Q)
+! -----------------------------------------------------------------
+    IF (guide_plevs.EQ.0) THEN
+        DO l=1,nlevnc
+            DO j=jjbu,jjeu
+                DO i=1,iip1
+                    plnc2(i,j,l)=apnc(l)
+                    plnc1(i,j,l)=apnc(l)
+               ENDDO
+            ENDDO
+        ENDDO
+    ENDIF   
+
+    if (first) then
+        first=.FALSE.
+        print*,'Guide: verification ordre niveaux verticaux'
+        print*,'LMDZ :'
+        do l=1,llm
+            print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jjeu)*(bp(l)+bp(l+1))/2.
+        enddo
+        print*,'Fichiers guidage'
+        SELECT CASE (guide_plevs)
+        CASE (0) 
+            do l=1,nlevnc
+                 print*,'PL(',l,')=',plnc2(1,jjbu,l)
+            enddo
+        CASE (1)
+            DO l=1,nlevnc
+                 print*,'PL(',l,')=',apnc(l)+bpnc(l)*psnat2(i,jjbu)
+             ENDDO
+        CASE (2)
+            do l=1,nlevnc
+                 print*,'PL(',l,')=',pnat2(1,jjbu,l)
+            enddo
+        END SELECT
+        print *,'inversion de l''ordre: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+                print*,'U(',l,')=',unat2(1,jjbu,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+                print*,'T(',l,')=',tnat2(1,jjbu,l)
+            enddo
+        endif
+    endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    IF (guide_plevs.EQ.1) THEN
+        DO l=1,llm
+	    DO j=jjbu,jjeu
+		DO i =1, iip1
+                    pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
+		ENDDO
+	    ENDDO
+        ENDDO
+    ELSE
+	CALL pression_loc( ijnb_u, ap, bp, psi, p )
+	if (disvert_type==1) then
+          CALL exner_hyb_loc(ijnb_u,psi,p,alpha,beta,pks,pk,pkf)
+        else ! we assume that we are in the disvert_type==2 case
+          CALL exner_milieu_loc(ijnb_u,psi,p,beta,pks,pk,pkf)
+        endif
+	unskap=1./kappa
+	DO l = 1, llm
+	    DO j=jjbu,jjeu
+		DO i =1, iip1
+		    pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+		ENDDO
+	    ENDDO
+	ENDDO
+    ENDIF
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=jjbu,jjeu
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+
+     CALL Register_Hallo_u(pext,llm,1,2,2,1,Req)
+     CALL SendRequest(Req)
+     CALL WaitRequest(Req)
+
+    call massbar_loc(pext, pbarx, pbary )
+    do l=1,llm
+        do j=jjbu,jjeu
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=jjbv,jjev
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation verticale champs guidage sur niveaux modele
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=jjbu,jjeu
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_T) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+        CALL pres2lev(tnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,           &
+                    plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+        CALL pres2lev(tnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,           &
+                    plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjbu,jjeu
+                IF (guide_teta) THEN
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)
+                    enddo
+                ELSE
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+                    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            if (pole_nord) then
+              do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui2(i,l)=tgui2(1,l)
+              enddo
+            endif
+            if (pole_sud) then
+              do i=1,iip1
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+              enddo
+           endif
+        enddo
+    ENDIF
+
+    IF (guide_Q) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+        CALL pres2lev(qnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,             &
+                      plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+        CALL pres2lev(qnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,             &
+                      plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+
+        ! Conversion en variables GCM
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        do l=1,llm
+            do j=jjbu,jjeu
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            if (pole_nord) then
+              do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui2(i,l)=qgui2(1,l)
+              enddo
+            endif
+            if (pole_nord) then
+              do i=1,iip1
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+              enddo
+            endif
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjnu*llm,teta(:,jjbu:jjeu,:)*pk(:,jjbu:jjeu,:)/cpp,       &
+                       plsnc(:,jjbu:jjeu,:),qsat(ijbu:ijeu,:))
+            qgui1(ijbu:ijeu,:)=qgui1(ijbu:ijeu,:)*qsat(ijbu:ijeu,:)*0.01 !hum. rel. en %
+            qgui2(ijbu:ijeu,:)=qgui2(ijbu:ijeu,:)*qsat(ijbu:ijeu,:)*0.01 
+        ENDIF
+    ENDIF
+
+    IF (guide_u) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iim
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iim
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ENDIF
+        
+        ! Interpolation verticale
+        CALL pres2lev(unat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,            &
+                      plnc1(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+        CALL pres2lev(unat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,            &
+                      plnc2(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjbu,jjeu
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            if (pole_nord) then
+              do i=1,iip1
+                ugui1(i,l)=0.
+                ugui2(i,l)=0.
+              enddo
+            endif
+            if (pole_sud) then
+              do i=1,iip1
+                ugui1(ip1jm+i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+              enddo
+            endif
+        enddo
+    ENDIF
+    
+    IF (guide_v) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+	 CALL Register_Hallo_u(psnat1,1,1,2,2,1,Req)
+	 CALL Register_Hallo_u(psnat2,1,1,2,2,1,Req)
+	 CALL SendRequest(Req)
+	 CALL WaitRequest(Req)
+            DO l=1,nlevnc
+                DO j=jjbv,jjev
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+	 CALL Register_Hallo_u(pnat1,llm,1,2,2,1,Req)
+	 CALL Register_Hallo_u(pnat2,llm,1,2,2,1,Req)
+	 CALL SendRequest(Req)
+	 CALL WaitRequest(Req)
+            DO l=1,nlevnc
+                DO j=jjbv,jjev
+                    DO i=1,iip1
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+        ! Interpolation verticale
+        CALL pres2lev(vnat1(:,jjbv:jjev,:),zv1(:,jjbv:jjev,:),nlevnc,llm,             &
+                      plnc1(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
+        CALL pres2lev(vnat2(:,jjbv:jjev,:),zv2(:,jjbv:jjev,:),nlevnc,llm,             &
+                      plnc2(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjbv,jjev
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom2.h"
+    include "serre.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                 print*,'ATTENTION modele peu zoome'
+                 print*,'ATTENTION on prend une constante de guidage cste'
+                 gamma=0.
+            else
+                gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+                print*,'gamma=',gamma
+                if (gamma.lt.1.e-5) then
+                  print*,'gamma =',gamma,'<1e-5'
+                  stop
+                endif
+                gamma=log(0.5)/log(gamma)
+                if (gamma4) then 
+                  gamma=min(gamma,4.)
+                endif
+                print*,'gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read'
+    abort_message='pb in guide_read'
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Ap et Bp si Niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             print *,'Lecture du guidage sur niveaux modele'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression si guidage sur niveaux P variables
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             print*,'ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         IF (guide_plevs.EQ.1) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         ELSEIF (guide_plevs.EQ.0) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         ENDIF
+         first=.FALSE.
+     ENDIF ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=jjb_u
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjnb_u
+     count(3)=nlevnc
+     count(4)=1
+
+     IF (invert_y) start(2)=jjp1-jje_u+1
+! Pression 
+     if (guide_plevs.EQ.2) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,pnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidp,varidp,start,count,pnat2)
+#endif
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
+         ENDIF
+     endif
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
+#endif
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
+#endif
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
+#endif
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         start(2)=jjb_v
+         count(2)=jjnb_v
+         IF (invert_y) start(2)=jjm-jje_v+1
+
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
+#endif
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(2)=jjb_u
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjnb_u
+         count(3)=1
+         count(4)=0
+         IF (invert_y) start(2)=jjp1-jje_u+1
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
+#endif
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjb_u:jje_u,llm)  :: zu
+    REAL, DIMENSION (jjb_v:jje_v,llm)  :: zv
+    INTEGER               :: i
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read'
+    abort_message='pb in guide_read2D'
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Ap et Bp si niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             print *,'Lecture du guidage sur niveaux mod�le'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             print*,'ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_plevs.EQ.1) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         elseif (guide_plevs.EQ.0) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=jjb_u
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjnb_u
+     count(3)=nlevnc
+     count(4)=1
+
+     IF (invert_y) start(2)=jjp1-jje_u+1
+!  Pression
+     if (guide_plevs.EQ.2) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidp,varidp,start,count,zu)
+#endif
+         DO i=1,iip1
+             pnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
+         ENDIF
+     endif
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
+#endif
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
+         ENDIF
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
+#endif
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
+#endif
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+         
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
+         ENDIF
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         start(2)=jjb_v
+         count(2)=jjnb_v
+         IF (invert_y) start(2)=jjm-jje_v+1
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
+#endif
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(2)=jjb_u
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjnb_u
+         count(3)=1
+         count(4)=0
+         IF (invert_y) start(2)=jjp1-jje_u+1
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
+#endif
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field,factt)
+    USE parallel
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    
+    ! Variables entree
+    CHARACTER, INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+    REAL, INTENT (IN)                              :: factt
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid
+    
+    CALL gather_field(field,iip1*hsize,vsize,0)
+    
+    IF (mpi_rank /= 0) RETURN
+    
+    print *,'Guide: output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
+#else
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
+#endif
+! --------------------------------------------------------------------
+! Cr�ation des variables sauvegard�es
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Pressure (GCM)
+        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+        ierr = NF_DEF_VAR(nid,"P",NF_FLOAT,4,dim4,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+ 
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    SELECT CASE (varname)
+    CASE ("P")
+        timestep=timestep+1
+        ierr = NF_INQ_VARID(nid,"P",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("SP")
+        ierr = NF_INQ_VARID(nid,"ps",varid)
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("U")
+        ierr = NF_INQ_VARID(nid,"ucov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("V")
+        ierr = NF_INQ_VARID(nid,"vcov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("T")
+        ierr = NF_INQ_VARID(nid,"teta",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("Q")
+        ierr = NF_INQ_VARID(nid,"q",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    END SELECT
+ 
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_loc_mod
Index: LMDZ5/trunk/libf/guide_loc_mod.F90.orig
===================================================================
--- LMDZ5/trunk/libf/guide_loc_mod.F90.orig	(revision 1630)
+++ LMDZ5/trunk/libf/guide_loc_mod.F90.orig	(revision 1630)
@@ -0,0 +1,1836 @@
+!
+! $Id$
+!
+MODULE guide_p_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam
+  USE Write_Field_p
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+  
+  INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v
+  INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v
+
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+    
+    USE control_mod
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    
+! Sauvegarde du for�age
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+        iguide_sav=day_step/iguide_sav
+    ELSE
+        iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
+    IF (iguide_int.EQ.0) THEN
+        iguide_int=1
+    ELSEIF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
+    ! Pour compatibilite avec ancienne version avec guide_modele
+    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
+    IF (guide_modele) THEN
+        guide_plevs=1
+    ENDIF
+    ! Fin raccord
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_plevs.EQ.1) then
+       if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+    elseif (guide_plevs.EQ.2) then
+       if (ncidpl.EQ.-99) rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
+    elseif (guide_u) then
+       if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+    elseif (guide_v) then
+       if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+    elseif (guide_T) then
+       if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+    elseif (guide_Q) then
+       if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        print *,'Guide: probleme lecture niveaux pression'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    print *,'Guide: nombre niveaux vert. nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='pb in allocation guide'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ip1jm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_plevs.EQ.2) THEN
+        ALLOCATE(pnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(pnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        pnat1=0.;pnat2=0.;
+    ENDIF
+
+    IF (guide_P.OR.guide_plevs.EQ.1) THEN
+        ALLOCATE(psnat1(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_plevs.EQ.2) pnat1=pnat2
+    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+    use parallel
+    USE control_mod
+    
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+
+    ! Variables entree
+    INTEGER,                       INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
+    ! Variables pour fonction Exner (P milieu couche)
+    REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
+    REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
+    REAL, DIMENSION (iip1,jjp1)        :: pks    
+    REAL                               :: unskap
+    REAL, DIMENSION (ip1jmp1,llmp1)    :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+    
+    INTEGER       :: i,j,l
+    
+    ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1  
+    jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 
+    ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1   
+    jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 
+    IF (pole_sud) THEN
+      ije_v=ij_end-iip1
+      jje_v=jj_end-1
+      ijn_v=ije_v-ijb_v+1
+      jjn_v=jje_v-jjb_v+1 
+    ENDIF
+      
+     PRINT *,'---> on rentre dans guide_main'
+!    CALL AllGather_Field(ucov,ip1jmp1,llm)
+!    CALL AllGather_Field(vcov,ip1jm,llm)
+!    CALL AllGather_Field(teta,ip1jmp1,llm)
+!    CALL AllGather_Field(ps,ip1jmp1,1)
+!    CALL AllGather_Field(q,ip1jmp1,llm)
+    
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+
+    IF (first) THEN
+        first=.FALSE.
+        CALL guide_init 
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
+            enddo
+        endif
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:)
+            IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:)
+            IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:)
+            IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)
+            IF (guide_P) THEN
+                ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u)
+                CALL pression_p(ip1jmp1,ap,bp,ps,p)
+                CALL massdair_p(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+        IF (guide_u) THEN
+            CALL writefield_p('unat',unat1)
+            CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
+        ENDIF
+        IF (guide_T) THEN
+            CALL writefield_p('tnat',tnat1)
+            CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/REAL(iguide_read)
+      ELSE
+          tau=REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+              write(*,*)'deuxieme passage de advreel a itau=',itau
+              stop
+          ELSE
+              IF (guide_v) vnat1(:,jjb_v:jje_v,:)=vnat2(:,jjb_v:jje_v,:)
+              IF (guide_u) unat1(:,jjb_u:jje_u,:)=unat2(:,jjb_u:jje_u,:)
+              IF (guide_T) tnat1(:,jjb_u:jje_u,:)=tnat2(:,jjb_u:jje_u,:)
+              IF (guide_Q) qnat1(:,jjb_u:jje_u,:)=qnat2(:,jjb_u:jje_u,:)
+              IF (guide_plevs.EQ.2) pnat1(:,jjb_u:jje_u,:)=pnat2(:,jjb_u:jje_u,:)
+              IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjb_u:jje_u)=psnat2(:,jjb_u:jje_u)
+              step_rea=step_rea+1
+              itau_test=itau
+              print*,'Lecture fichiers guidage, pas ',step_rea, &
+                    'apres ',count_no_rea,' non lectures'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) THEN
+!       Calcul niveaux pression milieu de couches 
+	CALL pression_p( ip1jmp1, ap, bp, ps, p )
+	if (disvert_type==1) then
+          CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
+	else
+          CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf)
+        endif
+        unskap=1./kappa
+	DO l = 1, llm
+	    DO j=jjb_u,jje_u
+		DO i =1, iip1
+		    p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+		ENDDO
+	    ENDDO
+	ENDDO
+        CALL guide_out("P",jjp1,llm,p(1:ip1jmp1,1:llm),1.)
+    ENDIF
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:)
+        endif 
+
+        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("U",jjp1,llm,f_add(:,:),factt)
+        ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("T",jjp1,llm,f_add(:,:),factt)
+        teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)
+        else
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
+        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
+        IF (f_out) CALL guide_out("SP",jjp1,1,f_add(1:ip1jmp1,1),factt)
+        ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1)
+        CALL pression_p(ip1jmp1,ap,bp,ps,p)
+        CALL massdair_p(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("Q",jjp1,llm,f_add(:,:),factt)
+        q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)
+        else
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:)
+        endif 
+        
+        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
+        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
+        IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:),factt)
+        vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:)
+    endif
+
+  END SUBROUTINE guide_main
+
+!=======================================================================
+  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: hsize
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    IF (hsize==ip1jm) THEN
+      do l=1,vsize
+        field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l)
+      enddo
+    ELSE
+      do l=1,vsize
+        field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l)
+      enddo
+    ENDIF    
+
+  END SUBROUTINE guide_addfield
+
+!=======================================================================
+  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    
+    IF (hsize==jjm) THEN
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_v,jje_v
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ELSE
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_u,jje_u
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ENDIF    
+
+  END SUBROUTINE guide_zonave
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+  USE parallel
+  USE mod_hallo
+  USE Bands
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comgeom2.h"
+  include "comconst.h"
+
+  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
+  REAL, DIMENSION (iip1,jjp1,llmp1)  :: p           ! pression intercouches 
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pbarx 
+  REAL, DIMENSION (iip1,jjm,llm)     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
+  REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
+  REAL, DIMENSION (iip1,jjp1)        :: pks    
+  REAL                               :: unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
+  !Variables intermediaires interpolation
+  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
+  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  TYPE(Request) :: Req  
+
+    print *,'Guide: conversion variables guidage'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage (pour T et Q)
+! -----------------------------------------------------------------
+    IF (guide_plevs.EQ.0) THEN
+        DO l=1,nlevnc
+            DO j=jjb_u,jje_u
+                DO i=1,iip1
+                    plnc2(i,j,l)=apnc(l)
+                    plnc1(i,j,l)=apnc(l)
+               ENDDO
+            ENDDO
+        ENDDO
+    ENDIF   
+
+    if (first) then
+        first=.FALSE.
+        print*,'Guide: verification ordre niveaux verticaux'
+        print*,'LMDZ :'
+        do l=1,llm
+            print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jje_u)*(bp(l)+bp(l+1))/2.
+        enddo
+        print*,'Fichiers guidage'
+        SELECT CASE (guide_plevs)
+        CASE (0) 
+            do l=1,nlevnc
+                 print*,'PL(',l,')=',plnc2(1,jjb_u,l)
+            enddo
+        CASE (1)
+            DO l=1,nlevnc
+                 print*,'PL(',l,')=',apnc(l)+bpnc(l)*psnat2(i,jjb_u)
+             ENDDO
+        CASE (2)
+            do l=1,nlevnc
+                 print*,'PL(',l,')=',pnat2(1,jjb_u,l)
+            enddo
+        END SELECT
+        print *,'inversion de l''ordre: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+                print*,'U(',l,')=',unat2(1,jjb_u,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+                print*,'T(',l,')=',tnat2(1,jjb_u,l)
+            enddo
+        endif
+    endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    IF (guide_plevs.EQ.1) THEN
+        DO l=1,llm
+	    DO j=jjb_u,jje_u
+		DO i =1, iip1
+                    pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
+		ENDDO
+	    ENDDO
+        ENDDO
+    ELSE
+	CALL pression_p( ip1jmp1, ap, bp, psi, p )
+	if (disvert_type==1) then
+          CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
+        else ! we assume that we are in the disvert_type==2 case
+          CALL exner_milieu_p(ip1jmp1,psi,p,beta,pks,pk,pkf)
+        endif
+	unskap=1./kappa
+	DO l = 1, llm
+	    DO j=jjb_u,jje_u
+		DO i =1, iip1
+		    pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+		ENDDO
+	    ENDDO
+	ENDDO
+    ENDIF
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+
+     CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+     CALL SendRequest(Req)
+     CALL WaitRequest(Req)
+
+     call massbar_p(pext, pbarx, pbary )
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=jjb_v,jje_v
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation verticale champs guidage sur niveaux modele
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=jjb_u,jje_u
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_T) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+        CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                    plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                    plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjb_u,jje_u
+                IF (guide_teta) THEN
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)
+                    enddo
+                ELSE
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+                    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(i,l)=tgui2(1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+            enddo
+        enddo
+    ENDIF
+
+    IF (guide_Q) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+        CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        ! Conversion en variables GCM
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        do l=1,llm
+            do j=jjb_u,jje_u
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(i,l)=qgui2(1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+            enddo
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp,       &
+                       plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:))
+            qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en %
+            qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 
+        ENDIF
+    ENDIF
+
+    IF (guide_u) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iim
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iim
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ENDIF
+        
+        ! Interpolation verticale
+        CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjb_u,jje_u
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                ugui1(i,l)=0.
+                ugui1(ip1jm+i,l)=0.
+                ugui2(i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_v) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+	 CALL Register_SwapFieldHallo(psnat1,psnat1,ip1jmp1,1,jj_Nb_caldyn,1,2,Req)
+	 CALL SendRequest(Req)
+	 CALL WaitRequest(Req)
+	 CALL Register_SwapFieldHallo(psnat2,psnat2,ip1jmp1,1,jj_Nb_caldyn,1,2,Req)
+	 CALL SendRequest(Req)
+	 CALL WaitRequest(Req)
+            DO l=1,nlevnc
+                DO j=jjb_v,jje_v
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+	 CALL Register_SwapFieldHallo(pnat1,pnat1,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+	 CALL SendRequest(Req)
+	 CALL WaitRequest(Req)
+	 CALL Register_SwapFieldHallo(pnat2,pnat2,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+	 CALL SendRequest(Req)
+	 CALL WaitRequest(Req)
+            DO l=1,nlevnc
+                DO j=jjb_v,jje_v
+                    DO i=1,iip1
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+        ! Interpolation verticale
+        CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+        CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjb_v,jje_v
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom2.h"
+    include "serre.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                 print*,'ATTENTION modele peu zoome'
+                 print*,'ATTENTION on prend une constante de guidage cste'
+                 gamma=0.
+            else
+                gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+                print*,'gamma=',gamma
+                if (gamma.lt.1.e-5) then
+                  print*,'gamma =',gamma,'<1e-5'
+                  stop
+                endif
+                gamma=log(0.5)/log(gamma)
+                if (gamma4) then 
+                  gamma=min(gamma,4.)
+                endif
+                print*,'gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Ap et Bp si Niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             print *,'Lecture du guidage sur niveaux modele'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression si guidage sur niveaux P variables
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             print*,'ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         IF (guide_plevs.EQ.1) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         ELSEIF (guide_plevs.EQ.0) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         ENDIF
+         first=.FALSE.
+     ENDIF ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+! Pression 
+     if (guide_plevs.EQ.2) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,pnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidp,varidp,start,count,pnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
+         ENDIF
+     endif
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjp1,llm) :: zu
+    REAL, DIMENSION (jjm,llm)  :: zv
+    INTEGER               :: i
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Ap et Bp si niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             print *,'Lecture du guidage sur niveaux mod�le'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             print*,'ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_plevs.EQ.1) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         elseif (guide_plevs.EQ.0) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Pression
+     if (guide_plevs.EQ.2) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidp,varidp,start,count,zu)
+#endif
+         DO i=1,iip1
+             pnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
+         ENDIF
+     endif
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
+#endif
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
+#endif
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
+#endif
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+         
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
+#endif
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
+#endif
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field,factt)
+    USE parallel
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    
+    ! Variables entree
+    CHARACTER, INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+    REAL, INTENT (IN)                              :: factt
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid
+    
+    CALL gather_field(field,iip1*hsize,vsize,0)
+    
+    IF (mpi_rank /= 0) RETURN
+    
+    print *,'Guide: output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
+#else
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
+#endif
+! --------------------------------------------------------------------
+! Cr�ation des variables sauvegard�es
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Pressure (GCM)
+        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+        ierr = NF_DEF_VAR(nid,"P",NF_FLOAT,4,dim4,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+ 
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    SELECT CASE (varname)
+    CASE ("P")
+        timestep=timestep+1
+        ierr = NF_INQ_VARID(nid,"P",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("SP")
+        ierr = NF_INQ_VARID(nid,"ps",varid)
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("U")
+        ierr = NF_INQ_VARID(nid,"ucov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("V")
+        ierr = NF_INQ_VARID(nid,"vcov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("T")
+        ierr = NF_INQ_VARID(nid,"teta",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    CASE ("Q")
+        ierr = NF_INQ_VARID(nid,"q",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
+#endif
+    END SELECT
+ 
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_p_mod
Index: LMDZ5/trunk/libf/guide_p_mod.F90
===================================================================
--- LMDZ5/trunk/libf/guide_p_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/guide_p_mod.F90	(revision 1630)
@@ -0,0 +1,1646 @@
+!
+! $Id$
+!
+MODULE guide_p_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam
+  USE Write_Field_p
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: guide_modele,invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+  
+  INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v
+  INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v
+
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+
+    USE control_mod
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    
+! Sauvegarde du for�age
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+        iguide_sav=day_step/iguide_sav
+    ELSE
+        iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage')
+    IF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele')
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_modele) then
+       if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+    else
+         if (guide_u) then
+           if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+         elseif (guide_v) then
+           if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+         elseif (guide_T) then
+           if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+         elseif (guide_Q) then
+           if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+         endif
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        print *,'Guide: probleme lecture niveaux pression'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    print *,'Guide: nombre niveaux vert. nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='pb in allocation guide'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ip1jm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_P.OR.guide_modele) THEN
+        ALLOCATE(psnat1(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_P.OR.guide_modele) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+    use parallel
+    USE control_mod
+    
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+
+    ! Variables entree
+    INTEGER,                       INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+    
+    INTEGER       :: l
+    
+    ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1  
+    jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 
+    ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1   
+    jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 
+    IF (pole_sud) THEN
+      ije_v=ij_end-iip1
+      jje_v=jj_end-1
+      ijn_v=ije_v-ijb_v+1
+      jjn_v=jje_v-jjb_v+1 
+    ENDIF
+      
+    
+    
+     PRINT *,'---> on rentre dans guide_main'
+!    CALL AllGather_Field(ucov,ip1jmp1,llm)
+!    CALL AllGather_Field(vcov,ip1jm,llm)
+!    CALL AllGather_Field(teta,ip1jmp1,llm)
+!    CALL AllGather_Field(ps,ip1jmp1,1)
+!    CALL AllGather_Field(q,ip1jmp1,llm)
+    
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+
+    IF (first) THEN
+        first=.FALSE.
+        CALL guide_init 
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
+            enddo
+        endif
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:)
+            IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:)
+            IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:)
+            IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)
+            IF (guide_P) THEN
+                ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u)
+                CALL pression_p(ip1jmp1,ap,bp,ps,p)
+                CALL massdair_p(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+        IF (guide_u) THEN
+            CALL writefield_p('unat',unat1)
+            CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
+        ENDIF
+        IF (guide_T) THEN
+            CALL writefield_p('tnat',tnat1)
+            CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/ REAL(iguide_read)
+      ELSE
+          tau= REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+              write(*,*)'deuxieme passage de advreel a itau=',itau
+              stop
+          ELSE
+              IF (guide_v) vnat1(jjb_v:jje_v,:,:)=vnat2(jjb_v:jje_v,:,:)
+              IF (guide_u) unat1(jjb_u:jje_u,:,:)=unat2(jjb_u:jje_u,:,:)
+              IF (guide_T) tnat1(jjb_u:jje_u,:,:)=tnat2(jjb_u:jje_u,:,:)
+              IF (guide_Q) qnat1(jjb_u:jje_u,:,:)=qnat2(jjb_u:jje_u,:,:)
+              IF (guide_P.OR.guide_modele) psnat1(jjb_u:jje_u,:)=psnat2(jjb_u:jje_u,:)
+              step_rea=step_rea+1
+              itau_test=itau
+              print*,'Lecture fichiers guidage, pas ',step_rea, &
+                    'apres ',count_no_rea,' non lectures'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) CALL guide_out("S",jjp1,1,ps)
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:)
+        endif 
+
+        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("U",jjp1,llm,f_add/factt)
+        ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("T",jjp1,llm,f_add/factt)
+        teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)
+        else
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
+        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
+        IF (f_out) CALL guide_out("P",jjp1,1,f_add(1:ip1jmp1,1)/factt)
+        ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1)
+        CALL pression_p(ip1jmp1,ap,bp,ps,p)
+        CALL massdair_p(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("Q",jjp1,llm,f_add/factt)
+        q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)
+        else
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:)
+        endif 
+        
+        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
+        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
+        IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:)/factt)
+        vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:)
+    endif
+
+  END SUBROUTINE guide_main
+
+!=======================================================================
+  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: hsize
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    IF (hsize==ip1jm) THEN
+      do l=1,vsize
+        field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l)
+      enddo
+    ELSE
+      do l=1,vsize
+        field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l)
+      enddo
+    ENDIF    
+
+  END SUBROUTINE guide_addfield
+
+!=======================================================================
+  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    
+    IF (hsize==jjm) THEN
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_v,jje_v
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ELSE
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_u,jje_u
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ENDIF    
+
+  END SUBROUTINE guide_zonave
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+  USE parallel
+  USE mod_hallo
+  USE Bands
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comgeom2.h"
+  include "comconst.h"
+
+  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
+!ym rustine temporaire pour ne pas depasser 2GB pour la stack
+!ym  => crach compilo avec la version intel 12
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE  :: p           ! pression intercouches 
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE    :: pbarx 
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE    :: pk, pkf
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE    :: alpha, beta
+  REAL, DIMENSION (:,:),ALLOCATABLE,SAVE        :: pks    
+  REAL                               :: prefkap,unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
+  !Variables intermediaires interpolation
+
+!ym rustine temporaire pour ne pas depasser 2GB pour la stack
+!ym  => crach compilo avec la version intel 12
+!  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
+!  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE     :: zu1,zu2 
+  REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  TYPE(Request) :: Req  
+
+    print *,'Guide: conversion variables guidage'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage
+! -----------------------------------------------------------------
+if (guide_modele) then
+    do i=1,iip1
+        do j=jjb_u,jje_u
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+            enddo
+        enddo
+    enddo
+else
+    do i=1,iip1
+        do j=jjb_u,jje_u
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)
+                plnc1(i,j,l)=apnc(l)
+           enddo
+        enddo
+    enddo
+
+endif
+    if (first) then
+        first=.FALSE.
+        print*,'Guide: verification ordre niveaux verticaux'
+        print*,'LMDZ :'
+        do l=1,llm
+            print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jje_u)*(bp(l)+bp(l+1))/2.
+        enddo
+        print*,'Fichiers guidage'
+        do l=1,nlevnc
+             print*,'PL(',l,')=',plnc2(1,jjb_u,l)
+        enddo
+        print *,'inversion de l''ordre: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+                print*,'U(',l,')=',unat2(1,jjb_u,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+                print*,'T(',l,')=',tnat2(1,jjb_u,l)
+            enddo
+        endif
+        ALLOCATE( zu1(iip1,jjp1,llm),zu2(iip1,jjp1,llm)) 
+        ALLOCATE( zv1(iip1,jjm,llm),zv2(iip1,jjm,llm)) 
+        ALLOCATE( p(iip1,jjp1,llmp1) )
+        ALLOCATE( pls(iip1,jjp1,llm), pext(iip1,jjp1,llm) )
+        ALLOCATE( pbarx(iip1,jjp1,llm) )
+        ALLOCATE( pbary(iip1,jjm,llm) )
+        ALLOCATE( pk(iip1,jjp1,llm),pkf(iip1,jjp1,llm) )
+        ALLOCATE( alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) )
+        ALLOCATE( pks(iip1,jjp1) )
+      endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+    CALL pression_p( ip1jmp1, ap, bp, psi, p )
+    CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
+
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    unskap=1./kappa
+    prefkap =  preff  ** kappa
+    DO l = 1, llm
+        DO j=jjb_u,jje_u
+            DO i =1, iip1
+                pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+            ENDDO
+        ENDDO
+    ENDDO
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+
+     CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+     CALL SendRequest(Req)
+     CALL WaitRequest(Req)
+
+     call massbar_p(pext, pbarx, pbary )
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=jjb_v,jje_v
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation champs guidage sur niveaux modele (+inversion N/S)
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=jjb_u,jje_u
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_u) THEN
+        CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        do l=1,llm
+            do j=jjb_u,jje_u
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                ugui1(i,l)=0.
+                ugui1(ip1jm+i,l)=0.
+                ugui2(i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_T) THEN
+        CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                      plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                      plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        do l=1,llm
+            do j=jjb_u,jje_u
+                IF (guide_teta) THEN
+		    do i=1,iim
+			ij=(j-1)*iip1+i
+			tgui1(ij,l)=zu1(i,j,l)
+			tgui2(ij,l)=zu2(i,j,l)
+		    enddo
+                ELSE
+		    do i=1,iim
+			ij=(j-1)*iip1+i
+			tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+			tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+		    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(i,l)=tgui2(1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+            enddo
+        enddo
+    ENDIF
+
+    IF (guide_v) THEN
+        
+        CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+        CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+
+        do l=1,llm
+            do j=jjb_v,jje_v
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_Q) THEN
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        do l=1,llm
+            do j=jjb_u,jjb_v
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(i,l)=qgui2(1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+            enddo
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp,       &
+                       plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:))
+            qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en %
+            qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 
+        ENDIF
+    ENDIF
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom2.h"
+    include "serre.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                 print*,'ATTENTION modele peu zoome'
+                 print*,'ATTENTION on prend une constante de guidage cste'
+                 gamma=0.
+            else
+                gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+                print*,'gamma=',gamma
+                if (gamma.lt.1.e-5) then
+                  print*,'gamma =',gamma,'<1e-5'
+                  stop
+                endif
+                gamma=log(0.5)/log(gamma)
+                if (gamma4) then 
+                  gamma=min(gamma,4.)
+                endif
+                print*,'gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidQ
+    INTEGER, SAVE         :: varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Niveaux de pression si non constants
+         if (guide_modele) then
+             print *,'Lecture du guidage sur niveaux mod�le'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (.not.guide_modele) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_modele) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         else
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,llm,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidQ
+    INTEGER, SAVE         :: varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjp1,llm) :: zu
+    REAL, DIMENSION (jjm,llm)  :: zv
+    INTEGER               :: i
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Niveaux de pression si non constants
+         if (guide_modele) then
+             print *,'Lecture du guidage sur niveaux mod�le'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (.not.guide_modele) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_modele) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         else
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
+#endif
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
+#endif
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,tnat2)
+         ENDIF
+
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
+#endif
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+         
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
+#endif
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,llm,vnat2)
+         ENDIF
+
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
+#endif
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field)
+    USE parallel
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    
+    ! Variables entree
+    CHARACTER, INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid
+    
+    CALL gather_field(field,iip1*hsize,vsize,0)
+    
+    IF (mpi_rank /= 0) RETURN
+    
+    print *,'Guide: output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
+#else
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
+#endif
+! --------------------------------------------------------------------
+! Cr�ation des variables sauvegard�es
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Surface pressure (GCM)
+        dim3=(/id_lonv,id_latu,id_tim/)
+        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    SELECT CASE (varname)
+    CASE ("S")
+        timestep=timestep+1
+        ierr = NF_INQ_VARID(nid,"SP",varid)
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("P")
+        ierr = NF_INQ_VARID(nid,"ps",varid)
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("U")
+        ierr = NF_INQ_VARID(nid,"ucov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("V")
+        ierr = NF_INQ_VARID(nid,"vcov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("T")
+        ierr = NF_INQ_VARID(nid,"teta",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("Q")
+        ierr = NF_INQ_VARID(nid,"q",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    END SELECT
+ 
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_p_mod
Index: LMDZ5/trunk/libf/guide_p_mod.F90.orig
===================================================================
--- LMDZ5/trunk/libf/guide_p_mod.F90.orig	(revision 1630)
+++ LMDZ5/trunk/libf/guide_p_mod.F90.orig	(revision 1630)
@@ -0,0 +1,1637 @@
+!
+! $Id$
+!
+MODULE guide_p_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam
+  USE Write_Field_p
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: guide_modele,invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+  
+  INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v
+  INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v
+
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+
+    USE control_mod
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    
+! Sauvegarde du for�age
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+        iguide_sav=day_step/iguide_sav
+    ELSE
+        iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage')
+    IF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele')
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_modele) then
+       if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+    else
+         if (guide_u) then
+           if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+         elseif (guide_v) then
+           if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+         elseif (guide_T) then
+           if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+         elseif (guide_Q) then
+           if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+         endif
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        print *,'Guide: probleme lecture niveaux pression'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    print *,'Guide: nombre niveaux vert. nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='pb in allocation guide'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ip1jm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_P.OR.guide_modele) THEN
+        ALLOCATE(psnat1(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_P.OR.guide_modele) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+    use parallel
+    USE control_mod
+    
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+
+    ! Variables entree
+    INTEGER,                       INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+    
+    INTEGER       :: l
+    
+    ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1  
+    jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 
+    ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1   
+    jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 
+    IF (pole_sud) THEN
+      ije_v=ij_end-iip1
+      jje_v=jj_end-1
+      ijn_v=ije_v-ijb_v+1
+      jjn_v=jje_v-jjb_v+1 
+    ENDIF
+      
+    
+    
+     PRINT *,'---> on rentre dans guide_main'
+!    CALL AllGather_Field(ucov,ip1jmp1,llm)
+!    CALL AllGather_Field(vcov,ip1jm,llm)
+!    CALL AllGather_Field(teta,ip1jmp1,llm)
+!    CALL AllGather_Field(ps,ip1jmp1,1)
+!    CALL AllGather_Field(q,ip1jmp1,llm)
+    
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+
+    IF (first) THEN
+        first=.FALSE.
+        CALL guide_init 
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
+            enddo
+        endif
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:)
+            IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:)
+            IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:)
+            IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)
+            IF (guide_P) THEN
+                ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u)
+                CALL pression_p(ip1jmp1,ap,bp,ps,p)
+                CALL massdair_p(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+        IF (guide_u) THEN
+            CALL writefield_p('unat',unat1)
+            CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
+        ENDIF
+        IF (guide_T) THEN
+            CALL writefield_p('tnat',tnat1)
+            CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/ REAL(iguide_read)
+      ELSE
+          tau= REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+              write(*,*)'deuxieme passage de advreel a itau=',itau
+              stop
+          ELSE
+              IF (guide_v) vnat1(jjb_v:jje_v,:,:)=vnat2(jjb_v:jje_v,:,:)
+              IF (guide_u) unat1(jjb_u:jje_u,:,:)=unat2(jjb_u:jje_u,:,:)
+              IF (guide_T) tnat1(jjb_u:jje_u,:,:)=tnat2(jjb_u:jje_u,:,:)
+              IF (guide_Q) qnat1(jjb_u:jje_u,:,:)=qnat2(jjb_u:jje_u,:,:)
+              IF (guide_P.OR.guide_modele) psnat1(jjb_u:jje_u,:)=psnat2(jjb_u:jje_u,:)
+              step_rea=step_rea+1
+              itau_test=itau
+              print*,'Lecture fichiers guidage, pas ',step_rea, &
+                    'apres ',count_no_rea,' non lectures'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) CALL guide_out("S",jjp1,1,ps)
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:)
+        endif 
+
+        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("U",jjp1,llm,f_add/factt)
+        ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("T",jjp1,llm,f_add/factt)
+        teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)
+        else
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
+        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
+        IF (f_out) CALL guide_out("P",jjp1,1,f_add(1:ip1jmp1,1)/factt)
+        ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1)
+        CALL pression_p(ip1jmp1,ap,bp,ps,p)
+        CALL massdair_p(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("Q",jjp1,llm,f_add/factt)
+        q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)
+        else
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:)
+        endif 
+        
+        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
+        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
+        IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:)/factt)
+        vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:)
+    endif
+
+  END SUBROUTINE guide_main
+
+!=======================================================================
+  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: hsize
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    IF (hsize==ip1jm) THEN
+      do l=1,vsize
+        field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l)
+      enddo
+    ELSE
+      do l=1,vsize
+        field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l)
+      enddo
+    ENDIF    
+
+  END SUBROUTINE guide_addfield
+
+!=======================================================================
+  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    
+    IF (hsize==jjm) THEN
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_v,jje_v
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ELSE
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_u,jje_u
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ENDIF    
+
+  END SUBROUTINE guide_zonave
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+  USE parallel
+  USE mod_hallo
+  USE Bands
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comgeom2.h"
+  include "comconst.h"
+
+  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
+  REAL, DIMENSION (iip1,jjp1,llmp1)  :: p           ! pression intercouches 
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pbarx 
+  REAL, DIMENSION (iip1,jjm,llm)     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
+  REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
+  REAL, DIMENSION (iip1,jjp1)        :: pks    
+  REAL                               :: prefkap,unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
+  !Variables intermediaires interpolation
+
+!ym rustine temporaire pour ne pas depasser 2GB pour la stack
+!ym  => crach compilo avec la version intel 12
+!  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
+!  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
+  REAL, DIMENSION (:,:,:),ALLOCATABLE     :: zu1,zu2 
+  REAL, DIMENSION (:,:,:),ALLOCATABLE     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  TYPE(Request) :: Req  
+
+    print *,'Guide: conversion variables guidage'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage
+! -----------------------------------------------------------------
+if (guide_modele) then
+    do i=1,iip1
+        do j=jjb_u,jje_u
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+            enddo
+        enddo
+    enddo
+else
+    do i=1,iip1
+        do j=jjb_u,jje_u
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)
+                plnc1(i,j,l)=apnc(l)
+           enddo
+        enddo
+    enddo
+
+endif
+    if (first) then
+        first=.FALSE.
+        print*,'Guide: verification ordre niveaux verticaux'
+        print*,'LMDZ :'
+        do l=1,llm
+            print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jje_u)*(bp(l)+bp(l+1))/2.
+        enddo
+        print*,'Fichiers guidage'
+        do l=1,nlevnc
+             print*,'PL(',l,')=',plnc2(1,jjb_u,l)
+        enddo
+        print *,'inversion de l''ordre: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+                print*,'U(',l,')=',unat2(1,jjb_u,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+                print*,'T(',l,')=',tnat2(1,jjb_u,l)
+            enddo
+        endif
+        ALLOCATE(zu1(iip1,jjp1,llm),zu2(iip1,jjp1,llm)) 
+        ALLOCATE(zv1(iip1,jjm,llm),zv2(iip1,jjm,llm)) 
+    endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+    CALL pression_p( ip1jmp1, ap, bp, psi, p )
+    CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
+
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    unskap=1./kappa
+    prefkap =  preff  ** kappa
+    DO l = 1, llm
+        DO j=jjb_u,jje_u
+            DO i =1, iip1
+                pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+            ENDDO
+        ENDDO
+    ENDDO
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+
+     CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+     CALL SendRequest(Req)
+     CALL WaitRequest(Req)
+
+     call massbar_p(pext, pbarx, pbary )
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=jjb_v,jje_v
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation champs guidage sur niveaux modele (+inversion N/S)
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=jjb_u,jje_u
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_u) THEN
+        CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        do l=1,llm
+            do j=jjb_u,jje_u
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                ugui1(i,l)=0.
+                ugui1(ip1jm+i,l)=0.
+                ugui2(i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_T) THEN
+        CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                      plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                      plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        do l=1,llm
+            do j=jjb_u,jje_u
+                IF (guide_teta) THEN
+		    do i=1,iim
+			ij=(j-1)*iip1+i
+			tgui1(ij,l)=zu1(i,j,l)
+			tgui2(ij,l)=zu2(i,j,l)
+		    enddo
+                ELSE
+		    do i=1,iim
+			ij=(j-1)*iip1+i
+			tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+			tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+		    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(i,l)=tgui2(1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+            enddo
+        enddo
+    ENDIF
+
+    IF (guide_v) THEN
+        
+        CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+        CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+
+        do l=1,llm
+            do j=jjb_v,jje_v
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_Q) THEN
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        do l=1,llm
+            do j=jjb_u,jjb_v
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(i,l)=qgui2(1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+            enddo
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp,       &
+                       plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:))
+            qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en %
+            qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 
+        ENDIF
+    ENDIF
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom2.h"
+    include "serre.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                 print*,'ATTENTION modele peu zoome'
+                 print*,'ATTENTION on prend une constante de guidage cste'
+                 gamma=0.
+            else
+                gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+                print*,'gamma=',gamma
+                if (gamma.lt.1.e-5) then
+                  print*,'gamma =',gamma,'<1e-5'
+                  stop
+                endif
+                gamma=log(0.5)/log(gamma)
+                if (gamma4) then 
+                  gamma=min(gamma,4.)
+                endif
+                print*,'gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidQ
+    INTEGER, SAVE         :: varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Niveaux de pression si non constants
+         if (guide_modele) then
+             print *,'Lecture du guidage sur niveaux mod�le'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (.not.guide_modele) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_modele) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         else
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,llm,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidQ
+    INTEGER, SAVE         :: varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjp1,llm) :: zu
+    REAL, DIMENSION (jjm,llm)  :: zv
+    INTEGER               :: i
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Niveaux de pression si non constants
+         if (guide_modele) then
+             print *,'Lecture du guidage sur niveaux mod�le'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (.not.guide_modele) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_modele) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         else
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
+#endif
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
+#endif
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,tnat2)
+         ENDIF
+
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
+#endif
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+         
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,llm,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
+#endif
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,llm,vnat2)
+         ENDIF
+
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
+#endif
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field)
+    USE parallel
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    
+    ! Variables entree
+    CHARACTER, INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid
+    
+    CALL gather_field(field,iip1*hsize,vsize,0)
+    
+    IF (mpi_rank /= 0) RETURN
+    
+    print *,'Guide: output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
+#else
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
+#endif
+! --------------------------------------------------------------------
+! Cr�ation des variables sauvegard�es
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Surface pressure (GCM)
+        dim3=(/id_lonv,id_latu,id_tim/)
+        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    SELECT CASE (varname)
+    CASE ("S")
+        timestep=timestep+1
+        ierr = NF_INQ_VARID(nid,"SP",varid)
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("P")
+        ierr = NF_INQ_VARID(nid,"ps",varid)
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("U")
+        ierr = NF_INQ_VARID(nid,"ucov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("V")
+        ierr = NF_INQ_VARID(nid,"vcov",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("T")
+        ierr = NF_INQ_VARID(nid,"teta",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    CASE ("Q")
+        ierr = NF_INQ_VARID(nid,"q",varid)
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
+#else
+        ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
+#endif
+    END SELECT
+ 
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_p_mod
Index: LMDZ5/trunk/libf/heavyside.F
===================================================================
--- LMDZ5/trunk/libf/heavyside.F	(revision 1630)
+++ LMDZ5/trunk/libf/heavyside.F	(revision 1630)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+c
+c
+       FUNCTION heavyside(a)
+
+c      ...   P. Le Van  ....
+c
+       IMPLICIT NONE
+
+       REAL(KIND=8) heavyside , a
+
+       IF ( a.LE.0. )  THEN
+         heavyside = 0.
+       ELSE
+         heavyside = 1.
+       ENDIF
+
+       RETURN
+       END
+
+
Index: LMDZ5/trunk/libf/infotrac.F90
===================================================================
--- LMDZ5/trunk/libf/infotrac.F90	(revision 1630)
+++ LMDZ5/trunk/libf/infotrac.F90	(revision 1630)
@@ -0,0 +1,335 @@
+! $Id$
+!
+MODULE infotrac
+
+! nqtot : total number of tracers and higher order of moment, water vapor and liquid included
+  INTEGER, SAVE :: nqtot
+
+! nbtr : number of tracers not including higher order of moment or water vapor or liquid
+!        number of tracers used in the physics
+  INTEGER, SAVE :: nbtr
+
+! Name variables
+  CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
+  CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics
+
+! iadv  : index of trasport schema for each tracer
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iadv
+
+! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the 
+!         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
+
+! conv_flg(it)=0 : convection desactivated for tracer number it 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: conv_flg
+! pbl_flg(it)=0  : boundary layer diffusion desactivaded for tracer number it 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: pbl_flg
+
+  CHARACTER(len=4),SAVE :: type_trac
+ 
+CONTAINS
+
+  SUBROUTINE infotrac_init
+    USE control_mod
+    IMPLICIT NONE
+!=======================================================================
+!
+!   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+!   -------
+!   Modif special traceur F.Forget 05/94
+!   Modif M-A Filiberti 02/02 lecture de traceur.def
+!
+!   Objet:
+!   ------
+!   GCM LMD nouvelle grille
+!
+!=======================================================================
+!   ... modification de l'integration de q ( 26/04/94 ) ....
+!-----------------------------------------------------------------------
+! Declarations
+
+    INCLUDE "dimensions.h"
+    INCLUDE "iniprint.h"
+
+! Local variables
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv  ! index of horizontal trasport schema
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv  ! index of vertical trasport schema
+
+    CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0  ! tracer short name
+    CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA
+    CHARACTER(len=3), DIMENSION(30) :: descrq
+    CHARACTER(len=1), DIMENSION(3)  :: txts
+    CHARACTER(len=2), DIMENSION(9)  :: txtp
+    CHARACTER(len=13)               :: str1,str2
+  
+    INTEGER :: nqtrue  ! number of tracers read from tracer.def, without higer order of moment
+    INTEGER :: iq, new_iq, iiq, jq, ierr
+    INTEGER, EXTERNAL :: lnblnk
+ 
+!-----------------------------------------------------------------------
+! Initialization :
+!
+    txts=(/'x','y','z'/)
+    txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/)
+
+    descrq(14)='VLH'
+    descrq(10)='VL1'
+    descrq(11)='VLP'
+    descrq(12)='FH1'
+    descrq(13)='FH2'
+    descrq(16)='PPM'
+    descrq(17)='PPS'
+    descrq(18)='PPP'
+    descrq(20)='SLP'
+    descrq(30)='PRA'
+    
+
+    IF (config_inca=='none') THEN
+       type_trac='lmdz'
+    ELSE
+       type_trac='inca'
+    END IF
+
+!-----------------------------------------------------------------------
+!
+! 1) Get the true number of tracers + water vapor/liquid
+!    Here true tracers (nqtrue) means declared tracers (only first order)
+!
+!-----------------------------------------------------------------------
+    IF (type_trac == 'lmdz') THEN
+       OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
+       IF(ierr.EQ.0) THEN
+          WRITE(lunout,*) 'Open traceur.def : ok'
+          READ(90,*) nqtrue
+       ELSE 
+          WRITE(lunout,*) 'Problem in opening traceur.def'
+          WRITE(lunout,*) 'ATTENTION using defaut values'
+          nqtrue=4 ! Defaut value
+       END IF
+       ! Attention! Only for planet_type=='earth'
+       nbtr=nqtrue-2
+    ELSE
+       ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F 
+       nqtrue=nbtr+2
+    END IF
+
+    IF (nqtrue < 2) THEN
+       WRITE(lunout,*) 'nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum'
+       CALL abort_gcm('infotrac_init','Not enough tracers',1)
+    END IF
+!
+! Allocate variables depending on nqtrue and nbtr
+!
+    ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue))
+    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr))
+    conv_flg(:) = 1 ! convection activated for all tracers
+    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
+
+!-----------------------------------------------------------------------
+! 2)     Choix  des schemas d'advection pour l'eau et les traceurs
+!
+!     iadv = 1    schema  transport type "humidite specifique LMD"
+!     iadv = 2    schema   amont
+!     iadv = 14   schema  Van-leer + humidite specifique 
+!                            Modif F.Codron
+!     iadv = 10   schema  Van-leer (retenu pour l'eau vapeur et liquide)
+!     iadv = 11   schema  Van-Leer pour hadv et version PPM (Monotone) pour vadv
+!     iadv = 12   schema  Frederic Hourdin I
+!     iadv = 13   schema  Frederic Hourdin II
+!     iadv = 16   schema  PPM Monotone(Collela & Woodward 1984)
+!     iadv = 17   schema  PPM Semi Monotone (overshoots autorisés)
+!     iadv = 18   schema  PPM Positif Defini (overshoots undershoots autorisés)
+!     iadv = 20   schema  Slopes
+!     iadv = 30   schema  Prather
+!
+!        Dans le tableau q(ij,l,iq) : iq = 1  pour l'eau vapeur
+!                                     iq = 2  pour l'eau liquide
+!       Et eventuellement             iq = 3,nqtot pour les autres traceurs
+!
+!        iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+!------------------------------------------------------------------------
+!
+!    Get choice of advection schema from file tracer.def or from INCA
+!---------------------------------------------------------------------
+    IF (type_trac == 'lmdz') THEN
+       IF(ierr.EQ.0) THEN
+          ! Continue to read tracer.def
+          DO iq=1,nqtrue
+             READ(90,999) hadv(iq),vadv(iq),tnom_0(iq)
+          END DO
+          CLOSE(90)  
+       ELSE ! Without tracer.def
+          hadv(1) = 14
+          vadv(1) = 14
+          tnom_0(1) = 'H2Ov'
+          hadv(2) = 10
+          vadv(2) = 10
+          tnom_0(2) = 'H2Ol'
+          hadv(3) = 10
+          vadv(3) = 10
+          tnom_0(3) = 'RN'
+          hadv(4) = 10
+          vadv(4) = 10
+          tnom_0(4) = 'PB'
+       END IF
+       
+       WRITE(lunout,*) 'Valeur de traceur.def :'
+       WRITE(lunout,*) 'nombre de traceurs ',nqtrue
+       DO iq=1,nqtrue
+          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq)
+       END DO
+
+    ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
+! le module de chimie fournit les noms des traceurs
+! et les schemas d'advection associes.
+     
+#ifdef INCA
+       CALL init_transport( &
+            hadv, &
+            vadv, &
+            conv_flg, &
+            pbl_flg,  &
+            tracnam)
+#endif
+       tnom_0(1)='H2Ov'
+       tnom_0(2)='H2Ol'
+
+       DO iq =3,nqtrue
+          tnom_0(iq)=tracnam(iq-2)
+       END DO
+
+    END IF ! type_trac
+
+!-----------------------------------------------------------------------
+!
+! 3) Verify if advection schema 20 or 30 choosen
+!    Calculate total number of tracers needed: nqtot
+!    Allocate variables depending on total number of tracers
+!-----------------------------------------------------------------------
+    new_iq=0
+    DO iq=1,nqtrue
+       ! Add tracers for certain advection schema
+       IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN
+          new_iq=new_iq+1  ! no tracers added
+       ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN
+          new_iq=new_iq+4  ! 3 tracers added
+       ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN
+          new_iq=new_iq+10 ! 9 tracers added
+       ELSE
+          WRITE(lunout,*) 'This choice of advection schema is not available'
+          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1)
+       END IF
+    END DO
+    
+    IF (new_iq /= nqtrue) THEN
+       ! The choice of advection schema imposes more tracers
+       ! Assigne total number of tracers
+       nqtot = new_iq
+
+       WRITE(lunout,*) 'The choice of advection schema for one or more tracers'
+       WRITE(lunout,*) 'makes it necessary to add tracers'
+       WRITE(lunout,*) nqtrue,' is the number of true tracers'
+       WRITE(lunout,*) nqtot, ' is the total number of tracers needed'
+
+    ELSE
+       ! The true number of tracers is also the total number
+       nqtot = nqtrue
+    END IF
+
+!
+! Allocate variables with total number of tracers, nqtot
+!
+    ALLOCATE(tname(nqtot), ttext(nqtot))
+    ALLOCATE(iadv(nqtot), niadv(nqtot))
+
+!-----------------------------------------------------------------------
+!
+! 4) Determine iadv, long and short name
+!
+!-----------------------------------------------------------------------
+    new_iq=0
+    DO iq=1,nqtrue
+       new_iq=new_iq+1
+
+       ! Verify choice of advection schema
+       IF (hadv(iq)==vadv(iq)) THEN
+          iadv(new_iq)=hadv(iq)
+       ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN
+          iadv(new_iq)=11
+       ELSE
+          WRITE(lunout,*)'This choice of advection schema is not available'
+          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1)
+       END IF
+      
+       str1=tnom_0(iq)
+       tname(new_iq)= tnom_0(iq)
+       IF (iadv(new_iq)==0) THEN
+          ttext(new_iq)=str1(1:lnblnk(str1))
+       ELSE
+          ttext(new_iq)=str1(1:lnblnk(str1))//descrq(iadv(new_iq))
+       END IF
+
+       ! schemas tenant compte des moments d'ordre superieur
+       str2=ttext(new_iq)
+       IF (iadv(new_iq)==20) THEN
+          DO jq=1,3
+             new_iq=new_iq+1
+             iadv(new_iq)=-20
+             ttext(new_iq)=str2(1:lnblnk(str2))//txts(jq)
+             tname(new_iq)=str1(1:lnblnk(str1))//txts(jq)
+          END DO
+       ELSE IF (iadv(new_iq)==30) THEN
+          DO jq=1,9
+             new_iq=new_iq+1
+             iadv(new_iq)=-30
+             ttext(new_iq)=str2(1:lnblnk(str2))//txtp(jq)
+             tname(new_iq)=str1(1:lnblnk(str1))//txtp(jq)
+          END DO
+       END IF
+    END DO
+
+!
+! Find vector keeping the correspodence between true and total tracers
+!
+    niadv(:)=0
+    iiq=0
+    DO iq=1,nqtot
+       IF(iadv(iq).GE.0) THEN
+          ! True tracer
+          iiq=iiq+1
+          niadv(iiq)=iq
+       ENDIF
+    END DO
+
+
+    WRITE(lunout,*) 'Information stored in infotrac :'
+    WRITE(lunout,*) 'iadv  niadv tname  ttext :'
+    DO iq=1,nqtot
+       WRITE(lunout,*) iadv(iq),niadv(iq), tname(iq), ttext(iq)
+    END DO
+
+!
+! Test for advection schema. 
+! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) .
+!
+    DO iq=1,nqtot
+       IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN
+          WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
+          CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1)
+       ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN
+          WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
+          CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1)
+       END IF
+    END DO
+
+!-----------------------------------------------------------------------
+! Finalize :
+!
+    DEALLOCATE(tnom_0, hadv, vadv)
+    DEALLOCATE(tracnam)
+
+999 FORMAT (i2,1x,i2,1x,a15)
+
+  END SUBROUTINE infotrac_init
+
+END MODULE infotrac
Index: LMDZ5/trunk/libf/iniacademic.F
===================================================================
--- LMDZ5/trunk/libf/iniacademic.F	(revision 1630)
+++ LMDZ5/trunk/libf/iniacademic.F	(revision 1630)
@@ -0,0 +1,201 @@
+!
+! $Id: iniacademic.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+      SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+
+      USE filtreg_mod
+      USE infotrac, ONLY : nqtot
+
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 15/01/93
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      USE control_mod
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "academic.h"
+#include "ener.h"
+#include "temps.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+
+      real time_0
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle
+      REAL q(ip1jmp1,llm,nqtot)              ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+
+c   Local:
+c   ------
+
+      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 phi(ip1jmp1,llm)                  ! geopotentiel
+      REAL ddsin,tetarappelj,tetarappell,zsig
+      real tetajl(jjp1,llm)
+      INTEGER i,j,l,lsup,ij
+
+      real zz,ran1
+      integer idum
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
+
+c-----------------------------------------------------------------------
+! 1. Initializations for Earth-like case
+! --------------------------------------
+      if (planet_type=="earth") then
+c
+        time_0=0.
+        day_ref=0
+	annee_ref=0
+
+        im         = iim
+        jm         = jjm
+        day_ini    = 0
+        omeg       = 4.*asin(1.)/86400.
+        rad    = 6371229.
+        g      = 9.8
+        daysec = 86400.
+        dtvr    = daysec/REAL(day_step)
+        zdtvr=dtvr
+        kappa  = 0.2857143
+        cpp    = 1004.70885
+        preff     = 101325.
+        pa        =  50000.
+        etot0      = 0.
+        ptot0      = 0.
+        ztot0      = 0.
+        stot0      = 0.
+        ang0       = 0.
+
+        CALL iniconst
+        CALL inigeom
+        CALL inifilr
+
+        ps=0.
+        phis=0.
+c---------------------------------------------------------------------
+
+        taurappel=10.*daysec
+
+c---------------------------------------------------------------------
+c   Calcul de la temperature potentielle :
+c   --------------------------------------
+
+        DO l=1,llm
+         zsig=ap(l)/preff+bp(l)
+         if (zsig.gt.0.3) then
+           lsup=l
+           tetarappell=1./8.*(-log(zsig)-.5)
+           DO j=1,jjp1
+             ddsin=sin(rlatu(j))-sin(pi/20.)
+             tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell)
+           ENDDO
+          else
+c   Choix isotherme au-dessus de 300 mbar
+           do j=1,jjp1
+             tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
+           enddo
+          endif ! of if (zsig.gt.0.3)
+        ENDDO ! of DO l=1,llm
+
+        do l=1,llm
+           do j=1,jjp1
+              do i=1,iip1
+                 ij=(j-1)*iip1+i
+                 tetarappel(ij,l)=tetajl(j,l)
+              enddo
+           enddo
+        enddo
+
+c       call dump2d(jjp1,llm,tetajl,'TEQ   ')
+
+        ps=1.e5
+        phis=0.
+        CALL pression ( ip1jmp1, ap, bp, ps, p       )
+        CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+        CALL massdair(p,masse)
+
+c  intialisation du vent et de la temperature
+        teta(:,:)=tetarappel(:,:)
+        CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
+        call ugeostr(phi,ucov)
+        vcov=0.
+        q(:,:,1   )=1.e-10
+        q(:,:,2   )=1.e-15
+        q(:,:,3:nqtot)=0.
+
+
+c   perturbation aleatoire sur la temperature
+        idum  = -1
+        zz = ran1(idum)
+        idum  = 0
+        do l=1,llm
+           do ij=iip2,ip1jm
+              teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum))
+           enddo
+        enddo
+
+        do l=1,llm
+           do ij=1,ip1jmp1,iip1
+              teta(ij+iim,l)=teta(ij,l)
+           enddo
+        enddo
+
+
+
+c     PRINT *,' Appel test_period avec tetarappel '
+c     CALL  test_period ( ucov,vcov,tetarappel,q,p,phis )
+c     PRINT *,' Appel test_period avec teta '
+c     CALL  test_period ( ucov,vcov,teta,q,p,phis )
+
+c   initialisation d'un traceur sur une colonne
+        j=jjp1*3/4
+        i=iip1/2
+        ij=(j-1)*iip1+i
+        q(ij,:,3)=1.
+      
+      else
+        write(lunout,*)"iniacademic: planet types other than earth",
+     &                 " not implemented (yet)."
+        stop
+      endif ! of if (planet_type=="earth")
+      return
+      END
+c-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/iniconst.F
===================================================================
--- LMDZ5/trunk/libf/iniconst.F	(revision 1630)
+++ LMDZ5/trunk/libf/iniconst.F	(revision 1630)
@@ -0,0 +1,63 @@
+!
+! $Id: iniconst.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE iniconst
+
+      USE control_mod
+      IMPLICIT NONE
+c
+c      P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "comvert.h"
+
+
+c
+c
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+      if (planet_type=="earth") then
+        disvert_type=1
+      else
+        disvert_type=2
+      endif
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+c
+
+      r       = cpp * kappa
+
+      PRINT*,' R  CP  Kappa ',  r , cpp,  kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: LMDZ5/trunk/libf/inidissip.F
===================================================================
--- LMDZ5/trunk/libf/inidissip.F	(revision 1630)
+++ LMDZ5/trunk/libf/inidissip.F	(revision 1630)
@@ -0,0 +1,226 @@
+!
+! $Id: inidissip.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  ,
+     *                       tetagdiv,tetagrot,tetatemp             )
+c=======================================================================
+c   initialisation de la dissipation horizontale
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      USE control_mod
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "logic.h"
+
+      LOGICAL lstardis
+      INTEGER nitergdiv,nitergrot,niterh
+      REAL    tetagdiv,tetagrot,tetatemp
+      REAL fact,zvert(llm),zz
+      REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm)
+      REAL ullm,vllm,umin,vmin,zhmin,zhmax
+      REAL zllm,z1llm
+
+      INTEGER l,ij,idum,ii
+      REAL tetamin
+      REAL pseudoz
+
+      REAL ran1
+
+
+c-----------------------------------------------------------------------
+c
+c   calcul des valeurs propres des operateurs par methode iterrative:
+c   -----------------------------------------------------------------
+
+      crot     = -1.
+      cdivu    = -1.
+      cdivh    = -1.
+
+c   calcul de la valeur propre de divgrad:
+c   --------------------------------------
+      idum = 0
+      DO l = 1, llm
+       DO ij = 1, ip1jmp1
+        deltap(ij,l) = 1.
+       ENDDO
+      ENDDO
+
+      idum  = -1
+      zh(1) = RAN1(idum)-.5
+      idum  = 0
+      DO ij = 2, ip1jmp1
+        zh(ij) = RAN1(idum) -.5
+      ENDDO
+
+      CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
+
+      CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+      IF ( zhmin .GE. zhmax  )     THEN
+         PRINT*,'  Inidissip  zh min max  ',zhmin,zhmax
+         STOP'probleme generateur alleatoire dans inidissip'
+      ENDIF
+
+      zllm = ABS( zhmax )
+      DO l = 1,50
+         IF(lstardis) THEN
+            CALL divgrad2(1,zh,deltap,niterh,zh)
+         ELSE
+            CALL divgrad (1,zh,niterh,zh)
+         ENDIF
+
+        CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+         zllm  = ABS( zhmax )
+         z1llm = 1./zllm
+         DO ij = 1,ip1jmp1
+            zh(ij) = zh(ij)* z1llm
+         ENDDO
+      ENDDO
+
+      IF(lstardis) THEN
+         cdivh = 1./ zllm
+      ELSE
+         cdivh = zllm ** ( -1./niterh )
+      ENDIF
+
+c   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
+c   -----------------------------------------------------------------
+      print*,'calcul des valeurs propres'
+
+      DO  20  ii = 1, 2
+c
+         DO ij = 1, ip1jmp1
+           zu(ij)  = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
+         DO ij = 1, ip1jm
+            zv(ij) = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
+
+         CALL minmax(iip1*jjp1,zu,umin,ullm )
+         CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+         ullm = ABS ( ullm )
+         vllm = ABS ( vllm )
+
+         DO  5  l = 1, 50
+            IF(ii.EQ.1) THEN
+ccccc             CALL covcont( 1,zu,zv,zu,zv )
+               IF(lstardis) THEN
+                  CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv )
+               ELSE
+                  CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv )
+               ENDIF
+            ELSE
+               IF(lstardis) THEN
+                  CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv )
+               ELSE
+                  CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv )
+               ENDIF
+            ENDIF
+
+            CALL minmax(iip1*jjp1,zu,umin,ullm )
+            CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+            ullm = ABS  ( ullm )
+            vllm = ABS  ( vllm )
+
+            zllm  = MAX( ullm,vllm )
+            z1llm = 1./ zllm
+            DO ij = 1, ip1jmp1
+              zu(ij) = zu(ij)* z1llm
+            ENDDO
+            DO ij = 1, ip1jm
+               zv(ij) = zv(ij)* z1llm
+            ENDDO
+ 5       CONTINUE
+
+         IF ( ii.EQ.1 ) THEN
+            IF(lstardis) THEN
+               cdivu  = 1./zllm
+            ELSE
+               cdivu  = zllm **( -1./nitergdiv )
+            ENDIF
+         ELSE
+            IF(lstardis) THEN
+               crot   = 1./ zllm
+            ELSE
+               crot   = zllm **( -1./nitergrot )
+            ENDIF
+         ENDIF
+
+ 20   CONTINUE
+
+c   petit test pour les operateurs non star:
+c   ----------------------------------------
+
+c     IF(.NOT.lstardis) THEN
+         fact    = rad*24./REAL(jjm)
+         fact    = fact*fact
+         PRINT*,'coef u ', fact/cdivu, 1./cdivu
+         PRINT*,'coef r ', fact/crot , 1./crot
+         PRINT*,'coef h ', fact/cdivh, 1./cdivh
+c     ENDIF
+
+c-----------------------------------------------------------------------
+c   variation verticale du coefficient de dissipation:
+c   --------------------------------------------------
+
+      if (ok_strato .and. llm==39) then
+         do l=1,llm
+            pseudoz=8.*log(preff/presnivs(l))
+            zvert(l)=1+
+     s      (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2.
+     s      *(dissip_factz-1.)
+         enddo 
+      else
+         DO l=1,llm
+            zvert(l)=1.
+         ENDDO
+         fact=2.
+         DO l = 1, llm
+            zz      = 1. - preff/presnivs(l)
+            zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
+         ENDDO
+      endif
+
+
+      PRINT*,'Constantes de temps de la diffusion horizontale'
+
+      tetamin =  1.e+6
+
+      DO l=1,llm
+        tetaudiv(l)   = zvert(l)/tetagdiv
+        tetaurot(l)   = zvert(l)/tetagrot
+        tetah(l)      = zvert(l)/tetatemp
+
+        IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
+        IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
+        IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
+      ENDDO
+
+      PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod
+      idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+      PRINT *,' INIDI tetamin idissip ',tetamin,idissip
+      idissip = MAX(iperiod,idissip)
+      dtdiss  = idissip * dtvr
+      PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss
+
+      DO l = 1,llm
+         PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l),
+     *                   dtdiss*tetah(l)
+      ENDDO
+
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/inigeom.F
===================================================================
--- LMDZ5/trunk/libf/inigeom.F	(revision 1630)
+++ LMDZ5/trunk/libf/inigeom.F	(revision 1630)
@@ -0,0 +1,699 @@
+!
+! $Id: inigeom.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+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
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "serre.h"
+#include "logic.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.NE.2 ) THEN
+        gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. )
+      ELSE
+        gamdi_gdiv = 0.
+      ENDIF
+      IF( nitergrot.NE.2 ) THEN
+        gamdi_grot = coefdis/ ( REAL(nitergrot) -2. )
+      ELSE
+        gamdi_grot = 0.
+      ENDIF
+      IF( niterh.NE.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 10 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.LE.eps )GO TO 11
+        xo1 = x1
+ 10     CONTINUE
+ 11     CONTINUE
+c
+        transx = xo1
+
+        itmay = 10
+        eps   = .1e-7
+C
+        yo1  = 0.
+        DO 15 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.LE.eps) GO TO 17
+        yo1  = y1
+ 15     CONTINUE
+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 fxyhyper( clat, grossismy, dzoomy, tauy    , 
+     ,                clon, grossismx, dzoomx, taux    ,
+     , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2  ,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,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 35 j = 1, jjp1
+c
+      IF ( j. eq. 1 )  THEN
+c
+      yprm           = yprimu1(j)
+      rlatm          = rlatu1(j)
+c
+      coslatm        = COS( rlatm )
+      radclatm       = 0.5* rad * coslatm
+c
+      DO 30 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)
+  30  CONTINUE
+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. eq. 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 31 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)
+ 31   CONTINUE
+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 .gt. 1 .AND. j .lt. 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
+         DO 32 i = 1,iim
+         xprp            = xprimp025( i )
+         xprm            = xprimm025( i )
+      
+         ai14            = un4rad2 * coslatp * yprp
+         ai23            = un4rad2 * coslatm * yprm
+         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)
+  32     CONTINUE
+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 )
+        
+  35  CONTINUE
+c
+c    ..............................................................
+c
+      DO 37 j = 1, jjp1
+      DO 36 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)
+  36  CONTINUE
+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)
+  37  CONTINUE
+c
+
+      DO 42 j = 1,jjp1
+      DO 41 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
+  41  CONTINUE
+      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)
+  42  CONTINUE
+c
+c
+      DO 48 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
+  48  CONTINUE
+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: LMDZ5/trunk/libf/inigrads.F
===================================================================
--- LMDZ5/trunk/libf/inigrads.F	(revision 1630)
+++ LMDZ5/trunk/libf/inigrads.F	(revision 1630)
@@ -0,0 +1,92 @@
+!
+! $Header$
+!
+      subroutine inigrads(if,im
+     s  ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz
+     s  ,dt,file,titlel)
+
+
+      implicit none
+
+      integer if,im,jm,lm,i,j,l,lnblnk
+      real x(im),y(jm),z(lm),fx,fy,fz,dt
+      real xmin,xmax,ymin,ymax
+
+      character file*10,titlel*40
+
+#include "gradsdef.h"
+
+c     data unit/66,32,34,36,38,40,42,44,46,48/
+      integer nf
+      save nf
+      data nf/0/
+
+      unit(1)=66
+      unit(2)=32
+      unit(3)=34
+      unit(4)=36
+      unit(5)=38
+      unit(6)=40
+      unit(7)=42
+      unit(8)=44
+      unit(9)=46
+
+      if (if.le.nf) stop'verifier les appels a inigrads'
+
+      print*,'Entree dans inigrads'
+
+      nf=if
+      title(if)=titlel
+      ivar(if)=0
+
+      fichier(if)=file(1:lnblnk(file))
+
+      firsttime(if)=.true.
+      dtime(if)=dt
+
+      iid(if)=1
+      ifd(if)=im
+      imd(if)=im
+      do i=1,im
+         xd(i,if)=x(i)*fx
+         if(xd(i,if).lt.xmin) iid(if)=i+1
+         if(xd(i,if).le.xmax) ifd(if)=i
+      enddo
+      print*,'On stoke du point ',iid(if),'  a ',ifd(if),' en x'
+
+      jid(if)=1
+      jfd(if)=jm
+      jmd(if)=jm
+      do j=1,jm
+         yd(j,if)=y(j)*fy
+         if(yd(j,if).gt.ymax) jid(if)=j+1
+         if(yd(j,if).ge.ymin) jfd(if)=j
+      enddo
+      print*,'On stoke du point ',jid(if),'  a ',jfd(if),' en y'
+
+      print*,'Open de dat'
+      print*,'file=',file
+      print*,'fichier(if)=',fichier(if)
+
+      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
+      print*,file(1:lnblnk(file))//'.dat'
+
+      OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat'
+     s   ,FORM='unformatted',
+     s   ACCESS='direct'
+     s  ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1))
+
+      print*,'Open de dat ok'
+
+      lmd(if)=lm
+      do l=1,lm
+         zd(l,if)=z(l)*fz
+      enddo
+
+      irec(if)=0
+
+      print*,if,imd(if),jmd(if),lmd(if)
+      print*,'if,imd(if),jmd(if),lmd(if)'
+
+      return
+      end
Index: LMDZ5/trunk/libf/iniprint.h
===================================================================
--- LMDZ5/trunk/libf/iniprint.h	(revision 1630)
+++ LMDZ5/trunk/libf/iniprint.h	(revision 1630)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!
+! gestion des impressions de sorties et de débogage
+! lunout:    unité du fichier dans lequel se font les sorties 
+!                           (par defaut 6, la sortie standard)
+! prt_level: niveau d'impression souhaité (0 = minimum)
+!
+      INTEGER lunout, prt_level
+      COMMON /comprint/ lunout, prt_level
Index: LMDZ5/trunk/libf/initdynav_loc.F
===================================================================
--- LMDZ5/trunk/libf/initdynav_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/initdynav_loc.F	(revision 1630)
@@ -0,0 +1,279 @@
+!
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel
+       use Write_field
+       use misc_mod
+       USE infotrac
+       use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
+     &        dynhistave_file,dynhistvave_file,dynhistuave_file
+       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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+! 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,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',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
+
+      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
+      call histdef(histuaveid, 'u', 'vent u moyen ',
+     .             'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiidu,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(histvaveid, 'v', 'vent v moyen',
+     .             'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiidv,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(histaveid, 'temp', 'temperature moyenne', 'K',
+     .             iip1, jjp1, 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, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(histaveid, 'phi', 'geopotentiel moyen', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+!        DO iq=1,nqtot
+!          call histdef(histaveid, ttext(iq), ttext(iq), '-',
+!     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+!     .             32, 'ave(X)', t_ops, t_wrt)
+!        enddo
+C
+C  Masse
+C
+      call histdef(histaveid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, 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, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression 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)
+#else
+      write(lunout,*)'initdynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/initdynav_p.F
===================================================================
--- LMDZ5/trunk/libf/initdynav_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/initdynav_p.F	(revision 1630)
@@ -0,0 +1,204 @@
+!
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel
+       use Write_field
+       use misc_mod
+       USE infotrac
+
+      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      infile: nom du fichier histoire a creer
+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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer thoriid, zvertiid
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      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 :: dynave_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
+
+      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',dynave_domain_id)
+             
+      call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,tau0, zjulian, tstep, thoriid,
+     .             fileid,dynave_domain_id)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sigss', 'Niveaux sigma','Pa',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      write(6,*)'inithistave',tstep
+      call histdef(fileid, 'u', 'vents u scalaires moyennes',
+     .             'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(fileid, 'v', 'vents v scalaires moyennes',
+     .             'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(fileid, 'temp', 'temperature moyennee', 'K',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel moyenne', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histdef(fileid, ttext(iq), ttext(iq), '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+#else
+      write(lunout,*)'initdynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/initfluxsto_p.F
===================================================================
--- LMDZ5/trunk/libf/initfluxsto_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/initfluxsto_p.F	(revision 1630)
@@ -0,0 +1,296 @@
+!
+! $Id: initfluxsto_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine initfluxsto_p
+     .  (infile,tstep,t_ops,t_wrt,
+     .                    fileid,filevid,filedid)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel
+       use Write_field
+       use misc_mod
+       
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+
+#ifdef CPP_IOIPSL
+! 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
+      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,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)
+      call histend(filedid)
+      if (ok_sync) then
+        call histsync(fileid)
+        call histsync(filevid)
+        call histsync(filedid)
+      endif
+	
+#else
+      write(lunout,*)'initfluxsto_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/inithist_loc.F
===================================================================
--- LMDZ5/trunk/libf/inithist_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/inithist_loc.F	(revision 1630)
@@ -0,0 +1,280 @@
+!
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine inithist_loc(day0,anne0,tstep,t_ops,t_wrt)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel
+       use Write_field
+       use misc_mod
+       USE infotrac
+       use com_io_dyn_mod, only : histid,histvid,histuid,               &
+     &                        dynhist_file,dynhistv_file,dynhistu_file
+       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      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      nq: nombre de traceurs
+C
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      integer day0, anne0
+      real tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+! 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 :: dynhist_domain_id
+      INTEGER :: dynhistv_domain_id
+      INTEGER :: dynhistu_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',dynhist_domain_id)
+             
+      call histbeg(dynhist_file,iip1, rlong(:,1), jjn,
+     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
+     .             zjulian, tstep, thoriid,
+     .             histid,dynhist_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,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',dynhistv_domain_id)
+
+      call histbeg(dynhistv_file,iip1, rlong(:,1), jjn,
+     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
+     .             zjulian, tstep, vhoriid,
+     .             histvid,dynhistv_domain_id)
+     
+! Grille U
+
+      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',dynhistu_domain_id)
+             
+      call histbeg(dynhistu_file,iip1, rlong(:,1), jjn,
+     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
+     .             zjulian, tstep, uhoriid,
+     .             histuid,dynhistu_domain_id)
+     
+     
+! -------------------------------------------------------------
+C  Appel a histvert pour la grille verticale
+! -------------------------------------------------------------
+      call histvert(histid, 'presnivs', 'Niveaux pression','mb',
+     .              llm, presnivs/100., zvertiid,'down')
+      call histvert(histvid, 'presnivs', 'Niveaux pression','mb',
+     .              llm, presnivs/100., zvertiidv,'down')
+      call histvert(histuid, 'presnivs', 'Niveaux pression','mb',
+     .              llm, presnivs/100., zvertiidu,'down')
+
+C
+! -------------------------------------------------------------
+C  Appels a histdef pour la definition des variables a sauvegarder
+! -------------------------------------------------------------
+C
+C  Vents U
+C
+      call histdef(histuid, 'u', 'vent u moyen ',
+     .             'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiidu,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(histvid, 'v', 'vent v moyen',
+     .             'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiidv,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(histid, 'temp', 'temperature moyenne', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Temperature potentielle
+C
+      call histdef(histid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(histid, 'phi', 'geopotentiel moyen', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+!        DO iq=1,nqtot
+!          call histdef(histid, ttext(iq), ttext(iq), '-',
+!     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+!     .             32, 'ave(X)', t_ops, t_wrt)
+!        enddo
+C
+C  Masse
+C
+      call histdef(histid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+!      call histdef(histid, 'phis', 'geopotentiel au sol', '-',
+!     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+!     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(histid)
+      call histend(histuid)
+      call histend(histvid)
+#else
+      write(lunout,*)'initdynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/inithist_p.F
===================================================================
--- LMDZ5/trunk/libf/inithist_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/inithist_p.F	(revision 1630)
@@ -0,0 +1,257 @@
+!
+! $Id: inithist_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt,
+     .                      fileid,filevid)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel
+       use Write_field
+       use misc_mod
+       USE infotrac
+
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+
+#ifdef CPP_IOIPSL
+! 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, zvertiid
+      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 :: dynu_domain_id
+      INTEGER :: dynv_domain_id
+
+C
+C  Initialisations
+C
+      if (adjust) return
+       
+      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) = 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('dyn_histv', iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn, tau0, zjulian, tstep, vhoriid, 
+     .             filevid,dynv_domain_id)
+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','-',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      jjn=jj_nb
+
+      call histdef(fileid, 'ucov', 'vents u covariants', 'm/s',
+     .             iip1, jjn, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histdef(filevid, 'vcov', 'vents v covariants', 'm/s',
+     .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      jjn=jj_nb
+      
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+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  Traceurs
+C
+        DO iq=1,nqtot
+          call histdef(fileid, ttext(iq),  ttext(iq), '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+#else
+      write(lunout,*)'inithist_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/initial0.F
===================================================================
--- LMDZ5/trunk/libf/initial0.F	(revision 1630)
+++ LMDZ5/trunk/libf/initial0.F	(revision 1630)
@@ -0,0 +1,12 @@
+!
+! $Header$
+!
+      SUBROUTINE initial0(n,x)
+      IMPLICIT NONE
+      INTEGER n,i
+      REAL x(n)
+      DO 10 i=1,n
+         x(i)=0.
+10    CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/integrd_loc.F
===================================================================
--- LMDZ5/trunk/libf/integrd_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/integrd_loc.F	(revision 1630)
@@ -0,0 +1,412 @@
+!
+! $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
+      USE control_mod
+      USE mod_filtreg_p
+      USE write_field_loc
+      USE write_field
+      USE integrd_mod
+      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 "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "logic.h"
+#include "temps.h"
+#include "serre.h"
+      include 'mpif.h'
+
+c   Arguments:
+c   ----------
+
+      INTEGER nq
+
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+      REAL teta(ijb_u:ije_u,llm)
+      REAL q(ijb_u:ije_u,llm,nq)
+      REAL ps0(ijb_u:ije_u),masse(ijb_u:ije_u,llm),phis(ijb_u:ije_u)
+
+      REAL vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm)
+      REAL tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u)
+      REAL massem1(ijb_u:ije_u,llm)
+
+      REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
+      REAL dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u)
+      REAL dq(ijb_u:ije_u,llm,nq), finvmaold(ijb_u:ije_u,llm)
+
+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 ), finvmasse(ijb_u:ije_u,llm)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+
+      INTEGER  l,ij,iq
+
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ijb,ije,jjb,jje
+      LOGICAL :: checksum
+      LOGICAL,SAVE :: checksum_all=.TRUE.
+      INTEGER :: stop_it
+      INTEGER :: ierr,j
+
+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 2 ij = ijb,ije
+       pscr (ij)    = ps0(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)
+   2  CONTINUE
+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).LT.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
+         PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. '
+     &         , ps(stop_it)
+         STOP' dans integrd'
+      ENDIF
+c$OMP END MASTER
+c$OMP BARRIER
+      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
+      STOP
+      ENDIF
+    
+       
+c
+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
+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         )
+
+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 10 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4 ij = ijb,ije
+      uscr( ij )   =  ucov( ij,l )
+      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+   4  CONTINUE
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 5 ij = ijb,ije
+      vscr( ij )   =  vcov( ij,l )
+      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+   5  CONTINUE
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO 6 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)
+   6  CONTINUE
+
+c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
+      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
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+
+c
+c   .......  integration de   q   ......
+c
+      ijb=ij_begin
+      ije=ij_end
+
+	 if (planet_type.eq."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 qminimum_loc( q, nq, deltap )
+	 endif ! of if (planet_type.eq."earth")
+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
+      
+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
+c
+c
+c     .....   FIN  de l'integration  de   q    .......
+
+15    continue
+
+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: LMDZ5/trunk/libf/integrd_mod.F90
===================================================================
--- LMDZ5/trunk/libf/integrd_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/integrd_mod.F90	(revision 1630)
@@ -0,0 +1,46 @@
+MODULE integrd_mod
+
+  REAL,POINTER,SAVE :: p(:,:)
+  REAL,POINTER,SAVE :: deltap(:,:)
+  REAL,POINTER,SAVE :: ps(:)
+
+
+  
+CONTAINS
+
+  SUBROUTINE integrd_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  USE advect_new_mod,ONLY : advect_new_allocate
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(deltap,llm,d)
+    CALL allocate_u(ps,d)
+
+    
+  END SUBROUTINE integrd_allocate
+  
+  SUBROUTINE integrd_switch_caldyn(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(p,distrib_caldyn,dist)
+    CALL switch_u(deltap,distrib_caldyn,dist)
+    CALL switch_u(ps,distrib_caldyn,dist)
+
+    
+    
+  END SUBROUTINE integrd_switch_caldyn
+  
+
+  
+END MODULE integrd_mod  
Index: LMDZ5/trunk/libf/inter_barxy_m.F90
===================================================================
--- LMDZ5/trunk/libf/inter_barxy_m.F90	(revision 1630)
+++ LMDZ5/trunk/libf/inter_barxy_m.F90	(revision 1630)
@@ -0,0 +1,450 @@
+module inter_barxy_m
+
+  ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ
+
+  implicit none
+
+  private
+  public inter_barxy
+
+contains
+
+  SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint)
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+
+    include "dimensions.h"
+    ! (for "iim", "jjm")
+
+    include "paramet.h"
+    ! (for other included files)
+
+    include "comgeom2.h"
+    ! (for "aire", "apoln", "apols")
+
+    REAL, intent(in):: dlonid(:)
+    ! (longitude from input file, in rad, from -pi to pi)
+
+    REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:)
+
+    REAL, intent(in):: rlatimod(:)
+    ! (latitude angle, in degrees or rad, in strictly decreasing order)
+
+    real, intent(out):: champint(:, :)
+    ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les
+    ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U)
+    ! Si taille de la seconde dim = jjm, on veut interpoler sur les
+    ! jjm latitudes rlatv du modèle (latitudes de V) 
+
+    ! Variables local to the procedure:
+
+    REAL champy(iim, size(champ, 2))
+    integer j, i, jnterfd, jmods
+
+    REAL yjmod(size(champint, 2))
+    ! (angle, in degrees, in strictly increasing order)
+
+    REAL   yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order
+    LOGICAL decrois ! "dlatid" is in decreasing order
+
+    !-----------------------------------
+
+    jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), &
+         "inter_barxy jnterfd")
+    jmods = size(champint, 2)
+    call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)")
+    call assert((/size(rlonimod), size(champint, 1)/) == iim, &
+         "inter_barxy iim")
+    call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods')
+    call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)")
+
+    ! Check decreasing order for "rlatimod":
+    DO i = 2, jjm
+       IF (rlatimod(i) >= rlatimod(i-1)) stop &
+            '"inter_barxy": "rlatimod" should be strictly decreasing'
+    ENDDO
+
+    yjmod(:jjm) = ord_coordm(rlatimod)
+    IF (jmods == jjm + 1) THEN
+       IF (90. - yjmod(jjm) < 0.01) stop &
+            '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.'
+    ELSE
+       ! jmods = jjm
+       IF (ABS(yjmod(jjm) - 90.) > 0.01) stop &
+            '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.'
+    ENDIF
+
+    if (jmods == jjm + 1) yjmod(jjm + 1) = 90.
+
+    DO j = 1, jnterfd + 1
+       champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod)
+    ENDDO
+
+    CALL ord_coord(dlatid, yjdat, decrois) 
+    IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1)
+    DO i = 1, iim
+       champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod)
+    ENDDO
+    champint(:, :) = champint(:, jmods:1:-1)
+
+    IF (jmods == jjm + 1) THEN
+       ! Valeurs uniques aux poles
+       champint(:, 1) = SUM(aire(:iim,  1) * champint(:, 1)) / apoln
+       champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) &
+            * champint(:, jjm + 1)) / apols
+    ENDIF
+
+  END SUBROUTINE inter_barxy
+
+  !******************************
+
+  function inter_barx(dlonid, fdat, rlonimod) 
+
+    !        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
+    !            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
+
+    !     idat : indice du champ de donnees, de 1 a idatmax
+    !     imod : indice du champ du modele,  de 1 a  imodmax
+    !     fdat(idat) : champ de donnees (entrees)
+    !     inter_barx(imod) : champ du modele (sorties)
+    !     dlonid(idat): abscisses des interfaces des mailles donnees
+    !     rlonimod(imod): abscisses des interfaces des mailles modele
+    !      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
+    !      ( Les abscisses sont exprimées en degres)
+
+    use assert_eq_m, only: assert_eq
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: dlonid(:)
+    real, intent(in):: fdat(:)
+    real, intent(in):: rlonimod(:)
+
+    real inter_barx(size(rlonimod))
+
+    !    ...  Variables locales ... 
+
+    INTEGER idatmax, imodmax
+    REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
+    REAL  fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) 
+    REAL  xxim(size(rlonimod))
+
+    REAL x0, xim0, dx, dxm
+    REAL chmin, chmax, pi
+
+    INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
+
+    !-----------------------------------------------------
+
+    idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
+    imodmax = size(rlonimod)
+
+    pi = 2. * ASIN(1.)
+
+    !   REDEFINITION DE L'ORIGINE DES ABSCISSES
+    !    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
+    DO imod = 1, imodmax
+       xxim(imod) = rlonimod(imod)
+    ENDDO
+
+    CALL minmax( imodmax, xxim, chmin, chmax)
+    IF( chmax.LT.6.50 )   THEN
+       DO imod = 1, imodmax
+          xxim(imod) = xxim(imod) * 180./pi
+       ENDDO
+    ENDIF
+
+    xim0 = xxim(imodmax) - 360.
+
+    DO imod = 1, imodmax
+       xxim(imod) = xxim(imod) - xim0
+    ENDDO
+
+    idatmax1 = idatmax +1
+
+    DO idat = 1, idatmax
+       xxd(idat) = dlonid(idat)
+    ENDDO
+
+    CALL minmax( idatmax, xxd, chmin, chmax)
+    IF( chmax.LT.6.50 )  THEN
+       DO idat = 1, idatmax
+          xxd(idat) = xxd(idat) * 180./pi
+       ENDDO
+    ENDIF
+
+    DO idat = 1, idatmax
+       xxd(idat) = AMOD( xxd(idat) - xim0, 360. )
+       fdd(idat) = fdat (idat)
+    ENDDO
+
+    i = 2
+    DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
+       i = i + 1
+    ENDDO
+    IF (xxd(i) < xxd(i-1)) THEN
+       ichang = i
+       !  ***  reorganisation  des longitudes entre 0. et 360. degres ****
+       nid = idatmax - ichang +1
+       DO i = 1, nid
+          xchan (i) = xxd(i+ichang -1 )
+          fdchan(i) = fdd(i+ichang -1 )
+       ENDDO
+       DO i=1, ichang -1
+          xchan (i+ nid) = xxd(i)
+          fdchan(i+nid) = fdd(i) 
+       ENDDO
+       DO i =1, idatmax
+          xxd(i) = xchan(i)
+          fdd(i) = fdchan(i)
+       ENDDO
+    end IF
+
+    !    translation des champs de donnees par rapport
+    !    a la nouvelle origine, avec redondance de la
+    !       maille a cheval sur les bords
+
+    id0 = 0
+    id1 = 0
+
+    DO idat = 1, idatmax
+       IF ( xxd( idatmax1- idat ).LT.360.) exit
+       id1 = id1 + 1
+    ENDDO
+
+    DO idat = 1, idatmax
+       IF (xxd(idat).GT.0.) exit
+       id0 = id0 + 1
+    END DO
+
+    IF( id1 /= 0 ) then
+       DO idat = 1, id1
+          xxid(idat) = xxd(idatmax - id1 + idat) - 360.
+          fxd (idat) = fdd(idatmax - id1 + idat)     
+       END DO
+       DO idat = 1, idatmax - id1
+          xxid(idat + id1) = xxd(idat)
+          fxd (idat + id1) = fdd(idat)
+       END DO
+    end IF
+
+    IF(id0 /= 0) then
+       DO idat = 1, idatmax - id0
+          xxid(idat) = xxd(idat + id0)
+          fxd (idat) = fdd(idat + id0)
+       END DO
+
+       DO idat = 1, id0
+          xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
+          fxd  (idatmax - id0 + idat) =  fdd(idat)   
+       END DO
+    else 
+       DO idat = 1, idatmax
+          xxid(idat)  = xxd(idat)
+          fxd (idat)  = fdd(idat)
+       ENDDO
+    end IF
+    xxid(idatmax1) = xxid(1) + 360.
+    fxd (idatmax1) = fxd(1)
+
+    !   initialisation du champ du modele
+
+    inter_barx(:) = 0.
+
+    ! iteration
+
+    x0   = xim0
+    dxm  = 0.
+    imod = 1
+    idat = 1
+
+    do while (imod <= imodmax)
+       do while (xxim(imod).GT.xxid(idat))
+          dx   = xxid(idat) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
+          x0   = xxid(idat)
+          idat = idat + 1
+       end do
+       IF (xxim(imod).LT.xxid(idat)) THEN
+          dx   = xxim(imod) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
+          x0   = xxim(imod)
+          dxm  = 0.
+          imod = imod + 1
+       ELSE
+          dx   = xxim(imod) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
+          x0   = xxim(imod)
+          dxm  = 0.
+          imod = imod + 1
+          idat = idat + 1
+       END IF
+    end do
+
+  END function inter_barx
+
+  !******************************
+
+  function inter_bary(yjdat, fdat, yjmod)
+
+    ! Interpolation barycentrique basée sur les aires.
+    ! Version unidimensionnelle, en latitude.
+    ! L'indice 1 correspond à l'interface maille 1 -- maille 2.
+
+    use assert_m, only: assert
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: yjdat(:)
+    ! (angles, ordonnées des interfaces des mailles des données, in
+    ! degrees, in increasing order)
+
+    REAL, intent(in):: fdat(:) ! champ de données
+
+    REAL, intent(in):: yjmod(:)
+    ! (ordonnées des interfaces des mailles du modèle)
+    ! (in degrees, in strictly increasing order)
+
+    REAL inter_bary(size(yjmod)) ! champ du modèle
+
+    ! Variables local to the procedure:
+
+    REAL y0, dy, dym 
+    INTEGER jdat ! indice du champ de données
+    integer jmod ! indice du champ du modèle
+
+    !------------------------------------
+
+    call assert(size(yjdat) == size(fdat), "inter_bary")
+
+    ! Initialisation des variables
+    inter_bary(:) = 0.
+    y0    = -90.
+    dym   = 0.
+    jmod  = 1
+    jdat  = 1
+
+    do while (jmod <= size(yjmod))
+       do while (yjmod(jmod) > yjdat(jdat))
+          dy         = yjdat(jdat) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat)
+          y0         = yjdat(jdat)
+          jdat       = jdat + 1
+       end do
+       IF (yjmod(jmod) < yjdat(jdat)) THEN
+          dy         = yjmod(jmod) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
+          y0         = yjmod(jmod)
+          dym        = 0.
+          jmod       = jmod + 1
+       ELSE
+          ! {yjmod(jmod) == yjdat(jdat)}
+          dy         = yjmod(jmod) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
+          y0         = yjmod(jmod)
+          dym        = 0.
+          jmod       = jmod + 1
+          jdat       = jdat + 1
+       END IF
+    end do
+    ! Le test de fin suppose que l'interface 0 est commune aux deux
+    ! grilles "yjdat" et "yjmod".
+
+  END function inter_bary
+
+  !******************************
+
+  SUBROUTINE ord_coord(xi, xo, decrois)
+
+    ! This procedure receives an array of latitudes.
+    ! It converts them to degrees if they are in radians.
+    ! If the input latitudes are in decreasing order, the procedure
+    ! reverses their order.
+    ! Finally, the procedure adds 90° as the last value of the array.
+
+    use assert_eq_m, only: assert_eq
+
+    IMPLICIT NONE
+
+    include "comconst.h"
+    ! (for "pi")
+
+    REAL, intent(in):: xi(:)
+    ! (latitude, in degrees or radians, in increasing or decreasing order)
+    ! ("xi" should contain latitudes from pole to pole.
+    ! "xi" should contain the latitudes of the boundaries of grid
+    ! cells, not the centers of grid cells.
+    ! So the extreme values should not be 90° and -90°.)
+
+    REAL, intent(out):: xo(:) ! angles in degrees
+    LOGICAL, intent(out):: decrois
+
+    ! Variables  local to the procedure:
+    INTEGER nmax, i
+
+    !--------------------
+
+    nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord")
+
+    ! Check monotonicity:
+    decrois = xi(2) < xi(1)
+    DO i = 3, nmax
+       IF (decrois .neqv. xi(i) < xi(i-1)) stop &
+            '"ord_coord":  latitudes are not monotonic'
+    ENDDO
+
+    IF (abs(xi(1)) < pi) then
+       ! "xi" contains latitudes in radians
+       xo(:nmax) = xi(:) * 180. / pi
+    else
+       ! "xi" contains latitudes in degrees
+       xo(:nmax) = xi(:)
+    end IF
+
+    IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN
+       print *, "ord_coord"
+       PRINT *, '"xi" should contain the latitudes of the boundaries of ' &
+            // 'grid cells, not the centers of grid cells.'
+       STOP
+    ENDIF
+
+    IF (decrois) xo(:nmax) = xo(nmax:1:- 1)
+    xo(nmax + 1) = 90.
+
+  END SUBROUTINE ord_coord
+
+  !***********************************
+
+  function ord_coordm(xi)
+
+    ! This procedure converts to degrees, if necessary, and inverts the
+    ! order.
+
+    IMPLICIT NONE
+
+    include "comconst.h"
+    ! (for "pi")
+
+    REAL, intent(in):: xi(:) ! angle, in rad or degrees
+    REAL ord_coordm(size(xi)) ! angle, in degrees
+
+    !-----------------------------
+
+    IF (xi(1) < 6.5) THEN
+       ! "xi" is in rad
+       ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi
+    else
+       ! "xi" is in degrees
+       ord_coordm(:) = xi(size(xi):1:-1)
+    ENDIF
+
+  END function ord_coordm
+
+end module inter_barxy_m
Index: LMDZ5/trunk/libf/interpost.F
===================================================================
--- LMDZ5/trunk/libf/interpost.F	(revision 1630)
+++ LMDZ5/trunk/libf/interpost.F	(revision 1630)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+        subroutine interpost(q,qppm)
+
+       implicit none
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.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: LMDZ5/trunk/libf/interpre.F
===================================================================
--- LMDZ5/trunk/libf/interpre.F	(revision 1630)
+++ LMDZ5/trunk/libf/interpre.F	(revision 1630)
@@ -0,0 +1,132 @@
+!
+! $Id: interpre.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+       subroutine interpre(q,qppm,w,fluxwppm,masse,
+     s            apppm,bpppm,massebx,masseby,pbaru,pbarv,
+     s            unatppm,vnatppm,psppm)
+
+      USE control_mod
+      implicit none
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.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+1)
+      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: LMDZ5/trunk/libf/invert_lat.F90
===================================================================
--- LMDZ5/trunk/libf/invert_lat.F90	(revision 1630)
+++ LMDZ5/trunk/libf/invert_lat.F90	(revision 1630)
@@ -0,0 +1,21 @@
+
+SUBROUTINE invert_lat(xsize,ysize,vsize,field)
+
+    IMPLICIT NONE
+ 
+! Input variables
+    INTEGER, INTENT(IN) :: xsize,ysize,vsize
+    REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field
+! Local variables
+    REAL, DIMENSION (xsize,ysize,vsize)                :: f_aux
+    INTEGER :: l,j
+ 
+    DO l=1,vsize
+        DO j=1,ysize
+            f_aux(:,j,l)=field(:,ysize+1-j,l)
+	END DO
+    END DO
+    
+    field=f_aux
+
+    END SUBROUTINE invert_lat
Index: LMDZ5/trunk/libf/ismax.F
===================================================================
--- LMDZ5/trunk/libf/ismax.F	(revision 1630)
+++ LMDZ5/trunk/libf/ismax.F	(revision 1630)
@@ -0,0 +1,24 @@
+!
+! $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 10 i=1,n-1
+       ix=ix+incx
+       if(sx(ix).gt.sxmax) then
+         sxmax=sx(ix)
+         ismax=i+1
+       endif
+10    continue
+c
+      return
+      end
+
Index: LMDZ5/trunk/libf/ismin.F
===================================================================
--- LMDZ5/trunk/libf/ismin.F	(revision 1630)
+++ LMDZ5/trunk/libf/ismin.F	(revision 1630)
@@ -0,0 +1,24 @@
+!
+! $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).lt.sxmin) then
+             sxmin=sx(ix)
+             ismin=i+1
+         endif
+      ENDDO
+c
+      return
+      end
+C
Index: LMDZ5/trunk/libf/juldate.F
===================================================================
--- LMDZ5/trunk/libf/juldate.F	(revision 1630)
+++ LMDZ5/trunk/libf/juldate.F	(revision 1630)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+	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 real (a-h,o-z)
+	frac=((os/60.+om)/60.+oh)/24.
+	ojou=dfloat(ijou)+frac
+	    year=dfloat(ian)
+	    rmon=dfloat(imoi)
+	if (imoi .le. 2) then
+	    year=year-1.
+	    rmon=rmon+12.
+	endif
+	cf=year+(rmon/100.)+(ojou/10000.)
+	if (cf .ge. 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: LMDZ5/trunk/libf/laplacien.F
===================================================================
--- LMDZ5/trunk/libf/laplacien.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien.F	(revision 1630)
@@ -0,0 +1,40 @@
+!
+! $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: LMDZ5/trunk/libf/laplacien_gam.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_gam.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_gam.F	(revision 1630)
@@ -0,0 +1,53 @@
+!
+! $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: LMDZ5/trunk/libf/laplacien_gam_loc.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_gam_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_gam_loc.F	(revision 1630)
@@ -0,0 +1,65 @@
+      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
+      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: LMDZ5/trunk/libf/laplacien_gam_p.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_gam_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_gam_p.F	(revision 1630)
@@ -0,0 +1,65 @@
+      SUBROUTINE laplacien_gam_p ( 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
+      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    ......................................................
+
+      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_p ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam_p ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/laplacien_loc.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_loc.F	(revision 1630)
@@ -0,0 +1,58 @@
+      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
+      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: LMDZ5/trunk/libf/laplacien_p.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_p.F	(revision 1630)
@@ -0,0 +1,56 @@
+      SUBROUTINE laplacien_p ( 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
+      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 )
+      INTEGER :: l
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,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,jje,jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad_p ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf_p ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/laplacien_rot.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_rot.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_rot.F	(revision 1630)
@@ -0,0 +1,39 @@
+!
+! $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: LMDZ5/trunk/libf/laplacien_rot_loc.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_rot_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_rot_loc.F	(revision 1630)
@@ -0,0 +1,47 @@
+      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
+      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: LMDZ5/trunk/libf/laplacien_rot_p.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_rot_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_rot_p.F	(revision 1630)
@@ -0,0 +1,45 @@
+      SUBROUTINE laplacien_rot_p ( 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
+      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
+      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,jje,jjm, klevel,2, 1, .FALSE., 1)
+
+      CALL   nxgrad_p ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf_p  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/laplacien_rotgam.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_rotgam.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_rotgam.F	(revision 1630)
@@ -0,0 +1,44 @@
+!
+! $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: LMDZ5/trunk/libf/laplacien_rotgam_loc.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_rotgam_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_rotgam_loc.F	(revision 1630)
@@ -0,0 +1,48 @@
+      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
+      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: LMDZ5/trunk/libf/laplacien_rotgam_p.F
===================================================================
--- LMDZ5/trunk/libf/laplacien_rotgam_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/laplacien_rotgam_p.F	(revision 1630)
@@ -0,0 +1,48 @@
+      SUBROUTINE laplacien_rotgam_p ( 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
+      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
+      INTEGER :: ijb,ije
+      
+c
+
+      CALL   nxgrad_gam_p ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil_p ( 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: LMDZ5/trunk/libf/leapfrog_loc.F
===================================================================
--- LMDZ5/trunk/libf/leapfrog_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/leapfrog_loc.F	(revision 1630)
@@ -0,0 +1,1613 @@
+! 
+! $Id: leapfrog_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
+#define DEBUG_IO
+#undef DEBUG_IO
+
+
+      SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0,
+     &                        masse0,phis0,q0,clesphy0,
+     &                        time_0)
+
+       USE misc_mod
+       USE parallel
+       USE times
+       USE mod_hallo
+       USE Bands
+       USE Write_Field
+       USE Write_Field_p
+       USE vampir
+       USE timer_filtre, ONLY : print_filtre_timer
+       USE infotrac
+       USE guide_loc_mod, ONLY : guide_main
+       USE getparam
+       USE control_mod
+       USE mod_filtreg_p
+       USE write_field_loc
+       USE allocate_field
+       USE call_dissip_mod, ONLY : call_dissip
+       USE call_calfis_mod, ONLY : call_calfis
+       USE leapfrog_mod
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+c  ... Possibilite de choisir le shema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10 
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "academic.h"
+      include "mpif.h"
+      
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      real zqmin,zqmax
+
+c   variables dynamiques
+      REAL :: vcov0(ijb_v:ije_v,llm),ucov0(ijb_u:ije_u,llm) ! vents covariants
+      REAL :: teta0(ijb_u:ije_u,llm)                 ! temperature potentielle 
+      REAL :: q0(ijb_u:ije_u,llm,nqtot)              ! champs advectes
+      REAL :: ps0(ijb_u:ije_u)                       ! pression  au sol
+      REAL :: masse0(ijb_u:ije_u,llm)                ! masse d'air
+      REAL :: phis0(ijb_u:ije_u)                     ! geopotentiel au sol
+
+!      REAL,SAVE,ALLOCATABLE :: p (:,:  )               ! pression aux interfac.des couches
+!      REAL,SAVE,ALLOCATABLE :: pks(:)                      ! exner au  sol
+!      REAL,SAVE,ALLOCATABLE :: pk(:,:)                   ! exner au milieu des couches
+!      REAL,SAVE,ALLOCATABLE :: pkf(:,:)                  ! exner filt.au milieu des couches
+!      REAL,SAVE,ALLOCATABLE :: phi(:,:)                  ! geopotentiel
+!      REAL,SAVE,ALLOCATABLE :: w(:,:)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+!      REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
+
+c   variables dynamiques au pas -1
+!      REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
+!      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
+!      REAL,SAVE,ALLOCATABLE :: massem1(:,:)
+
+c   tendances dynamiques
+!      REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
+!      REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
+!      REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
+
+c   tendances de la dissipation
+!      REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
+!      REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
+
+c   tendances physiques
+!      REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
+!      REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
+!      REAL,SAVE,ALLOCATABLE :: dpfi(:)
+!      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL tppn(iim),tpps(iim),tpn,tps
+c
+      INTEGER itau,itaufinp1,iav
+!      INTEGER  iday ! jour julien
+      REAL       time 
+
+      REAL  SSUM
+      REAL time_0 
+!      REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
+
+cym      LOGICAL  lafin
+      LOGICAL :: lafin
+      INTEGER ij,iq,l
+      INTEGER ik
+
+      real time_step, t_wrt, t_ops
+
+! jD_cur: jour julien courant
+! jH_cur: heure julienne courante
+      REAL :: jD_cur, jH_cur
+      INTEGER :: an, mois, jour
+      REAL :: secondes
+
+      LOGICAL first,callinigrads
+
+      data callinigrads/.true./
+      character*10 string10
+
+!      REAL,SAVE,ALLOCATABLE :: alpha(:,:),beta(:,:)
+!      REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
+
+c+jld variables test conservation energie
+!      REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+!      REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:)
+!      REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:)
+!      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+      CHARACTER*15 ztit
+!!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+!      SAVE      ip_ebil_dyn
+!      DATA      ip_ebil_dyn/0/
+c-jld 
+
+      character*80 dynhist_file, dynhistave_file
+      character*20 modname
+      character*80 abort_message
+
+
+      logical,PARAMETER :: dissip_conservative=.TRUE.
+ 
+      INTEGER testita
+      PARAMETER (testita = 9)
+
+      logical , parameter :: flag_verif = .false.
+      
+c declaration liees au parallelisme
+      INTEGER :: ierr
+      LOGICAL :: FirstCaldyn
+      LOGICAL :: FirstPhysic
+      INTEGER :: ijb,ije,j,i
+      type(Request) :: TestRequest
+      type(Request) :: Request_Dissip
+      type(Request) :: Request_physic
+
+      INTEGER :: true_itau
+      LOGICAL :: verbose=.true.
+      INTEGER :: iapptrac
+      INTEGER :: AdjustCount
+!      INTEGER :: var_time
+      LOGICAL :: ok_start_timer=.FALSE.
+      LOGICAL, SAVE :: firstcall=.TRUE.
+      TYPE(distrib),SAVE :: new_dist
+      
+c$OMP MASTER
+      ItCount=0
+c$OMP END MASTER      
+      true_itau=0
+      FirstCaldyn=.TRUE.
+      FirstPhysic=.TRUE.
+      iapptrac=0
+      AdjustCount = 0
+      lafin=.false.
+      
+      itaufin   = nday*day_step
+      itaufinp1 = itaufin +1
+      modname="leapfrog_p"
+
+      itau = 0
+      CALL init_nan
+      CALL leapfrog_allocate
+      ucov=ucov0
+      vcov=vcov0
+      teta=teta0
+      ps=ps0
+      masse=masse0
+      phis=phis0
+      q=q0
+      
+!      iday = day_ini+itau/day_step
+!      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+!         IF(time.GT.1.) THEN
+!          time = time-1.
+!          iday = iday+1
+!         ENDIF
+
+c Allocate variables depending on dynamic variable nqtot
+!c$OMP MASTER
+!      
+!      ALLOCATE(p(ijb_u:ije_u,llmp1))
+!      ALLOCATE(pks(ijb_u:ije_u))
+!      ALLOCATE(pk(ijb_u:ije_u,llm))
+!      ALLOCATE(pkf(ijb_u:ije_u,llm))
+!      ALLOCATE(phi(ijb_u:ije_u,llm))
+!      ALLOCATE(w(ijb_u:ije_u,llm))
+!      ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm))
+!      ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm))
+!      ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u))
+!      ALLOCATE(massem1(ijb_u:ije_u,llm))
+!      ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm))
+!      ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u))      
+!      ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm))
+!      ALLOCATE(dtetadis(ijb_u:ije_u,llm))
+!      ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm))
+!      ALLOCATE(dtetafi(ijb_u:ije_u,llm))
+!      ALLOCATE(dpfi(ijb_u:ije_u))
+!      ALLOCATE(dq(ijb_u:ije_u,llm,nqtot))
+!      ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot))
+!      ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
+!      ALLOCATE(finvmaold(ijb_u:ije_u,llm))
+!      ALLOCATE(alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm))
+!      ALLOCATE(flxw(ijb_u:ije_u,llm))
+!      ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
+!      ALLOCATE(dtetaecdt(ijb_u:ije_u,llm))
+!      ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
+!      ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
+!c$OMP END MASTER      
+!c$OMP BARRIER
+
+!                CALL dynredem1_loc("restart.nc",0.0,
+!     &                           vcov,ucov,teta,q,masse,ps)
+
+
+c-----------------------------------------------------------------------
+c   On initialise la pression et la fonction d'Exner :
+c   --------------------------------------------------
+
+c$OMP MASTER
+      dq=0.
+      CALL pression ( ijnb_u, ap, bp, ps, p       )
+c$OMP END MASTER
+      CALL exner_hyb_loc( ijnb_u, ps, p,alpha,beta, pks, pk, pkf)
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+c et du parallelisme !!
+
+   1  CONTINUE
+
+      jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) 
+      jH_cur = jH_ref +                                                 &
+     &          (itau * dtvr / daysec - int(itau * dtvr / daysec)) 
+
+#ifdef CPP_IOIPSL
+      if (ok_guide) then
+!$OMP MASTER
+        call guide_main(itau,ucov,vcov,teta,q,masse,ps)
+!$OMP END MASTER
+!$OMP BARRIER
+      endif
+#endif
+
+
+c
+c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+c       CALL  test_period ( ucov,vcov,teta,q,p,phis )
+c       PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+c     ENDIF 
+c
+cym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+cym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+cym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+cym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+cym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+       if (FirstCaldyn) then
+c$OMP MASTER
+         ucovm1=ucov
+         vcovm1=vcov
+         tetam1= teta
+         massem1= masse
+         psm1= ps
+         
+         finvmaold = masse
+c$OMP END MASTER
+c$OMP BARRIER
+         CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm,
+     &                    -2,2, .TRUE., 1 )
+       else
+! Save fields obtained at previous time step as '...m1'
+         ijb=ij_begin
+         ije=ij_end
+
+c$OMP MASTER           
+         psm1     (ijb:ije) = ps    (ijb:ije)
+c$OMP END MASTER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
+         DO l=1,llm      
+           ije=ij_end
+           ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
+           tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
+           massem1  (ijb:ije,l) = masse (ijb:ije,l)
+           finvmaold(ijb:ije,l)=masse(ijb:ije,l)
+                 
+           if (pole_sud) ije=ij_end-iip1
+           vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
+       
+
+         ENDDO
+c$OMP ENDDO  
+
+
+          CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1, 
+     .                    llm, -2,2, .TRUE., 1 )
+
+       endif ! of if (FirstCaldyn)
+       
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+
+c   ...    P.Le Van .26/04/94  ....
+
+cym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+cym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+cym  ne sert a rien
+cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+
+   2  CONTINUE
+
+c$OMP MASTER
+      ItCount=ItCount+1
+      if (MOD(ItCount,1)==0) then
+        debug=.true.
+      else
+        debug=.false.
+      endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+
+c   date:
+c   -----
+
+
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+
+      IF( purmats ) THEN
+         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
+         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward 
+     s          .and. iflag_phys.EQ.1                 ) apphys = .TRUE.
+      ELSE
+         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
+         IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE.
+      END IF
+
+cym    ---> Pour le moment      
+cym      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      
+      if (firstCaldyn) then
+c$OMP MASTER
+          call Set_Distrib(distrib_caldyn)
+c$OMP END MASTER
+c$OMP BARRIER
+          firstCaldyn=.FALSE.
+cym          call InitTime
+c$OMP MASTER
+          call Init_timer
+c$OMP END MASTER
+      endif
+
+c$OMP MASTER      
+      IF (ok_start_timer) THEN
+        CALL InitTime
+!        ok_start_timer=.FALSE.
+        ok_start_timer=.TRUE.
+      ENDIF      
+c$OMP END MASTER      
+
+
+!ym  PAS D'AJUSTEMENT POUR LE MOMENT     
+      if (Adjust) then
+        AdjustCount=AdjustCount+1
+!        if (iapptrac==iapp_tracvl .and. (forward. OR . leapf)
+!     &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
+        if (Adjustcount>1) then
+           AdjustCount=0
+c$OMP MASTER 
+           call allgather_timer_average
+        verbose=.TRUE.
+        if (Verbose) then
+        
+        print *,'*********************************'
+        print *,'******    TIMER CALDYN     ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i),
+     &            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER VANLEER    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i),
+     &            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER DISSIP    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_dissip(i),timer_dissip,i),
+     &             '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
+        enddo
+        
+!        if (mpi_rank==0) call WriteBands
+        
+       endif
+       
+         call AdjustBands_caldyn(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+         CALL leapfrog_switch_caldyn(new_dist)
+!$OMP BARRIER
+
+
+!$OMP MASTER
+         distrib_caldyn=new_dist
+         CALL set_distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+!         call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+! 
+!        do j=1,nqtot
+!         call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm,
+!     &                                jj_nb_caldyn,0,0,TestRequest)
+!        enddo
+!
+!         call Set_Distrib(distrib_caldyn)
+!         call SendRequest(TestRequest)
+!         call WaitRequest(TestRequest)
+         
+!$OMP MASTER
+        call AdjustBands_dissip(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+        CALL leapfrog_switch_dissip(new_dist)
+!$OMP BARRIER
+!$OMP MASTER
+        distrib_dissip=new_dist
+!$OMP END MASTER
+!$OMP BARRIER
+!        call AdjustBands_physic
+
+c$OMP MASTER  
+        if (mpi_rank==0) call WriteBands
+c$OMP END MASTER  
+
+
+      endif
+      endif       
+     
+      
+      
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+c$OMP BARRIER
+c$OMP MASTER
+       call VTb(VThallo)
+c$OMP END MASTER
+
+       call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(ps,1,1,2,2,1,TestRequest)
+       call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(pks,1,1,1,1,1,TestRequest)
+       call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest)
+       
+c       do j=1,nqtot
+c         call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
+c     *                       TestRequest)
+c        enddo
+
+       call SendRequest(TestRequest)
+c$OMP BARRIER
+       call WaitRequest(TestRequest)
+
+c$OMP MASTER
+       call VTe(VThallo)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      if (debug) then        
+        call WriteField_u('ucov',ucov)
+        call WriteField_v('vcov',vcov)
+        call WriteField_u('teta',teta)
+        call WriteField_u('ps',ps)
+        call WriteField_u('masse',masse)
+        call WriteField_u('pk',pk)
+        call WriteField_u('pks',pks)
+        call WriteField_u('pkf',pkf)
+        call WriteField_u('phis',phis)
+        do j=1,nqtot
+          call WriteField_u('q'//trim(int2str(j)),
+     .                q(:,:,j))
+        enddo
+      endif
+
+      
+      True_itau=True_itau+1
+
+c$OMP MASTER      
+      PRINT *,"---> itau=",itau,"  True_itau=",True_itau
+c$OMP END MASTER
+
+c$OMP MASTER
+      IF (prt_level>9) THEN
+        WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
+      ENDIF
+
+
+      call start_timer(timer_caldyn)
+
+      CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+      
+      call VTb(VTcaldyn)
+c$OMP END MASTER
+!      var_time=time+iday-day_ini
+
+c$OMP BARRIER
+!      CALL FTRACE_REGION_BEGIN("caldyn")
+      time = jD_cur + jH_cur 
+      CALL caldyn_loc 
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+
+!      CALL FTRACE_REGION_END("caldyn")
+
+c$OMP MASTER
+      call VTe(VTcaldyn)
+c$OMP END MASTER      
+
+#ifdef DEBUG_IO    
+      call WriteField_u('du',du)
+      call WriteField_v('dv',dv)
+      call WriteField_u('dteta',dteta)
+      call WriteField_u('dp',dp)
+      call WriteField_u('w',w)
+      call WriteField_u('pbaru',pbaru)
+      call WriteField_v('pbarv',pbarv)
+      call WriteField_u('p',p)
+      call WriteField_u('masse',masse)
+      call WriteField_u('pk',pk)
+#endif
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+
+      
+      IF( forward. OR . leapf )  THEN
+ 
+ 
+         CALL caladvtrac_loc(q,pbaru,pbarv,
+     *        p, masse, dq,  teta,
+     .        flxw,pk, iapptrac)
+
+!      do j=1,nqtot
+!        call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
+!      enddo
+
+c
+      ENDIF ! of IF( forward. OR . leapf )
+
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+c$OMP MASTER 
+       call VTb(VTintegre)
+c$OMP END MASTER
+#ifdef DEBUG_IO    
+      if (true_itau>20) then
+      call WriteField_u('ucovm1',ucovm1)
+      call WriteField_v('vcovm1',vcovm1)
+      call WriteField_u('tetam1',tetam1)
+      call WriteField_u('psm1',psm1)
+      call WriteField_u('ucov_int',ucov)
+      call WriteField_v('vcov_int',vcov)
+      call WriteField_u('teta_int',teta)
+      call WriteField_u('ps_int',ps)
+      endif
+#endif
+c$OMP BARRIER
+!       CALL FTRACE_REGION_BEGIN("integrd")
+
+       CALL integrd_loc ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
+     $              finvmaold                                    )
+
+!       CALL FTRACE_REGION_END("integrd")
+c$OMP BARRIER
+#ifdef DEBUG_IO    
+      call WriteField_u('ucovm1',ucovm1)
+      call WriteField_v('vcovm1',vcovm1)
+      call WriteField_u('tetam1',tetam1)
+      call WriteField_u('psm1',psm1)
+      call WriteField_u('ucov_int',ucov)
+      call WriteField_v('vcov_int',vcov)
+      call WriteField_u('teta_int',teta)
+      call WriteField_u('ps_int',ps)
+#endif    
+c      do j=1,nqtot
+c        call WriteField_p('q'//trim(int2str(j)),
+c     .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+c        call WriteField_p('dq'//trim(int2str(j)),
+c     .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
+c      enddo
+
+
+c$OMP MASTER 
+       call VTe(VTintegre)
+c$OMP END MASTER
+c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+c
+c-----------------------------------------------------------------------
+c   calcul des tendances physiques:
+c   -------------------------------
+c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+c
+       IF( purmats )  THEN
+          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+       ELSE
+          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
+       ENDIF
+
+cc$OMP END PARALLEL
+
+c
+c
+       IF( apphys )  THEN
+       
+         CALL call_calfis(itau,lafin,clesphy0,ucov,vcov,teta,masse,ps,  
+     &                     phis,q,flxw)
+! #ifdef DEBUG_IO    
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('pfi',p)
+!         call WriteField_u('pkfi',pk)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!         enddo
+! #endif
+! c
+! c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+! c
+! cc$OMP PARALLEL DEFAULT(SHARED)
+! cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
+
+! c$OMP MASTER
+!          call suspend_timer(timer_caldyn)
+
+!          write(lunout,*)
+!      &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
+! c$OMP END MASTER
+
+!          CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
+
+! c$OMP BARRIER
+!          CALL exner_hyb_loc(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
+! c$OMP BARRIER
+!            jD_cur = jD_ref + day_ini - day_ref
+!      $        + int (itau * dtvr / daysec) 
+!            jH_cur = jH_ref +                                            &
+!      &              (itau * dtvr / daysec - int(itau * dtvr / daysec)) 
+! !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
+
+! c rajout debug
+! c       lafin = .true.
+
+
+! c   Inbterface avec les routines de phylmd (phymars ... )
+! c   -----------------------------------------------------
+
+! c+jld
+
+! c  Diagnostique de conservation de l'energie : initialisation
+!  
+! c-jld
+! c$OMP BARRIER
+! c$OMP MASTER
+!         call VTb(VThallo)
+! c$OMP END MASTER
+
+! #ifdef DEBUG_IO    
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('pfi',p)
+!         call WriteField_u('pkfi',pk)
+! #endif
+!         call SetTag(Request_physic,800)
+!         
+!         call Register_SwapField_u(ucov,ucov,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_v(vcov,vcov,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+
+!         call Register_SwapField_u(teta,teta,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_u(masse,masse,distrib_physic,
+!      *                            Request_physic,up=1,down=2)
+
+!         call Register_SwapField_u(p,p,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_u(pk,pk,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_u(phis,phis,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_u(phi,phi,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_u(w,w,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call Register_SwapField_u(q,q,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+
+!         call Register_SwapField_u(flxw,flxw,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         
+!         call SendRequest(Request_Physic)
+! c$OMP BARRIER
+!         call WaitRequest(Request_Physic)       
+
+! c$OMP BARRIER
+! c$OMP MASTER
+!         call Set_Distrib(distrib_Physic)
+!         call VTe(VThallo)
+!         
+!         call VTb(VTphysiq)
+! c$OMP END MASTER
+! c$OMP BARRIER
+
+! #ifdef DEBUG_IO    
+!       call WriteField_u('ucovfi',ucov)
+!       call WriteField_v('vcovfi',vcov)
+!       call WriteField_u('tetafi',teta)
+!       call WriteField_u('pfi',p)
+!       call WriteField_u('pkfi',pk)
+!       do j=1,nqtot
+!         call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!       enddo
+! #endif
+!        STOP
+! c$OMP BARRIER
+! !        CALL FTRACE_REGION_BEGIN("calfis")
+!         CALL calfis_loc(lafin ,jD_cur, jH_cur,
+!      $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+!      $               du,dv,dteta,dq,
+!      $               flxw,
+!      $               clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi  )
+! !        CALL FTRACE_REGION_END("calfis")
+! !        ijb=ij_begin
+! !        ije=ij_end  
+! !        if ( .not. pole_nord) then
+! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+! !          DO l=1,llm
+! !          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l) 
+! !          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)  
+! !          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)  
+! !          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)  
+! !          ENDDO
+! !c$OMP END DO NOWAIT
+! !
+! !c$OMP MASTER
+! !          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)  
+! !c$OMP END MASTER
+! !        endif ! of if ( .not. pole_nord)
+
+! !c$OMP BARRIER
+! !c$OMP MASTER
+! !        call Set_Distrib(distrib_physic_bis)
+
+! !        call VTb(VThallo)
+! !c$OMP END MASTER
+! !c$OMP BARRIER
+! ! 
+! !        call Register_Hallo_u(dufi,llm,
+! !     *                      1,0,0,1,Request_physic)
+! !        
+! !        call Register_Hallo_v(dvfi,llm,
+! !     *                      1,0,0,1,Request_physic)
+! !        
+! !        call Register_Hallo_u(dtetafi,llm,
+! !     *                      1,0,0,1,Request_physic)
+! !
+! !        call Register_Hallo_u(dpfi,1,
+! !     *                      1,0,0,1,Request_physic)
+! !
+! !        do j=1,nqtot
+! !          call Register_Hallo_u(dqfi(ijb_u,1,j),llm,
+! !     *                        1,0,0,1,Request_physic)
+! !        enddo
+! !        
+! !        call SendRequest(Request_Physic)
+! !c$OMP BARRIER
+! !        call WaitRequest(Request_Physic)
+! !             
+! !c$OMP BARRIER
+! !c$OMP MASTER
+! !        call VTe(VThallo)
+! ! 
+! !        call set_Distrib(distrib_Physic)
+! !c$OMP END MASTER
+! !c$OMP BARRIER        
+! !                ijb=ij_begin
+! !        if (.not. pole_nord) then
+! !        
+! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+! !          DO l=1,llm
+! !            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+! !            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) 
+! !            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
+! !     &                              +dtetafi_tmp(1:iip1,l)
+! !            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
+! !     &                              + dqfi_tmp(1:iip1,l,:)
+! !          ENDDO
+! !c$OMP END DO NOWAIT
+! !
+! !c$OMP MASTER
+! !          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+! !c$OMP END MASTER
+! !          
+! !        endif ! of if (.not. pole_nord)
+
+! #ifdef DEBUG_IO           
+!         call WriteField_u('dufi',dufi)
+!         call WriteField_v('dvfi',dvfi) 
+!         call WriteField_u('dtetafi',dtetafi)
+!         call WriteField_u('dpfi',dpfi)
+!         do j=1,nqtot
+!           call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
+!        enddo
+! #endif
+
+! c$OMP BARRIER
+
+! c      ajout des tendances physiques:
+! c      ------------------------------
+! #ifdef DEBUG_IO    
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+
+!          IF (ok_strato) THEN
+!            CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
+!          ENDIF
+
+! #ifdef DEBUG_IO           
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+
+!           CALL addfi_loc( dtphys, leapf, forward   ,
+!      $                  ucov, vcov, teta , q   ,ps ,
+!      $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+
+! #ifdef DEBUG_IO    
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+
+! c$OMP BARRIER
+! c$OMP MASTER
+!         call VTe(VTphysiq)
+
+!         call VTb(VThallo)
+! c$OMP END MASTER
+
+!         call SetTag(Request_physic,800)
+!         call Register_SwapField_u(ucov,ucov,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_v(vcov,vcov,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_u(teta,teta,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_u(masse,masse,
+!      *                               distrib_caldyn,Request_physic)
+
+!         call Register_SwapField_u(p,p,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_u(pk,pk,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_u(phis,phis,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_u(phi,phi,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call Register_SwapField_u(w,w,
+!      *                               distrib_caldyn,Request_physic)
+
+!         call Register_SwapField_u(q,q,
+!      *                               distrib_caldyn,Request_physic)
+!         
+!         call SendRequest(Request_Physic)
+! c$OMP BARRIER
+!         call WaitRequest(Request_Physic)     
+
+! c$OMP BARRIER
+! c$OMP MASTER
+!        call VTe(VThallo)
+!        call set_distrib(distrib_caldyn)
+! c$OMP END MASTER
+! c$OMP BARRIER
+! c
+! c  Diagnostique de conservation de l'energie : difference
+!       IF (ip_ebil_dyn.ge.1 ) THEN 
+!           ztit='bil phys'
+!           CALL diagedyn(ztit,2,1,1,dtphys
+!      e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+!       ENDIF 
+
+! #ifdef DEBUG_IO    
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+
+
+! c-jld
+c$OMP MASTER
+         if (FirstPhysic) then
+           ok_start_timer=.TRUE.
+           FirstPhysic=.false.
+         endif
+c$OMP END MASTER
+       ENDIF ! of IF( apphys )
+
+      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+c   Calcul academique de la physique = Rappel Newtonien + fritcion 
+c   --------------------------------------------------------------
+cym       teta(:,:)=teta(:,:)
+cym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+       ijb=ij_begin
+       ije=ij_end
+       teta(ijb:ije,:)=teta(ijb:ije,:)
+     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
+
+       call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic)
+       call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic)
+       call SendRequest(Request_Physic)
+c$OMP BARRIER
+       call WaitRequest(Request_Physic)     
+
+       call friction_loc(ucov,vcov,iphysiq*dtvr)
+      ENDIF ! of IF(iflag_phys.EQ.2)
+
+
+        CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
+c$OMP BARRIER
+        CALL exner_hyb_loc( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+c$OMP BARRIER
+
+cc$OMP END PARALLEL
+
+c-----------------------------------------------------------------------
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+      IF(apdiss) THEN
+      
+        CALL call_dissip(ucov,vcov,teta,p,pk,ps)
+!cc$OMP  PARALLEL DEFAULT(SHARED) 
+!cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
+!c$OMP MASTER
+!        call suspend_timer(timer_caldyn)
+!        
+!c       print*,'Entree dans la dissipation : Iteration No ',true_itau
+!c   calcul de l'energie cinetique avant dissipation
+!c       print *,'Passage dans la dissipation'
+
+!        call VTb(VThallo)
+!c$OMP END MASTER
+
+!c$OMP BARRIER
+
+!        call Register_SwapField_u(ucov,ucov,distrib_dissip,
+!     *                            Request_dissip,up=1,down=1)
+
+!        call Register_SwapField_v(vcov,vcov,distrib_dissip,
+!     *                            Request_dissip,up=1,down=1)
+
+!        call Register_SwapField_u(teta,teta,distrib_dissip,
+!     *                            Request_dissip)
+
+!        call Register_SwapField_u(p,p,distrib_dissip,
+!     *                            Request_dissip)
+
+!        call Register_SwapField_u(pk,pk,distrib_dissip,
+!     *                            Request_dissip)
+
+!        call SendRequest(Request_dissip)       
+!c$OMP BARRIER
+!        call WaitRequest(Request_dissip)       
+
+!c$OMP BARRIER
+!c$OMP MASTER
+!        call set_distrib(distrib_dissip)
+!        call VTe(VThallo)
+!        call VTb(VTdissipation)
+!        call start_timer(timer_dissip)
+!c$OMP END MASTER
+!c$OMP BARRIER
+
+!        call covcont_loc(llm,ucov,vcov,ucont,vcont)
+!        call enercin_loc(vcov,ucov,vcont,ucont,ecin0)
+
+!c   dissipation
+
+!!        CALL FTRACE_REGION_BEGIN("dissip")
+!        CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+
+!#ifdef DEBUG_IO    
+!        call WriteField_u('dudis',dudis)
+!        call WriteField_v('dvdis',dvdis)
+!        call WriteField_u('dtetadis',dtetadis)
+!#endif
+! 
+!!      CALL FTRACE_REGION_END("dissip")
+!         
+!        ijb=ij_begin
+!        ije=ij_end
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+!        DO l=1,llm
+!          ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+!        ENDDO
+!c$OMP END DO NOWAIT        
+!        if (pole_sud) ije=ije-iip1
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+!        DO l=1,llm
+!          vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+!        ENDDO
+!c$OMP END DO NOWAIT        
+
+!c       teta=teta+dtetadis
+
+
+!c------------------------------------------------------------------------
+!        if (dissip_conservative) then
+!C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+!C       lors de la dissipation
+!c$OMP BARRIER
+!c$OMP MASTER
+!            call suspend_timer(timer_dissip)
+!            call VTb(VThallo)
+!c$OMP END MASTER
+!            call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
+!            call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
+!            call SendRequest(Request_Dissip)
+!c$OMP BARRIER
+!            call WaitRequest(Request_Dissip)
+!c$OMP MASTER
+!            call VTe(VThallo)
+!            call resume_timer(timer_dissip)
+!c$OMP END MASTER
+!c$OMP BARRIER            
+!            call covcont_loc(llm,ucov,vcov,ucont,vcont)
+!            call enercin_loc(vcov,ucov,vcont,ucont,ecin)
+!            
+!            ijb=ij_begin
+!            ije=ij_end
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+!            do l=1,llm
+!              do ij=ijb,ije
+!                dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+!                dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+!              enddo
+!            enddo
+!c$OMP END DO NOWAIT            
+!       endif
+
+!       ijb=ij_begin
+!       ije=ij_end
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+!         do l=1,llm
+!           do ij=ijb,ije
+!              teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+!           enddo
+!         enddo
+!c$OMP END DO NOWAIT         
+!c------------------------------------------------------------------------
+
+
+!c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+!c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+!c
+
+!        ijb=ij_begin
+!        ije=ij_end
+!         
+!        if (pole_nord) then
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!          DO l  =  1, llm
+!            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
+!          ENDDO
+!c$OMP END DO NOWAIT
+
+!c$OMP MASTER               
+!          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
+!c$OMP END MASTER
+!        endif
+!        
+!        if (pole_sud) then
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!          DO l  =  1, llm
+!            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
+!          ENDDO
+!c$OMP END DO NOWAIT
+
+!c$OMP MASTER               
+!          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
+!c$OMP END MASTER
+!        endif
+
+
+!c$OMP BARRIER
+!c$OMP MASTER
+!        call VTe(VTdissipation)
+
+!        call stop_timer(timer_dissip)
+!        
+!        call VTb(VThallo)
+!c$OMP END MASTER
+!        call Register_SwapField_u(ucov,ucov,distrib_caldyn,
+!     *                            Request_dissip)
+
+!        call Register_SwapField_v(vcov,vcov,distrib_caldyn,
+!     *                            Request_dissip)
+
+!        call Register_SwapField_u(teta,teta,distrib_caldyn,
+!     *                            Request_dissip)
+
+!        call Register_SwapField_u(p,p,distrib_caldyn,
+!     *                            Request_dissip)
+
+!        call Register_SwapField_u(pk,pk,distrib_caldyn,
+!     *                            Request_dissip)
+
+!        call SendRequest(Request_dissip)       
+!c$OMP BARRIER
+!        call WaitRequest(Request_dissip)       
+
+!c$OMP BARRIER
+!c$OMP MASTER
+!        call set_distrib(distrib_caldyn)
+!        call VTe(VThallo)
+!        call resume_timer(timer_caldyn)
+!c        print *,'fin dissipation'
+!c$OMP END MASTER
+!c$OMP BARRIER
+       END IF
+
+cc$OMP END PARALLEL
+
+c ajout debug
+c              IF( lafin ) then  
+c                abort_message = 'Simulation finished'
+c                call abort_gcm(modname,abort_message,0)
+c              ENDIF
+        
+c   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+
+c   preparation du pas d'integration suivant  ......
+cym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+cym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c$OMP MASTER      
+      call stop_timer(timer_caldyn)
+c$OMP END MASTER
+      IF (itau==itaumax) then
+c$OMP MASTER
+            call allgather_timer_average
+
+      if (mpi_rank==0) then
+        
+        print *,'*********************************'
+        print *,'******    TIMER CALDYN     ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER VANLEER    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER DISSIP    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_dissip(i),timer_dissip,i)
+        enddo
+        
+        print *,'*********************************'
+        print *,'******    TIMER PHYSIC    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_physic(i),timer_physic,i)
+        enddo
+        
+      endif  
+      
+      print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
+      print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
+      print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
+      print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
+      CALL print_filtre_timer
+c$OMP END MASTER
+      CALL dynredem1_loc("restart.nc",0.0,
+     .                               vcov,ucov,teta,q,masse,ps)
+c$OMP MASTER
+      call fin_getparam
+        call finalize_parallel
+c$OMP END MASTER
+c$OMP BARRIER
+        RETURN
+      ENDIF
+      
+      IF ( .NOT.purmats ) THEN
+c       ........................................................
+c       ..............  schema matsuno + leapfrog  ..............
+c       ........................................................
+
+            IF(forward. OR. leapf) THEN
+              itau= itau + 1
+!              iday= day_ini+itau/day_step
+!              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+!                IF(time.GT.1.) THEN
+!                  time = time-1.
+!                  iday = iday+1
+!                ENDIF
+            ENDIF
+
+
+            IF( itau. EQ. itaufinp1 ) then
+
+              if (flag_verif) then
+                write(79,*) 'ucov',ucov
+                write(80,*) 'vcov',vcov
+                write(81,*) 'teta',teta
+                write(82,*) 'ps',ps
+                write(83,*) 'q',q
+                WRITE(85,*) 'q1 = ',q(:,:,1)
+                WRITE(86,*) 'q3 = ',q(:,:,3)
+              endif
+  
+
+c$OMP MASTER
+              call fin_getparam
+              call finalize_parallel
+c$OMP END MASTER
+              abort_message = 'Simulation finished'
+              call abort_gcm(modname,abort_message,0)
+              RETURN
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+c$OMP BARRIER
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+
+#ifdef CPP_IOIPSL
+             IF (ok_dynzon) THEN 
+
+              CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, 
+     ,             ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) 
+
+              ENDIF !ok_dynzon
+
+              IF (ok_dyn_ave) THEN
+                 CALL writedynav_loc(itau,vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+              ENDIF
+#endif
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   ecriture de la bande histoire:
+c   ------------------------------
+
+            IF( MOD(itau,iecri).EQ.0) THEN
+             ! Ehouarn: output only during LF or Backward Matsuno
+	     if (leapf.or.(.not.leapf.and.(.not.forward))) then
+
+c$OMP BARRIER
+c$OMP MASTER
+              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+c$OMP END MASTER
+c$OMP BARRIER
+       
+#ifdef CPP_IOIPSL
+             if (ok_dyn_ins) then
+	         CALL writehist_loc(itau,vcov,ucov,teta,phi,q,
+     &                              masse,ps,phis)
+             endif
+#endif
+            endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
+           ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+
+            IF(itau.EQ.itaufin) THEN
+
+c$OMP BARRIER
+
+              if (planet_type.eq."earth") then
+! Write an Earth-format restart file
+                CALL dynredem1_loc("restart.nc",0.0,
+     &                           vcov,ucov,teta,q,masse,ps)
+              endif ! of if (planet_type.eq."earth")
+
+!              CLOSE(99)
+            ENDIF ! of IF (itau.EQ.itaufin)
+
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2
+                   END IF
+            ELSE
+
+c      ......   pas leapfrog  .....
+
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF ! of IF (MOD(itau,iperiod).EQ.0)
+                   !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
+
+
+      ELSE ! of IF (.not.purmats)
+
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+
+             itau =  itau + 1
+!             iday = day_ini+itau/day_step
+!             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+!
+!                  IF(time.GT.1.) THEN
+!                   time = time-1.
+!                   iday = iday+1
+!                  ENDIF
+
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then  
+c$OMP MASTER
+                 call fin_getparam
+                 call finalize_parallel
+c$OMP END MASTER
+                 abort_message = 'Simulation finished'
+                 call abort_gcm(modname,abort_message,0)
+                 RETURN
+               ENDIF
+               GO TO 2
+
+            ELSE ! of IF(forward) i.e. backward step
+
+              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+
+#ifdef CPP_IOIPSL
+               IF (ok_dynzon) THEN
+               CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+               ENDIF
+              
+               IF (ok_dyn_ave) THEN
+                 CALL writedynav_loc(itau,vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+               ENDIF
+#endif
+              ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
+
+
+               IF(MOD(itau,iecri         ).EQ.0) THEN
+
+c$OMP BARRIER
+c$OMP MASTER
+              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+c$OMP END MASTER
+c$OMP BARRIER
+
+
+#ifdef CPP_IOIPSL
+              if (ok_dyn_ins) then
+                 CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
+              endif ! of if (ok_dyn_ins)
+#endif
+              ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+              
+
+              IF(itau.EQ.itaufin) THEN
+                if (planet_type.eq."earth") then
+                   CALL dynredem1_loc("restart.nc",0.0,
+     .                               vcov,ucov,teta,q,masse,ps)
+                endif ! of if (planet_type.eq."earth")
+              ENDIF ! of IF(itau.EQ.itaufin)
+
+              forward = .TRUE.
+              GO TO  1
+
+            ENDIF ! of IF (forward)
+
+      END IF ! of IF(.not.purmats)
+c$OMP MASTER
+      call fin_getparam
+      call finalize_parallel
+c$OMP END MASTER
+      abort_message = 'Simulation finished'
+      call abort_gcm(modname,abort_message,0)
+      RETURN
+      END
Index: LMDZ5/trunk/libf/leapfrog_mod.F90
===================================================================
--- LMDZ5/trunk/libf/leapfrog_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/leapfrog_mod.F90	(revision 1630)
@@ -0,0 +1,163 @@
+MODULE leapfrog_mod
+
+  REAL,POINTER,SAVE :: ucov(:,:)
+  REAL,POINTER,SAVE :: vcov(:,:)
+  REAL,POINTER,SAVE :: teta(:,:)
+  REAL,POINTER,SAVE :: ps(:)
+  REAL,POINTER,SAVE :: masse(:,:)
+  REAL,POINTER,SAVE :: phis(:)
+  REAL,POINTER,SAVE :: q(:,:,:)
+  REAL,POINTER,SAVE :: p(:,:)
+  REAL,POINTER,SAVE :: pks(:)
+  REAL,POINTER,SAVE :: pk(:,:)
+  REAL,POINTER,SAVE :: pkf(:,:)
+  REAL,POINTER,SAVE :: phi(:,:)
+  REAL,POINTER,SAVE :: w(:,:)
+  REAL,POINTER,SAVE :: pbaru(:,:)
+  REAL,POINTER,SAVE :: pbarv(:,:)
+  REAL,POINTER,SAVE :: vcovm1(:,:)
+  REAL,POINTER,SAVE :: ucovm1(:,:)
+  REAL,POINTER,SAVE :: tetam1(:,:)
+  REAL,POINTER,SAVE :: psm1(:)
+  REAL,POINTER,SAVE :: massem1(:,:)
+  REAL,POINTER,SAVE :: dv(:,:)
+  REAL,POINTER,SAVE :: du(:,:)
+  REAL,POINTER,SAVE :: dteta(:,:)
+  REAL,POINTER,SAVE :: dp(:)
+  REAL,POINTER,SAVE :: dq(:,:,:)
+  REAL,POINTER,SAVE :: finvmaold(:,:)
+  REAL,POINTER,SAVE :: alpha(:,:)
+  REAL,POINTER,SAVE :: beta(:,:)
+  REAL,POINTER,SAVE :: flxw(:,:)
+  REAL,POINTER,SAVE :: unat(:,:)
+  REAL,POINTER,SAVE :: vnat(:,:)
+ 
+
+  
+CONTAINS
+
+  SUBROUTINE leapfrog_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  USE infotrac
+  USE caldyn_mod,ONLY : caldyn_allocate
+  USE integrd_mod,ONLY : integrd_allocate
+  USE caladvtrac_mod,ONLY : caladvtrac_allocate
+  USE call_calfis_mod,ONLY : call_calfis_allocate
+  USE call_dissip_mod, ONLY : call_dissip_allocate
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_u(ucov,llm,d)
+    CALL allocate_v(vcov,llm,d)
+    CALL allocate_u(teta,llm,d)
+    CALL allocate_u(ps,d)
+    CALL allocate_u(masse,llm,d)
+    CALL allocate_u(phis,d)
+    CALL allocate_u(q,llm,nqtot,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(pks,d)
+    CALL allocate_u(pk,llm,d)
+    CALL allocate_u(pkf,llm,d)
+    CALL allocate_u(phi,llm,d)
+    CALL allocate_u(w,llm,d)
+    CALL allocate_u(pbaru,llm,d)
+    CALL allocate_v(pbarv,llm,d)
+    CALL allocate_v(vcovm1,llm,d)
+    CALL allocate_u(ucovm1,llm,d)
+    CALL allocate_u(tetam1,llm,d)
+    CALL allocate_u(psm1,d)
+    CALL allocate_u(massem1,llm,d)
+    CALL allocate_v(dv,llm,d)
+    CALL allocate_u(du,llm,d)
+    CALL allocate_u(dteta,llm,d)
+    CALL allocate_u(dp,d)
+    CALL allocate_u(dq,llm,nqtot,d)
+    CALL allocate_u(finvmaold,llm,d)
+    CALL allocate_u(alpha,llm,d)
+    CALL allocate_u(beta,llm,d)
+    CALL allocate_u(flxw,llm,d)
+    CALL allocate_u(unat,llm,d)
+    CALL allocate_v(vnat,llm,d)
+    
+    CALL caldyn_allocate
+    CALL integrd_allocate
+    CALL caladvtrac_allocate
+    CALL call_calfis_allocate
+    CALL call_dissip_allocate
+        
+  END SUBROUTINE leapfrog_allocate
+  
+  SUBROUTINE leapfrog_switch_caldyn(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE caldyn_mod,ONLY : caldyn_switch_caldyn
+  USE integrd_mod,ONLY : integrd_switch_caldyn
+  USE caladvtrac_mod,ONLY : caladvtrac_switch_caldyn
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(ucov,distrib_caldyn,dist)
+    CALL switch_v(vcov,distrib_caldyn,dist)
+    CALL switch_u(teta,distrib_caldyn,dist)
+    CALL switch_u(ps,distrib_caldyn,dist)
+    CALL switch_u(masse,distrib_caldyn,dist)
+    CALL switch_u(phis,distrib_caldyn,dist,up=halo_max,down=halo_max)
+    CALL switch_u(q,distrib_caldyn,dist)
+    CALL switch_u(p,distrib_caldyn,dist)
+    CALL switch_u(pks,distrib_caldyn,dist)
+    CALL switch_u(pk,distrib_caldyn,dist)
+    CALL switch_u(pkf,distrib_caldyn,dist)
+    CALL switch_u(phi,distrib_caldyn,dist)
+    CALL switch_u(w,distrib_caldyn,dist)
+    CALL switch_u(pbaru,distrib_caldyn,dist)
+    CALL switch_v(pbarv,distrib_caldyn,dist)
+    CALL switch_v(vcovm1,distrib_caldyn,dist)
+    CALL switch_u(ucovm1,distrib_caldyn,dist)
+    CALL switch_u(tetam1,distrib_caldyn,dist)
+    CALL switch_u(psm1,distrib_caldyn,dist)
+    CALL switch_u(massem1,distrib_caldyn,dist)
+    CALL switch_v(dv,distrib_caldyn,dist)
+    CALL switch_u(du,distrib_caldyn,dist)
+    CALL switch_u(dteta,distrib_caldyn,dist)
+    CALL switch_u(dp,distrib_caldyn,dist)
+    CALL switch_u(dq,distrib_caldyn,dist)
+    CALL switch_u(finvmaold,distrib_caldyn,dist)
+    CALL switch_u(alpha,distrib_caldyn,dist)
+    CALL switch_u(beta,distrib_caldyn,dist)
+    CALL switch_u(flxw,distrib_caldyn,dist)
+    CALL switch_u(unat,distrib_caldyn,dist)
+    CALL switch_v(vnat,distrib_caldyn,dist)
+
+    
+    CALL caldyn_switch_caldyn(dist)
+    CALL integrd_switch_caldyn(dist)
+    CALL caladvtrac_switch_caldyn(dist)
+    
+  END SUBROUTINE leapfrog_switch_caldyn
+  
+  SUBROUTINE leapfrog_switch_dissip(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE call_dissip_mod,ONLY : call_dissip_switch_dissip
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL call_dissip_switch_dissip(dist)
+    
+  END SUBROUTINE leapfrog_switch_dissip
+  
+END MODULE leapfrog_mod  
+
+
+
+
+
+
+
Index: LMDZ5/trunk/libf/limit_netcdf.F
===================================================================
--- LMDZ5/trunk/libf/limit_netcdf.F	(revision 1630)
+++ LMDZ5/trunk/libf/limit_netcdf.F	(revision 1630)
@@ -0,0 +1,1332 @@
+!
+! $Id: limit_netcdf.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+C
+C
+      SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque)
+#ifdef CPP_EARTH
+! This routine is designed to work for Earth
+      USE dimphy
+      USE control_mod
+      use phys_state_var_mod , ONLY : pctsrf
+      use inter_barxy_m, only: inter_barxy
+
+      IMPLICIT none
+c
+c-------------------------------------------------------------
+C Author : L. Fairhead
+C Date   : 27/01/94
+C Objet  : Construction des fichiers de conditions aux limites
+C          pour le nouveau
+C          modele a partir de fichiers de climatologie. Les deux
+C          grilles doivent etre regulieres
+c
+c Modifie par z.x.li (le23mars1994)
+c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
+c                         pour lecture netcdf dans LMDZ.3.3
+c Modifie par P;Le Van  ,  juillet 2001
+c-------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "comconst.h"
+cy#include "dimphy.h"
+#include "indicesol.h"
+#include "iniprint.h"
+c
+c-----------------------------------------------------------------------
+      LOGICAL interbar, extrap, oldice
+
+      REAL phy_nat(klon,360), phy_nat0(klon)
+      REAL phy_alb(klon,360)
+      REAL phy_sst(klon,360)
+      REAL phy_bil(klon,360)
+      REAL phy_rug(klon,360)
+      REAL phy_ice(klon)
+c
+      real pctsrf_t(klon,nbsrf,360)
+
+      REAL verif
+
+      REAL masque(iip1,jjp1)
+      REAL mask(iim,jjp1)
+CPB
+C newlmt indique l'utilisation de la sous-maille fractionnelle
+C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3)
+      LOGICAL newlmt, fracterre
+      PARAMETER(newlmt=.TRUE.)
+      PARAMETER(fracterre = .TRUE.) 
+
+C Declarations pour le champ de depart
+      INTEGER imdep, jmdep,lmdep
+      INTEGER  tbid
+      PARAMETER ( tbid = 60 )        ! >52 semaines
+      REAL  timecoord(tbid)
+c
+      REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:)
+      REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:)
+      REAL , ALLOCATABLE :: dlon(:), dlat(:)
+      REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:)
+      REAL , ALLOCATABLE :: champ_msk(:), champ(:, :)
+      REAL , ALLOCATABLE :: work(:,:)
+
+      CHARACTER*25 title
+
+C Declarations pour le champ interpole 2D
+      REAL champint(iim,jjp1)
+      real chmin,chmax
+
+C Declarations pour le champ interpole 3D
+      REAL champtime(iim,jjp1,tbid)
+      REAL timeyear(tbid)
+      REAL champan(iip1,jjp1,366)
+
+C Declarations pour l'inteprolation verticale
+      REAL ax(tbid), ay(tbid)
+      REAL by
+      REAL yder(tbid)
+
+
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+CPB
+      INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC
+
+      INTEGER i, j, k, l, ji
+c declarations pour lecture glace de mer
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+
+c Diverses variables locales
+      REAL time
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+
+      INTEGER          longcles
+      PARAMETER      ( longcles = 20 )
+      REAL  clesphy0 ( longcles      )
+#include "serre.h"
+      INTEGER ncid,varid,ndimid(4),dimid
+      character*30 namedim
+      CHARACTER*80 :: varname
+
+cIM28/02/2002 <== PM
+      REAL tmidmonth(12)
+      SAVE tmidmonth
+      DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/
+
+c initialisations:
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+
+      pi     = 4. * ATAN(1.)
+      rad    = 6 371 229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      dtvr    = daysec/ REAL(day_step)
+      CALL inigeom
+c
+C Traitement du relief au sol
+c
+      write(*,*) 'Traitement du relief au sol pour fabriquer masque'
+      ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
+
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ALLOCATE( lonmsk_ini(imdep) )
+      ALLOCATE(   dlon_msk(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini)
+#endif
+
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ALLOCATE( latmsk_ini(jmdep) )
+      ALLOCATE(   dlat_msk(jmdep) )
+      ALLOCATE(  champ_msk(imdep*jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini)
+#endif
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
+#endif
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      title='RELIEF'
+
+      CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini,
+     . dlon_msk, dlat_msk, champ_msk, interbar  )
+
+      DO i = 1, iim
+      DO j = 1, jjp1
+         mask(i,j) = masque(i,j)
+      ENDDO
+      ENDDO
+      WRITE(*,*) 'MASK:'
+      WRITE(*,'(96i1)')INT(mask)     
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de la rugosite
+c
+      PRINT*, 'Traitement de la rugosite'
+      ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlon_ini(imdep) )
+      ALLOCATE(     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlat_ini(jmdep) )
+      ALLOCATE(     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      ALLOCATE( champ(imdep, jmdep) )
+
+      DO  200 l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+         print*,dimfirst,dimlast
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF 
+   
+        title = 'Rugosite Amip '
+c
+        CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                      dlon, dlat, champ, interbar          )
+
+       IF ( interbar )   THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour la rugosite $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+        CALL inter_barxy(dlon, dlat(:jmdep -1), log(champ), rlonu(:iim),
+     $       rlatv, champint)
+         DO j=1,jjp1
+          DO i=1,iim
+           champint(i,j)=EXP(champint(i,j))
+          ENDDO
+         ENDDO
+
+         DO j = 1, jjp1
+           DO i = 1, iim
+             IF(NINT(mask(i,j)).NE.1)  THEN
+               champint( i,j ) = 0.001
+             ENDIF
+           ENDDO
+         ENDDO
+      ELSE
+         CALL rugosite(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint, mask)
+      ENDIF
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+200      CONTINUE
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+
+      PRINT 222, timeyear(:lmdep)
+222   FORMAT(2x,' Time year ',10f6.1)
+c
+        
+      PRINT*, 'Interpolation temporelle dans l annee'
+
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time =  REAL(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Rugosite au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+c
+c
+C Traitement de la glace oceanique
+c
+      PRINT*, 'Traitement de la glace oceanique'
+
+      ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) THEN
+        ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid)
+        if (ierr.ne.0) THEN
+          print *, NF_STRERROR(ierr)
+          STOP
+        endif
+      ENDIF
+
+cIM22/02/2002
+cIM07/03/2002 AMIP.nc & amip79to95.nc
+cIM   ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid)
+cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc
+      ierr = NF_INQ_VARID(ncid,'sicbcs',varid)
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr),'sicbcs'
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlon_ini(imdep) )
+      ALLOCATE (     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlat_ini(jmdep) )
+      ALLOCATE (     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, lmdep
+cIM28/02/2002
+cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
+c               Ici on suppose qu'on a 12 mois (de 30 jours).
+      IF (lmdep.NE.12) THEN
+          print *, 'Unknown AMIP file: not 12 months ?'
+          STOP
+       ENDIF
+cIM28/02/2002
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      ALLOCATE ( champ(imdep, jmdep) )
+
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+ 
+         title = 'Sea-ice Amip '
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                        dlon, dlat, champ, interbar          )
+c
+      IF( oldice )  THEN
+                 CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint )
+      ELSEIF ( interbar )  THEN
+       IF( l.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour Sea-ice Amip  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+       ENDIF
+cIM07/03/2002 
+cIM22/02/2002 : Sea-ice Amip entre 0. et 1.
+cIM    PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' 
+cIM   DO j = 1, imdep * jmdep
+cIM28/02/2002 <==PM         champ(j) = champ(j)/100.
+cIM14/03/2002      champ(j) = max(0.0,(min(1.0, (champ(j)/100.) )))
+cIM      champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) )))
+cIM   ENDDO
+cIM22/02/2002
+       CALL inter_barxy (dlon, dlat(:jmdep -1), champ, rlonu(:iim),
+     $      rlatv, champint)
+      ELSE
+         CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint )
+      ENDIF
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+cIM28/02/2002 <== PM  timeyear(l) = timecoord(l)
+cIM      timeyear(l) = timecoord(l)
+cIM07/03/2002      
+         timeyear(l) = tmidmonth(l)
+      ENDDO
+      PRINT 222,  timeyear(:lmdep)
+c
+      PRINT*, 'Interpolation temporelle'
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time =  REAL(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Sea ice au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+cIM14/03/2002 : Sea-ice Amip entre 0. et 1.
+      PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc '
+      DO k = 1, 360
+      DO j = 1, jjp1
+      DO i = 1, iim
+        champan(i, j, k) = 
+     $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.))))
+      ENDDO
+        champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+cIM14/03/2002
+
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_ice)
+        IF ( newlmt) THEN
+
+CPB  en attendant de mettre fraction de terre
+c
+          WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1.
+          WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0.
+c 
+          IF (fracterre ) THEN
+c            WRITE(*,*) 'passe dans cas fracterre' 
+            pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter)
+            pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic)
+            pctsrf_t(1:klon,is_sic,k) =   phy_ice(1:klon) 
+     $            - pctsrf_t(1:klon,is_lic,k)
+c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP
+            WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0)
+              pctsrf_t(1:klon,is_sic,k) = 0.
+            END WHERE 
+            WHERE( 1. - zmasq(1:klon) .LT. EPSFRA)
+              pctsrf_t(1:klon,is_sic,k) = 0.
+              pctsrf_t(1:klon,is_oce,k) = 0.
+            END WHERE
+            DO i = 1, klon
+              IF ( 1. - zmasq(i) .GT. EPSFRA) THEN 
+                IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN
+                  pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                  pctsrf_t(i,is_oce,k) = 0.
+                ELSE 
+                  pctsrf_t(i,is_oce,k) = 1 - zmasq(i) 
+     $                    - pctsrf_t(i,is_sic,k)
+                  IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN
+                    pctsrf_t(i,is_oce,k) = 0.
+                    pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                  ENDIF 
+                ENDIF
+              ENDIF  
+              if (pctsrf_t(i,is_oce,k) .lt. 0.) then
+                WRITE(*,*) 'pb sous maille au point : i,k '
+     $              , i,k,pctsrf_t(:,is_oce,k)
+              ENDIF
+              IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + 
+     $          pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k)  - 1.) 
+     $            .GT. EPSFRA) THEN 
+                  WRITE(*,*) 'physiq : pb sous surface au point ', i, 
+     $                pctsrf_t(i, 1 : nbsrf,k), phy_ice(i)
+              ENDIF 
+            END DO
+          ELSE 
+            DO i = 1, klon
+              pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter)
+              IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN
+                pctsrf_t(i,is_sic,k) = 0.
+                pctsrf_t(i,is_oce,k) = 0.                  
+                IF(phy_ice(i) .GE. 1.e-5) THEN
+                  pctsrf_t(i,is_lic,k) = phy_ice(i)
+                  pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) 
+     .                                   - pctsrf_t(i,is_lic,k)
+                ELSE
+                  pctsrf_t(i,is_lic,k) = 0.
+                ENDIF 
+              ELSE
+                pctsrf_t(i,is_lic,k) = 0. 
+                IF(phy_ice(i) .GE. 1.e-5) THEN 
+                  pctsrf_t(i,is_ter,k) = 0.
+                  pctsrf_t(i,is_sic,k) = phy_ice(i)
+                  pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k)
+                ELSE
+                  pctsrf_t(i,is_sic,k) = 0.
+                  pctsrf_t(i,is_oce,k) = 1.                      
+                ENDIF 
+              ENDIF
+              verif = pctsrf_t(i,is_ter,k) +
+     .                pctsrf_t(i,is_oce,k) + 
+     .                pctsrf_t(i,is_sic,k) +
+     .                pctsrf_t(i,is_lic,k)
+              IF ( verif .LT. 1. - 1.e-5 .OR. 
+     $             verif .GT. 1 + 1.e-5) THEN  
+                WRITE(*,*) 'pb sous maille au point : i,k,verif '
+     $                    , i,k,verif
+              ENDIF 
+            END DO
+          ENDIF 
+        ELSE  
+          DO i = 1, klon
+            phy_nat(i,k) = phy_nat0(i)
+            IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN
+              IF (NINT(phy_nat0(i)).EQ.0) THEN
+                phy_nat(i,k) = 3.0
+              ELSE
+                phy_nat(i,k) = 2.0
+              ENDIF
+            ENDIF
+            IF( NINT(phy_nat(i,k)).EQ.0 ) THEN
+              IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001
+            ENDIF
+          END DO
+        ENDIF
+      ENDDO
+c
+
+      ierr = NF_CLOSE(ncid)
+c
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+
+477    continue
+c
+C Traitement de la sst
+c
+      PRINT*, 'Traitement de la sst'
+c     ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid)
+      ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) THEN
+        ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid)
+        if (ierr.ne.0) THEN
+          print *, NF_STRERROR(ierr)
+          STOP
+        endif
+      ENDIF
+
+cIM22/02/2002
+cIM   ierr = NF_INQ_VARID(ncid,'SST',varid)
+      ierr = NF_INQ_VARID(ncid,'tosbcs',varid)
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable SST ', namedim,'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+ 
+      ALLOCATE( dlon_ini(imdep) )
+      ALLOCATE(     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable SST ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlat_ini(jmdep) )
+      ALLOCATE(     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+cIM28/02/2002
+cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
+c               Ici on suppose qu'on a 12 mois (de 30 jours).
+      IF (lmdep.NE.12) THEN
+          print *, 'Unknown AMIP file: not 12 months ?'
+          STOP
+       ENDIF
+cIM28/02/2002
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+       ALLOCATE( champ(imdep, jmdep) )
+       IF( extrap )   THEN
+         ALLOCATE ( work(imdep,jmdep) )
+       ENDIF
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         title='Sst Amip'
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                            dlon, dlat, champ, interbar     )
+       IF ( extrap )  THEN
+        CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work)
+       ENDIF
+c
+
+      IF ( interbar )  THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour la Sst Amip $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+        CALL inter_barxy (dlon, dlat(:jmdep -1), champ, rlonu(:iim),
+     $       rlatv, champint)
+      ELSE
+       CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .          iim, jjp1, rlonv, rlatu, champint   )
+      ENDIF
+
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+cIM28/02/2002 <==PM  timeyear(l) = timecoord(l)
+         timeyear(l) = tmidmonth(l)
+      ENDDO
+      print 222,  timeyear(:lmdep)
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time =  REAL(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' SST au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+cIM14/03/2002 : SST amipbc greater then 271.38
+      PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 '
+      DO k = 1, 360
+      DO j = 1, jjp1
+      DO i = 1, iim
+         champan(i, j, k) = amax1(champan(i, j, k), 271.38)
+      ENDDO
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+cIM14/03/2002
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon, 
+     .                  champan(1,1,k), phy_sst(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+c
+C Traitement de l'albedo
+c
+      PRINT*, 'Traitement de l albedo'
+      ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlon_ini(imdep) )
+      ALLOCATE (     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlat_ini(jmdep) )
+      ALLOCATE (     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      ALLOCATE ( champ(imdep, jmdep) )
+
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         title='Albedo Amip'
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                            dlon, dlat, champ, interbar      )
+c
+c
+      IF ( interbar )  THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour l Albedo Amip $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+
+       CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim),
+     $       rlatv, champint)
+      ELSE
+       CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .          iim, jjp1, rlonv, rlatu, champint   )
+      ENDIF
+c
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i, j, l) = champint(i, j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+      print 222,  timeyear(:lmdep)
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i, j, l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time =  REAL(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Albedo au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_alb(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+c
+      DO k = 1, 360
+      DO i = 1, klon
+         phy_bil(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      PRINT*, 'Ecriture du fichier limit'
+c
+      ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
+     .                       "Fichier conditions aux limites")
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+      ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+c
+      dims(1) = ndim
+      dims(2) = ntim
+c
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
+#else
+      ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
+     .                        "Jour dans l annee")
+      IF (newlmt) THEN
+c
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 2,dims, id_FOCE)
+#else
+        ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14,
+     .                      "Fraction ocean")
+c
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 2,dims, id_FSIC)
+#else
+        ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21,
+     .                      "Fraction glace de mer")
+c
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 2,dims, id_FTER)
+#else
+        ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14,
+     .                      "Fraction terre")
+c
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 2,dims, id_FLIC)
+#else
+        ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17,
+     .                      "Fraction land ice")
+c
+      ELSE 
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
+#else
+        ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
+     .                      "Nature du sol (0,1,2,3)")
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
+#else
+      ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
+     .                      "Temperature superficielle de la mer")
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
+#else
+      ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
+     .                        "Reference flux de chaleur au sol")
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
+#else
+      ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
+     .                        "Albedo a la surface")
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
+#else
+      ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
+     .                        "Rugosite")
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO k = 1, 360
+c
+      debut(1) = 1
+      debut(2) = k
+      epais(1) = klon
+      epais(2) = 1
+c
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+c
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+c
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,id_tim,k, REAL(k))
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+      ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
+#endif
+c
+      ENDDO
+c
+      ierr = NF_CLOSE(nid)
+c
+#else
+      WRITE(lunout,*)
+     & 'limit_netcdf: Earth-specific routine, needs Earth physics'
+#endif
+! of #ifdef CPP_EARTH
+      STOP
+      END
Index: LMDZ5/trunk/libf/limx.F
===================================================================
--- LMDZ5/trunk/libf/limx.F	(revision 1630)
+++ LMDZ5/trunk/libf/limx.F	(revision 1630)
@@ -0,0 +1,109 @@
+!
+! $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 "logic.h"
+#include "comvert.h"
+#include "comconst.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,CVMGP,CVMGT
+      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).gt.0.
+     &         .and. dxq(ij,l)*dxqu(ij).gt.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: LMDZ5/trunk/libf/limy.F
===================================================================
--- LMDZ5/trunk/libf/limy.F	(revision 1630)
+++ LMDZ5/trunk/libf/limy.F	(revision 1630)
@@ -0,0 +1,193 @@
+!
+! $Header$
+!
+      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   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real 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,apn,aps,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, ismin,ismax
+
+      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     apn=abs(dyq(1)/dyqv(iip1+1))
+c     print*,dyq(ip1jm+1)
+c     print*,dyqv(ip1jm-iip1+1)
+c     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+c     do ij=2,iim
+c        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+c        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+c     enddo
+c     apn=min(pente_max/apn,1.)
+c     aps=min(pente_max/aps,1.)
+
+
+c   cas ou on a un extremum au pole
+
+c     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+c    &   apn=0.
+c     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+c    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+c    &   aps=0.
+
+c   limitation des pentes aux poles
+c     do ij=1,iip1
+c        dyq(ij)=apn*dyq(ij)
+c        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+c     enddo
+
+c   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)).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
+
+c   calcul des pentes limitees
+
+      do ij=1,ip1jmp1
+         if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then
+            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: LMDZ5/trunk/libf/limz.F
===================================================================
--- LMDZ5/trunk/libf/limz.F	(revision 1630)
+++ LMDZ5/trunk/libf/limz.F	(revision 1630)
@@ -0,0 +1,99 @@
+!
+! $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 "logic.h"
+#include "comvert.h"
+#include "comconst.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,CVMGP,CVMGT
+      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).gt.0.
+     &         .and. dzq(ij,l)*dzqw(l).gt.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: LMDZ5/trunk/libf/logic.h
===================================================================
--- LMDZ5/trunk/libf/logic.h	(revision 1630)
+++ LMDZ5/trunk/libf/logic.h	(revision 1630)
@@ -0,0 +1,19 @@
+!
+! $Header$
+!
+!
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'logic.h'
+
+      COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys,            &
+     &  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus       &
+     &  ,read_start,ok_guide,ok_strato,ok_gradsfile
+
+      LOGICAL purmats,forward,leapf,apphys,statcl,conser,               &
+     & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus                      &
+     &  ,read_start,ok_guide,ok_strato,ok_gradsfile
+
+      INTEGER iflag_phys
+!$OMP THREADPRIVATE(/logic/)
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/massbar.F
===================================================================
--- LMDZ5/trunk/libf/massbar.F	(revision 1630)
+++ LMDZ5/trunk/libf/massbar.F	(revision 1630)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE massbar(  masse, massebx, masseby )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+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   100    l = 1 , llm
+c
+        DO  ij = 1, ip1jmp1 - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jmp1, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+         DO  ij = 1,ip1jm
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/massbar_loc.F
===================================================================
--- LMDZ5/trunk/libf/massbar_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/massbar_loc.F	(revision 1630)
@@ -0,0 +1,117 @@
+      SUBROUTINE massbar_loc(  masse, massebx, masseby )
+     
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ijb_u:ije_u,llm ), massebx( ijb_u:ije_u,llm )  ,
+     *      masseby(   ijb_v:ije_v,llm )
+      INTEGER ij,l,ijb,ije
+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=======================================================================
+      
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+      DO   100    l = 1 , llm
+c
+        ijb=ij_begin
+        ije=ij_end+iip1
+        if (pole_sud) ije=ije-iip1
+        
+        DO  ij = ijb, ije - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+
+        
+
+        DO  ij = ijb+iim, ije+iim, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+      
+        ijb=ij_begin-iip1
+        ije=ij_end+iip1
+        if (pole_nord) ijb=ij_begin
+        if (pole_sud) ije=ij_end-iip1
+
+         DO  ij = ijb,ije
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/massbarxy.F
===================================================================
--- LMDZ5/trunk/libf/massbarxy.F	(revision 1630)
+++ LMDZ5/trunk/libf/massbarxy.F	(revision 1630)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE massbarxy(  masse, massebxy )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = 1, ip1jm - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/massbarxy_loc.F
===================================================================
--- LMDZ5/trunk/libf/massbarxy_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/massbarxy_loc.F	(revision 1630)
@@ -0,0 +1,55 @@
+      SUBROUTINE massbarxy_loc(  masse, massebxy )
+      USE parallel
+      implicit none
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ijb_u:ije_u,llm ), massebxy( ijb_v:ije_v,llm )
+c
+      INTEGER ij,l,ijb,ije
+
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = ijb, ije - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = ijb+iip1-1, ije+iip1-1, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/massdair.F
===================================================================
--- LMDZ5/trunk/libf/massdair.F	(revision 1630)
+++ LMDZ5/trunk/libf/massdair.F	(revision 1630)
@@ -0,0 +1,109 @@
+!
+! $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 "comconst.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   100    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
+       
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/massdair_loc.F
===================================================================
--- LMDZ5/trunk/libf/massdair_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/massdair_loc.F	(revision 1630)
@@ -0,0 +1,120 @@
+      SUBROUTINE massdair_loc( p, masse )
+      USE parallel
+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 "comconst.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   100    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
+       
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/minmax.F
===================================================================
--- LMDZ5/trunk/libf/minmax.F	(revision 1630)
+++ LMDZ5/trunk/libf/minmax.F	(revision 1630)
@@ -0,0 +1,23 @@
+!
+! $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: LMDZ5/trunk/libf/minmax2.F
===================================================================
--- LMDZ5/trunk/libf/minmax2.F	(revision 1630)
+++ LMDZ5/trunk/libf/minmax2.F	(revision 1630)
@@ -0,0 +1,20 @@
+!
+! $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: LMDZ5/trunk/libf/mod_const_para.F90
===================================================================
--- LMDZ5/trunk/libf/mod_const_para.F90	(revision 1630)
+++ LMDZ5/trunk/libf/mod_const_para.F90	(revision 1630)
@@ -0,0 +1,77 @@
+! 
+! $Id: mod_const_para.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE mod_const_mpi
+
+  INTEGER,SAVE :: COMM_LMDZ
+  INTEGER,SAVE :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+#ifdef CPP_IOIPSL
+    USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+    USE ioipsl_getincom
+#endif
+
+    IMPLICIT NONE
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER             :: ierr
+    INTEGER             :: comp_id
+    INTEGER             :: thread_required
+    INTEGER             :: thread_provided
+    CHARACTER(len = 6)  :: type_ocean
+
+!$OMP MASTER
+    type_ocean = 'force '
+    CALL getin('type_ocean', type_ocean)
+!$OMP END MASTER
+!$OMP BARRIER
+
+    IF (type_ocean=='couple') THEN
+#ifdef CPP_COUPLE
+!$OMP MASTER
+       CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr)
+       CALL prism_get_localcomm_proto(COMM_LMDZ,ierr)
+!$OMP END MASTER
+#endif
+#ifdef CPP_MPI
+      MPI_REAL_LMDZ=MPI_REAL8
+#endif
+    ELSE
+      CALL init_mpi
+    ENDIF
+
+  END SUBROUTINE Init_const_mpi
+  
+  SUBROUTINE Init_mpi
+  IMPLICIT NONE
+#ifdef CPP_MPI
+     INCLUDE 'mpif.h'
+#endif
+    INTEGER             :: ierr
+    INTEGER             :: thread_required
+    INTEGER             :: thread_provided
+
+#ifdef CPP_MPI
+!$OMP MASTER
+      thread_required=MPI_THREAD_SERIALIZED
+
+      CALL MPI_INIT_THREAD(thread_required,thread_provided,ierr)
+      IF (thread_provided < thread_required) THEN
+        PRINT *,'Warning : The multithreaded level of MPI librairy do not provide the requiered level',  &
+                ' in mod_const_mpi::Init_const_mpi'
+      ENDIF
+      COMM_LMDZ=MPI_COMM_WORLD
+      MPI_REAL_LMDZ=MPI_REAL8
+!$OMP END MASTER
+#endif
+
+   END SUBROUTINE Init_mpi
+    
+END MODULE mod_const_mpi
Index: LMDZ5/trunk/libf/mod_filtreg_p.F
===================================================================
--- LMDZ5/trunk/libf/mod_filtreg_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/mod_filtreg_p.F	(revision 1630)
@@ -0,0 +1,403 @@
+      MODULE mod_filtreg_p
+      
+      CONTAINS
+      
+      SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, 
+     &     ifiltre, iaire, griscal ,iter)
+      USE Parallel, only : OMP_CHUNK
+      USE mod_filtre_fft_loc
+      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 jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
+      INTEGER i,j,l,k
+      INTEGER iim2,immjm
+      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+      
+      REAL  champ( iip1,jjb:jje,nbniv)
+      
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+      
+      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
+
+      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.EQ.1.or.ifiltre.EQ.-1) 
+     &     STOP'Pas de transformee simple dans cette version'
+      
+      IF( iter.EQ. 2 )  THEN
+         PRINT *,' Pas d iteration du filtre dans cette version !'
+     &        , ' Utiliser old_filtreg et repasser !'
+         STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+         PRINT *,' Cette routine ne calcule le filtre inverse que '
+     &        , ' sur la grille des scalaires !'
+         STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     &        , ' corriger et repasser !'
+         STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+            PRINT  1111
+            STOP
+         ELSE
+c     
+            IF( iaire.EQ.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.NE.jjm )  THEN
+            PRINT  2222
+            STOP
+         ELSE
+c
+            IF( iaire.EQ.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.EQ.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.EQ.1 )      THEN
+               
+               IF( ifiltre.EQ.-2 )   THEN
+                  DO j = jdfil,jffil
+                     CALL DGEMM("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))
+                  ENDDO
+                  
+               ELSE IF ( griscal )     THEN
+                  DO j = jdfil,jffil
+                     CALL DGEMM("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))
+                  ENDDO
+                  
+               ELSE 
+                  DO j = jdfil,jffil
+                     CALL DGEMM("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))
+                  ENDDO
+                  
+               ENDIF
+               
+            ELSE
+               
+               IF( ifiltre.EQ.-2 )   THEN
+                  DO j = jdfil,jffil
+                     CALL DGEMM("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))
+                  ENDDO
+                  
+               ELSE IF ( griscal )     THEN
+                  
+                  DO j = jdfil,jffil
+                     CALL DGEMM("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))
+                  ENDDO
+                  
+               ELSE 
+                  
+                  DO j = jdfil,jffil
+                     CALL DGEMM("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))
+                  ENDDO
+                  
+               ENDIF
+               
+            ENDIF
+!     c     
+            IF( ifiltre.EQ.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_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,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,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. EQ. -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.EQ. 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 SUBROUTINE filtreg_p
+      END MODULE mod_filtreg_p
Index: LMDZ5/trunk/libf/mod_hallo.F90
===================================================================
--- LMDZ5/trunk/libf/mod_hallo.F90	(revision 1630)
+++ LMDZ5/trunk/libf/mod_hallo.F90	(revision 1630)
@@ -0,0 +1,1612 @@
+module mod_Hallo
+USE parallel
+implicit none
+  logical,save :: use_mpi_alloc
+  integer, parameter :: MaxRequest=200
+  integer, parameter :: MaxProc=512
+  integer, parameter :: MaxBufferSize=1024*1024*100
+  integer, parameter :: ListSize=1000
+  
+  integer,save       :: MaxBufferSize_Used
+!$OMP THREADPRIVATE( MaxBufferSize_Used)
+
+   real,save,pointer,dimension(:) :: Buffer
+!$OMP THREADPRIVATE(Buffer)
+
+   integer,save,dimension(Listsize) :: Buffer_Pos
+   integer,save :: Index_Pos
+!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
+   
+  type Hallo
+    real, dimension(:,:),pointer :: Field
+    integer :: offset
+    integer :: size
+    integer :: NbLevel
+    integer :: Stride
+  end type Hallo
+  
+  type request_SR
+    integer :: NbRequest=0
+    integer :: BufferSize
+    integer :: Pos
+    integer :: Index 
+    type(Hallo),dimension(MaxRequest) :: Hallo
+    integer :: MSG_Request
+  end type request_SR
+
+  type request
+    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
+    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
+    integer :: tag=1
+  end type request
+  
+   TYPE(distrib),SAVE :: distrib_gather
+
+
+  INTERFACE Register_SwapField_u
+    MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u
+  END INTERFACE Register_SwapField_u
+
+  INTERFACE Register_SwapField_v
+    MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v
+  END INTERFACE Register_SwapField_v
+
+  INTERFACE Register_SwapField2d_u
+    MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d
+  END INTERFACE Register_SwapField2d_u
+
+  INTERFACE Register_SwapField2d_v
+    MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d
+  END INTERFACE Register_SwapField2d_v
+
+  contains
+
+  subroutine Init_mod_hallo
+  USE dimensions
+    implicit none
+    integer :: jj_nb_gather(0:mpi_size-1)
+    
+    Index_Pos=1
+    Buffer_Pos(Index_Pos)=1
+    MaxBufferSize_Used=0
+
+    IF (use_mpi_alloc .AND. using_mpi) THEN
+      CALL create_global_mpi_buffer
+    ELSE 
+      CALL create_standard_mpi_buffer
+    ENDIF
+     
+     jj_nb_gather(:)=0
+     jj_nb_gather(0)=jjp1
+     
+     CALL create_distrib(jj_nb_gather,distrib_gather) 
+
+  end subroutine init_mod_hallo
+
+  SUBROUTINE create_standard_mpi_buffer
+  IMPLICIT NONE
+    
+    ALLOCATE(Buffer(MaxBufferSize))
+    
+  END SUBROUTINE create_standard_mpi_buffer
+  
+  SUBROUTINE create_global_mpi_buffer
+  IMPLICIT NONE
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif  
+    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
+    REAL :: MPI_Buffer
+#ifdef CPP_MPI
+    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
+#else
+    INTEGER(KIND=8) :: BS
+#endif
+    INTEGER :: i,ierr
+
+!  Allocation du buffer MPI
+      Bs=8*MaxBufferSize
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      DO i=1,MaxBufferSize
+	MPI_Buffer(i)=i
+      ENDDO
+     
+      CALL  Associate_buffer(MPI_Buffer)
+      
+  CONTAINS
+     
+     SUBROUTINE Associate_buffer(MPI_Buffer)
+     IMPLICIT NONE
+       REAL,DIMENSION(:),target :: MPI_Buffer  
+
+         Buffer=>MPI_Buffer
+ 
+      END SUBROUTINE  Associate_buffer
+                                      
+  END SUBROUTINE create_global_mpi_buffer
+ 
+      
+  subroutine allocate_buffer(Size,Index,Pos)
+  implicit none
+    integer :: Size
+    integer :: Index
+    integer :: Pos
+
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
+      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+    
+    if (Index_pos>=ListSize) then
+      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+     
+    Pos=Buffer_Pos(Index_Pos)
+    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
+    Index_Pos=Index_Pos+1
+    Index=Index_Pos
+    
+  end subroutine allocate_buffer
+     
+  subroutine deallocate_buffer(Index)
+  implicit none
+    integer :: Index
+    
+    Buffer_Pos(Index)=-1
+    
+    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
+      Index_Pos=Index_Pos-1
+    end do
+
+  end subroutine deallocate_buffer  
+  
+  subroutine SetTag(a_request,tag)
+  implicit none
+    type(request):: a_request
+    integer :: tag
+    
+    a_request%tag=tag
+  end subroutine SetTag
+  
+  
+  subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
+    integer :: Stride
+    integer :: NbLevel
+    integer :: size
+    integer :: offset
+    real, dimension(Stride,NbLevel),target :: Field
+    type(Hallo) :: NewHallo
+    
+    NewHallo%Field=>Field
+    NewHallo%Stride=Stride
+    NewHallo%NbLevel=NbLevel
+    NewHallo%size=size
+    NewHallo%offset=offset
+    
+    
+  end subroutine Init_Hallo
+  
+  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions
+  implicit none
+
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestSend(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif      
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+      
+   end subroutine Register_SendField      
+      
+  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions
+  implicit none
+
+   
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestRecv(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif   
+            
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+
+      
+   end subroutine Register_RecvField      
+  
+  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
+  USE dimensions
+      implicit none
+
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapField    
+  
+
+  
+  subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
+  USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
+      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
+    enddo
+   
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapFieldHallo
+
+
+
+  SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_u 
+
+
+  SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+    IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_u1d
+   
+
+  SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_u 
+  
+
+
+ SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),OPTIONAL,INTENT(IN)          :: new_dist !LF
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_u2d 
+
+
+  SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_u2d
+   
+
+  SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_u2d 
+
+
+
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_v 
+
+
+  SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+   
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_v1d
+   
+
+  SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_v 
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),OPTIONAL,INTENT(IN)          :: new_dist !LF
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_v2d
+
+
+  SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_v2d
+   
+
+  SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_v2d 
+  
+  
+
+  SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+   
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,:)=FieldS(ijb:ije,:)              
+        ENDDO
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_u
+
+
+
+  SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel
+  USE dimensions
+    IMPLICIT NONE
+    
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+
+        IF (jje==jjp1) jje=jjm        
+
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+
+        IF (jje==jjp1) jje=jjm
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        IF (jje==jjp1) jje=jjm
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+        ENDDO              
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_v
+
+
+ 
+
+  
+  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo
+
+
+  subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ll
+      REAL, dimension(ijb_u:ije_u,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_u
+
+  subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ll
+      REAL, dimension(ijb_v:ije_v,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_v
+    
+    subroutine SendRequest(a_Request)
+    USE dimensions
+      implicit none
+
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer :: SizeBuffer
+      integer :: i,rank,l,ij,Pos,ierr
+      integer :: offset
+      real,dimension(:,:),pointer :: Field
+      integer :: Nb
+       
+      do rank=0,MPI_SIZE-1
+      
+        Req=>a_Request%RequestSend(rank)
+        
+        SizeBuffer=0
+        do i=1,Req%NbRequest
+          PtrHallo=>Req%Hallo(i)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+          DO l=1,PtrHallo%NbLevel
+            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+          ENDDO
+!$OMP ENDDO NOWAIT          
+        enddo
+      
+         Req%BufferSize=SizeBuffer
+         if (Req%NbRequest>0) then
+       
+          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
+
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+            Nb=iip1*PtrHallo%size-1
+            Field=>PtrHallo%Field
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+            do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        Buffer(Pos+ij)=Field(Offset+ij,l)
+	      enddo
+              
+              Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT            
+          enddo
+    
+         if (SizeBuffer>0) then
+!$OMP CRITICAL (MPI)
+         
+#ifdef CPP_MPI
+         call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                         COMM_LMDZ,Req%MSG_Request,ierr)
+#endif
+         IF (.NOT.using_mpi) THEN
+           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+           STOP
+         ENDIF
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+        endif
+       endif
+    enddo
+   
+           
+      do rank=0,MPI_SIZE-1
+         
+          Req=>a_Request%RequestRecv(rank)
+          SizeBuffer=0
+          
+	  do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+            DO l=1,PtrHallo%NbLevel
+              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+            ENDDO
+!$OMP ENDDO NOWAIT          
+          enddo
+          
+          Req%BufferSize=SizeBuffer
+          
+          if (Req%NbRequest>0) then
+          call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
+   
+          if (SizeBuffer>0) then
+
+!$OMP CRITICAL (MPI)
+
+#ifdef CPP_MPI
+             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                           COMM_LMDZ,Req%MSG_Request,ierr)
+#endif             
+             IF (.NOT.using_mpi) THEN
+               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+               STOP
+             ENDIF
+
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+          endif
+        endif
+      
+      enddo
+                        
+   end subroutine SendRequest 
+   
+   subroutine WaitRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(2*mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
+#else
+      integer, dimension(1,2*mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      integer :: Nb
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+      endif
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+
+              Pos=Pos+Nb+1
+	    enddo
+!$OMP ENDDO NOWAIT	    
+          enddo
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRequest
+     
+   subroutine WaitSendRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+
+      if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN 
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+      endif      
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      a_request%tag=1
+    end subroutine WaitSendRequest
+    
+   subroutine WaitRecvRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset,Nb
+      
+      
+      NbRequest=0
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)     
+      endif
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+                 Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT
+          enddo
+        endif
+      enddo
+      
+           
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRecvRequest
+    
+    
+    
+    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
+    USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,l
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb,ijb,ije
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
+    jje=min(jj_end,jj_end_new(MPI_Rank))
+    if (ij==ip1jm) jje=min(jje,jjm)
+
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+    endif
+
+
+  end subroutine CopyField    
+
+  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
+  USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+
+    integer ::i,jje,jjb,ijb,ije,l
+
+     
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+
+        
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
+    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
+    if (ij==ip1jm) jje=min(jje,jjm)
+    
+    
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+
+    endif
+   end subroutine CopyFieldHallo        
+
+   subroutine Gather_field_u(field_loc,field_glo,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_u:ije_u,ll)
+     real :: field_glo(ip1jmp1,ll)
+     type(request) :: request_gather
+     integer       :: l
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_u
+        
+   subroutine Gather_field_v(field_loc,field_glo,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_v:ije_v,ll)
+     real :: field_glo(ip1jm,ll)
+     type(request) :: request_gather
+     integer :: ijb,ije
+     integer       :: l
+     
+   
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+        
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_v
+     
+   subroutine Scatter_field_u(field_glo,field_loc,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_u:ije_u,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: l
+     
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+ 
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER     
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
+       ENDDO
+
+    end subroutine Scatter_field_u
+
+   subroutine Scatter_field_v(field_glo,field_loc,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_v:ije_v,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: ijb,ije,l
+     
+
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+     
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
+       ENDDO
+
+    end subroutine Scatter_field_v
+              
+end module mod_Hallo 
+   
Index: LMDZ5/trunk/libf/mod_hallo.F90_modified
===================================================================
--- LMDZ5/trunk/libf/mod_hallo.F90_modified	(revision 1630)
+++ LMDZ5/trunk/libf/mod_hallo.F90_modified	(revision 1630)
@@ -0,0 +1,1612 @@
+module mod_Hallo
+USE parallel
+implicit none
+  logical,save :: use_mpi_alloc
+  integer, parameter :: MaxRequest=200
+  integer, parameter :: MaxProc=512
+  integer, parameter :: MaxBufferSize=1024*1024*100
+  integer, parameter :: ListSize=1000
+  
+  integer,save       :: MaxBufferSize_Used
+!$OMP THREADPRIVATE( MaxBufferSize_Used)
+
+   real,save,pointer,dimension(:) :: Buffer
+!$OMP THREADPRIVATE(Buffer)
+
+   integer,save,dimension(Listsize) :: Buffer_Pos
+   integer,save :: Index_Pos
+!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
+   
+  type Hallo
+    real, dimension(:,:),pointer :: Field
+    integer :: offset
+    integer :: size
+    integer :: NbLevel
+    integer :: Stride
+  end type Hallo
+  
+  type request_SR
+    integer :: NbRequest=0
+    integer :: BufferSize
+    integer :: Pos
+    integer :: Index 
+    type(Hallo),dimension(MaxRequest) :: Hallo
+    integer :: MSG_Request
+  end type request_SR
+
+  type request
+    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
+    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
+    integer :: tag=1
+  end type request
+  
+   TYPE(distrib),SAVE :: distrib_gather
+
+
+  INTERFACE Register_SwapField_u
+    MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u
+  END INTERFACE Register_SwapField_u
+
+  INTERFACE Register_SwapField_v
+    MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v
+  END INTERFACE Register_SwapField_v
+
+  INTERFACE Register_SwapField2d_u
+    MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d
+  END INTERFACE Register_SwapField2d_u
+
+  INTERFACE Register_SwapField2d_v
+    MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d
+  END INTERFACE Register_SwapField2d_v
+
+  contains
+
+  subroutine Init_mod_hallo
+  USE dimensions
+    implicit none
+    integer :: jj_nb_gather(0:mpi_size-1)
+    
+    Index_Pos=1
+    Buffer_Pos(Index_Pos)=1
+    MaxBufferSize_Used=0
+
+    IF (use_mpi_alloc .AND. using_mpi) THEN
+      CALL create_global_mpi_buffer
+    ELSE 
+      CALL create_standard_mpi_buffer
+    ENDIF
+     
+     jj_nb_gather(:)=0
+     jj_nb_gather(0)=jjp1
+     
+     CALL create_distrib(jj_nb_gather,distrib_gather) 
+
+  end subroutine init_mod_hallo
+
+  SUBROUTINE create_standard_mpi_buffer
+  IMPLICIT NONE
+    
+    ALLOCATE(Buffer(MaxBufferSize))
+    
+  END SUBROUTINE create_standard_mpi_buffer
+  
+  SUBROUTINE create_global_mpi_buffer
+  IMPLICIT NONE
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif  
+    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
+    REAL :: MPI_Buffer
+#ifdef CPP_MPI
+    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
+#else
+    INTEGER(KIND=8) :: BS
+#endif
+    INTEGER :: i,ierr
+
+!  Allocation du buffer MPI
+      Bs=8*MaxBufferSize
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      DO i=1,MaxBufferSize
+	MPI_Buffer(i)=i
+      ENDDO
+     
+      CALL  Associate_buffer(MPI_Buffer)
+      
+  CONTAINS
+     
+     SUBROUTINE Associate_buffer(MPI_Buffer)
+     IMPLICIT NONE
+       REAL,DIMENSION(:),target :: MPI_Buffer  
+
+         Buffer=>MPI_Buffer
+ 
+      END SUBROUTINE  Associate_buffer
+                                      
+  END SUBROUTINE create_global_mpi_buffer
+ 
+      
+  subroutine allocate_buffer(Size,Index,Pos)
+  implicit none
+    integer :: Size
+    integer :: Index
+    integer :: Pos
+
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
+      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+    
+    if (Index_pos>=ListSize) then
+      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+     
+    Pos=Buffer_Pos(Index_Pos)
+    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
+    Index_Pos=Index_Pos+1
+    Index=Index_Pos
+    
+  end subroutine allocate_buffer
+     
+  subroutine deallocate_buffer(Index)
+  implicit none
+    integer :: Index
+    
+    Buffer_Pos(Index)=-1
+    
+    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
+      Index_Pos=Index_Pos-1
+    end do
+
+  end subroutine deallocate_buffer  
+  
+  subroutine SetTag(a_request,tag)
+  implicit none
+    type(request):: a_request
+    integer :: tag
+    
+    a_request%tag=tag
+  end subroutine SetTag
+  
+  
+  subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
+    integer :: Stride
+    integer :: NbLevel
+    integer :: size
+    integer :: offset
+    real, dimension(Stride,NbLevel),target :: Field
+    type(Hallo) :: NewHallo
+    
+    NewHallo%Field=>Field
+    NewHallo%Stride=Stride
+    NewHallo%NbLevel=NbLevel
+    NewHallo%size=size
+    NewHallo%offset=offset
+    
+    
+  end subroutine Init_Hallo
+  
+  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions
+  implicit none
+
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestSend(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif      
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+      
+   end subroutine Register_SendField      
+      
+  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions
+  implicit none
+
+   
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestRecv(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif   
+            
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+
+      
+   end subroutine Register_RecvField      
+  
+  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
+  USE dimensions
+      implicit none
+
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapField    
+  
+
+  
+  subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
+  USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
+      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
+    enddo
+   
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapFieldHallo
+
+
+
+  SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_u 
+
+
+  SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+    IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_u1d
+   
+
+  SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_u 
+  
+
+
+ SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),OPTIONAL,INTENT(IN)          :: new_dist !LF
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_u2d 
+
+
+  SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_u2d
+   
+
+  SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_u2d 
+
+
+
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_v 
+
+
+  SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+   
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_v1d
+   
+
+  SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_v 
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),OPTIONAL,INTENT(IN)          :: new_dist !LF
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_v2d
+
+
+  SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_v2d
+   
+
+  SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_v2d 
+  
+  
+
+  SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+   
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,:)=FieldS(ijb:ije,:)              
+        ENDDO
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_u
+
+
+
+  SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel
+  USE dimensions
+    IMPLICIT NONE
+    
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+
+        IF (jje==jjp1) jje=jjm        
+
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+
+        IF (jje==jjp1) jje=jjm
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        IF (jje==jjp1) jje=jjm
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+        ENDDO              
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_v
+
+
+ 
+
+  
+  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo
+
+
+  subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ll
+      REAL, dimension(ijb_u:ije_u,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_u
+
+  subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ll
+      REAL, dimension(ijb_v:ije_v,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_v
+    
+    subroutine SendRequest(a_Request)
+    USE dimensions
+      implicit none
+
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer :: SizeBuffer
+      integer :: i,rank,l,ij,Pos,ierr
+      integer :: offset
+      real,dimension(:,:),pointer :: Field
+      integer :: Nb
+       
+      do rank=0,MPI_SIZE-1
+      
+        Req=>a_Request%RequestSend(rank)
+        
+        SizeBuffer=0
+        do i=1,Req%NbRequest
+          PtrHallo=>Req%Hallo(i)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+          DO l=1,PtrHallo%NbLevel
+            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+          ENDDO
+!$OMP ENDDO NOWAIT          
+        enddo
+      
+         Req%BufferSize=SizeBuffer
+         if (Req%NbRequest>0) then
+       
+          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
+
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+            Nb=iip1*PtrHallo%size-1
+            Field=>PtrHallo%Field
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+            do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        Buffer(Pos+ij)=Field(Offset+ij,l)
+	      enddo
+              
+              Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT            
+          enddo
+    
+         if (SizeBuffer>0) then
+!$OMP CRITICAL (MPI)
+         
+#ifdef CPP_MPI
+         call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                         COMM_LMDZ,Req%MSG_Request,ierr)
+#endif
+         IF (.NOT.using_mpi) THEN
+           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+           STOP
+         ENDIF
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+        endif
+       endif
+    enddo
+   
+           
+      do rank=0,MPI_SIZE-1
+         
+          Req=>a_Request%RequestRecv(rank)
+          SizeBuffer=0
+          
+	  do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+            DO l=1,PtrHallo%NbLevel
+              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+            ENDDO
+!$OMP ENDDO NOWAIT          
+          enddo
+          
+          Req%BufferSize=SizeBuffer
+          
+          if (Req%NbRequest>0) then
+          call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
+   
+          if (SizeBuffer>0) then
+
+!$OMP CRITICAL (MPI)
+
+#ifdef CPP_MPI
+             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                           COMM_LMDZ,Req%MSG_Request,ierr)
+#endif             
+             IF (.NOT.using_mpi) THEN
+               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+               STOP
+             ENDIF
+
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+          endif
+        endif
+      
+      enddo
+                        
+   end subroutine SendRequest 
+   
+   subroutine WaitRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(2*mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
+#else
+      integer, dimension(1,2*mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      integer :: Nb
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+      endif
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+
+              Pos=Pos+Nb+1
+	    enddo
+!$OMP ENDDO NOWAIT	    
+          enddo
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRequest
+     
+   subroutine WaitSendRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+
+      if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN 
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+      endif      
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      a_request%tag=1
+    end subroutine WaitSendRequest
+    
+   subroutine WaitRecvRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset,Nb
+      
+      
+      NbRequest=0
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)     
+      endif
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+                 Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT
+          enddo
+        endif
+      enddo
+      
+           
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRecvRequest
+    
+    
+    
+    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
+    USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,l
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb,ijb,ije
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
+    jje=min(jj_end,jj_end_new(MPI_Rank))
+    if (ij==ip1jm) jje=min(jje,jjm)
+
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+    endif
+
+
+  end subroutine CopyField    
+
+  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
+  USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+
+    integer ::i,jje,jjb,ijb,ije,l
+
+     
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+
+        
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
+    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
+    if (ij==ip1jm) jje=min(jje,jjm)
+    
+    
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+
+    endif
+   end subroutine CopyFieldHallo        
+
+   subroutine Gather_field_u(field_loc,field_glo,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_u:ije_u,ll)
+     real :: field_glo(ip1jmp1,ll)
+     type(request) :: request_gather
+     integer       :: l
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_u
+        
+   subroutine Gather_field_v(field_loc,field_glo,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_v:ije_v,ll)
+     real :: field_glo(ip1jm,ll)
+     type(request) :: request_gather
+     integer :: ijb,ije
+     integer       :: l
+     
+   
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+        
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_v
+     
+   subroutine Scatter_field_u(field_glo,field_loc,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_u:ije_u,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: l
+     
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+ 
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER     
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
+       ENDDO
+
+    end subroutine Scatter_field_u
+
+   subroutine Scatter_field_v(field_glo,field_loc,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_v:ije_v,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: ijb,ije,l
+     
+
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+     
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
+       ENDDO
+
+    end subroutine Scatter_field_v
+              
+end module mod_Hallo 
+   
Index: LMDZ5/trunk/libf/mod_hallo.F90_orig
===================================================================
--- LMDZ5/trunk/libf/mod_hallo.F90_orig	(revision 1630)
+++ LMDZ5/trunk/libf/mod_hallo.F90_orig	(revision 1630)
@@ -0,0 +1,1612 @@
+module mod_Hallo
+USE parallel
+implicit none
+  logical,save :: use_mpi_alloc
+  integer, parameter :: MaxRequest=200
+  integer, parameter :: MaxProc=512
+  integer, parameter :: MaxBufferSize=1024*1024*100
+  integer, parameter :: ListSize=1000
+  
+  integer,save       :: MaxBufferSize_Used
+!$OMP THREADPRIVATE( MaxBufferSize_Used)
+
+   real,save,pointer,dimension(:) :: Buffer
+!$OMP THREADPRIVATE(Buffer)
+
+   integer,save,dimension(Listsize) :: Buffer_Pos
+   integer,save :: Index_Pos
+!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
+   
+  type Hallo
+    real, dimension(:,:),pointer :: Field
+    integer :: offset
+    integer :: size
+    integer :: NbLevel
+    integer :: Stride
+  end type Hallo
+  
+  type request_SR
+    integer :: NbRequest=0
+    integer :: BufferSize
+    integer :: Pos
+    integer :: Index 
+    type(Hallo),dimension(MaxRequest) :: Hallo
+    integer :: MSG_Request
+  end type request_SR
+
+  type request
+    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
+    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
+    integer :: tag=1
+  end type request
+  
+   TYPE(distrib),SAVE :: distrib_gather
+
+
+  INTERFACE Register_SwapField_u
+    MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u,Register_SwapField3d_u
+  END INTERFACE Register_SwapField_u
+
+  INTERFACE Register_SwapField_v
+    MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v,Register_SwapField3d_v
+  END INTERFACE Register_SwapField_v
+
+  INTERFACE Register_SwapField2d_u
+    MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d
+  END INTERFACE Register_SwapField2d_u
+
+  INTERFACE Register_SwapField2d_v
+    MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d
+  END INTERFACE Register_SwapField2d_v
+
+  contains
+
+  subroutine Init_mod_hallo
+  USE dimensions
+    implicit none
+    integer :: jj_nb_gather(0:mpi_size-1)
+    
+    Index_Pos=1
+    Buffer_Pos(Index_Pos)=1
+    MaxBufferSize_Used=0
+
+    IF (use_mpi_alloc .AND. using_mpi) THEN
+      CALL create_global_mpi_buffer
+    ELSE 
+      CALL create_standard_mpi_buffer
+    ENDIF
+     
+     jj_nb_gather(:)=0
+     jj_nb_gather(0)=jjp1
+     
+     CALL create_distrib(jj_nb_gather,distrib_gather) 
+
+  end subroutine init_mod_hallo
+
+  SUBROUTINE create_standard_mpi_buffer
+  IMPLICIT NONE
+    
+    ALLOCATE(Buffer(MaxBufferSize))
+    
+  END SUBROUTINE create_standard_mpi_buffer
+  
+  SUBROUTINE create_global_mpi_buffer
+  IMPLICIT NONE
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif  
+    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
+    REAL :: MPI_Buffer
+#ifdef CPP_MPI
+    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
+#else
+    INTEGER(KIND=8) :: BS
+#endif
+    INTEGER :: i,ierr
+
+!  Allocation du buffer MPI
+      Bs=8*MaxBufferSize
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      DO i=1,MaxBufferSize
+	MPI_Buffer(i)=i
+      ENDDO
+     
+      CALL  Associate_buffer(MPI_Buffer)
+      
+  CONTAINS
+     
+     SUBROUTINE Associate_buffer(MPI_Buffer)
+     IMPLICIT NONE
+       REAL,DIMENSION(:),target :: MPI_Buffer  
+
+         Buffer=>MPI_Buffer
+ 
+      END SUBROUTINE  Associate_buffer
+                                      
+  END SUBROUTINE create_global_mpi_buffer
+ 
+      
+  subroutine allocate_buffer(Size,Index,Pos)
+  implicit none
+    integer :: Size
+    integer :: Index
+    integer :: Pos
+
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
+      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+    
+    if (Index_pos>=ListSize) then
+      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+     
+    Pos=Buffer_Pos(Index_Pos)
+    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
+    Index_Pos=Index_Pos+1
+    Index=Index_Pos
+    
+  end subroutine allocate_buffer
+     
+  subroutine deallocate_buffer(Index)
+  implicit none
+    integer :: Index
+    
+    Buffer_Pos(Index)=-1
+    
+    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
+      Index_Pos=Index_Pos-1
+    end do
+
+  end subroutine deallocate_buffer  
+  
+  subroutine SetTag(a_request,tag)
+  implicit none
+    type(request):: a_request
+    integer :: tag
+    
+    a_request%tag=tag
+  end subroutine SetTag
+  
+  
+  subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
+    integer :: Stride
+    integer :: NbLevel
+    integer :: size
+    integer :: offset
+    real, dimension(Stride,NbLevel),target :: Field
+    type(Hallo) :: NewHallo
+    
+    NewHallo%Field=>Field
+    NewHallo%Stride=Stride
+    NewHallo%NbLevel=NbLevel
+    NewHallo%size=size
+    NewHallo%offset=offset
+    
+    
+  end subroutine Init_Hallo
+  
+  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions
+  implicit none
+
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestSend(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif      
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+      
+   end subroutine Register_SendField      
+      
+  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions
+  implicit none
+
+   
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestRecv(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif   
+            
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+
+      
+   end subroutine Register_RecvField      
+  
+  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
+  USE dimensions
+      implicit none
+
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapField    
+  
+
+  
+  subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
+  USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
+      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
+    enddo
+   
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapFieldHallo
+
+
+
+  SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_u 
+
+
+!!  SUBROUTINE Register_SwapField2d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+!!  USE parallel
+!!  USE dimensions
+!!    IMPLICIT NONE
+!!    
+!!    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+!!    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+!!    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+!!    TYPE(distrib),INTENT(IN)          :: new_dist
+!!    INTEGER,OPTIONAL,INTENT(IN)       :: up
+!!    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+!!    TYPE(request),INTENT(INOUT)         :: a_request
+!!
+!!    INTEGER                           :: halo_up
+!!    INTEGER                           :: halo_down
+!!    INTEGER                           :: ll
+!!        
+!!    
+!!    halo_up=0
+!!    halo_down=0
+!!    IF (PRESENT(up))   halo_up=up
+!!    IF (PRESENT(down)) halo_down=down
+!!    
+!!    ll=size(FieldS,2)
+!!    
+!!    IF (PRESENT(old_dist)) THEN
+!!      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+!!    ELSE
+!!      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+!!    ENDIF
+!!    
+!!  END SUBROUTINE  Register_SwapField2d_u
+   
+
+  SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_u 
+  
+
+
+ SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),OPTIONAL,INTENT(IN)          :: new_dist !LF
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_u2d 
+
+
+  SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_u2d
+   
+
+  SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_u2d 
+
+
+
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_v 
+
+
+!!  SUBROUTINE Register_SwapField2d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+!!  USE parallel
+!!  USE dimensions
+!!      IMPLICIT NONE
+    
+!!    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+!!    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+!!    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+!!    TYPE(distrib),INTENT(IN)          :: new_dist
+!!    INTEGER,OPTIONAL,INTENT(IN)       :: up
+!!    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+!!    TYPE(request),INTENT(INOUT)         :: a_request
+!!
+!!    INTEGER                           :: halo_up
+!!    INTEGER                           :: halo_down
+!!    INTEGER                           :: ll
+!!        
+!!    
+!!    halo_up=0
+!!    halo_down=0
+!!    IF (PRESENT(up))   halo_up=up
+!!    IF (PRESENT(down)) halo_down=down
+!!    
+!!    ll=size(FieldS,2)
+!!    
+!!    IF (PRESENT(old_dist)) THEN
+!!      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+!!    ELSE
+!!      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+!!    ENDIF
+!!    
+!!  END SUBROUTINE  Register_SwapField2d_v
+   
+
+  SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_v 
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),OPTIONAL,INTENT(IN)          :: new_dist !LF
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+        
+  END SUBROUTINE  Register_SwapField1d_v2d
+
+
+  SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField2d_v2d
+   
+
+  SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+    
+    REAL, DIMENSION(:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(:,:,:,:),INTENT(OUT)    :: FieldR
+    TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    IF (PRESENT(old_dist)) THEN
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    ELSE
+      CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    ENDIF
+    
+  END SUBROUTINE  Register_SwapField3d_v2d 
+  
+  
+
+  SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel
+  USE dimensions
+      IMPLICIT NONE
+   
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,:)=FieldS(ijb:ije,:)              
+        ENDDO
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_u
+
+
+
+  SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel
+  USE dimensions
+    IMPLICIT NONE
+    
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+
+        IF (jje==jjp1) jje=jjm        
+
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+
+        IF (jje==jjp1) jje=jjm
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        IF (jje==jjp1) jje=jjm
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+        ENDDO              
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_v
+
+
+ 
+
+  
+  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo
+
+
+  subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ll
+      REAL, dimension(ijb_u:ije_u,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_u
+
+  subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions
+      implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ll
+      REAL, dimension(ijb_v:ije_v,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_v
+    
+    subroutine SendRequest(a_Request)
+    USE dimensions
+      implicit none
+
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer :: SizeBuffer
+      integer :: i,rank,l,ij,Pos,ierr
+      integer :: offset
+      real,dimension(:,:),pointer :: Field
+      integer :: Nb
+       
+      do rank=0,MPI_SIZE-1
+      
+        Req=>a_Request%RequestSend(rank)
+        
+        SizeBuffer=0
+        do i=1,Req%NbRequest
+          PtrHallo=>Req%Hallo(i)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+          DO l=1,PtrHallo%NbLevel
+            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+          ENDDO
+!$OMP ENDDO NOWAIT          
+        enddo
+      
+         Req%BufferSize=SizeBuffer
+         if (Req%NbRequest>0) then
+       
+          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
+
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+            Nb=iip1*PtrHallo%size-1
+            Field=>PtrHallo%Field
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+            do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        Buffer(Pos+ij)=Field(Offset+ij,l)
+	      enddo
+              
+              Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT            
+          enddo
+    
+         if (SizeBuffer>0) then
+!$OMP CRITICAL (MPI)
+         
+#ifdef CPP_MPI
+         call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                         COMM_LMDZ,Req%MSG_Request,ierr)
+#endif
+         IF (.NOT.using_mpi) THEN
+           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+           STOP
+         ENDIF
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+        endif
+       endif
+    enddo
+   
+           
+      do rank=0,MPI_SIZE-1
+         
+          Req=>a_Request%RequestRecv(rank)
+          SizeBuffer=0
+          
+	  do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+            DO l=1,PtrHallo%NbLevel
+              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+            ENDDO
+!$OMP ENDDO NOWAIT          
+          enddo
+          
+          Req%BufferSize=SizeBuffer
+          
+          if (Req%NbRequest>0) then
+          call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
+   
+          if (SizeBuffer>0) then
+
+!$OMP CRITICAL (MPI)
+
+#ifdef CPP_MPI
+             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                           COMM_LMDZ,Req%MSG_Request,ierr)
+#endif             
+             IF (.NOT.using_mpi) THEN
+               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+               STOP
+             ENDIF
+
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+          endif
+        endif
+      
+      enddo
+                        
+   end subroutine SendRequest 
+   
+   subroutine WaitRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(2*mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
+#else
+      integer, dimension(1,2*mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      integer :: Nb
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+      endif
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+
+              Pos=Pos+Nb+1
+	    enddo
+!$OMP ENDDO NOWAIT	    
+          enddo
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRequest
+     
+   subroutine WaitSendRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+
+      if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN 
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+      endif      
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      a_request%tag=1
+    end subroutine WaitSendRequest
+    
+   subroutine WaitRecvRequest(a_Request)
+   USE dimensions
+   implicit none
+   
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset,Nb
+      
+      
+      NbRequest=0
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)     
+      endif
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+                 Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT
+          enddo
+        endif
+      enddo
+      
+           
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRecvRequest
+    
+    
+    
+    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
+    USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,l
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb,ijb,ije
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
+    jje=min(jj_end,jj_end_new(MPI_Rank))
+    if (ij==ip1jm) jje=min(jje,jjm)
+
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+    endif
+
+
+  end subroutine CopyField    
+
+  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
+  USE dimensions
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+
+    integer ::i,jje,jjb,ijb,ije,l
+
+     
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+
+        
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
+    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
+    if (ij==ip1jm) jje=min(jje,jjm)
+    
+    
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+
+    endif
+   end subroutine CopyFieldHallo        
+
+   subroutine Gather_field_u(field_loc,field_glo,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_u:ije_u,ll)
+     real :: field_glo(ip1jmp1,ll)
+     type(request) :: request_gather
+     integer       :: l
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_u
+        
+   subroutine Gather_field_v(field_loc,field_glo,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_v:ije_v,ll)
+     real :: field_glo(ip1jm,ll)
+     type(request) :: request_gather
+     integer :: ijb,ije
+     integer       :: l
+     
+   
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+        
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_v
+     
+   subroutine Scatter_field_u(field_glo,field_loc,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_u:ije_u,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: l
+     
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+ 
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER     
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
+       ENDDO
+
+    end subroutine Scatter_field_u
+
+   subroutine Scatter_field_v(field_glo,field_loc,ll)
+   USE dimensions
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_v:ije_v,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: ijb,ije,l
+     
+
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+     
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
+       ENDDO
+
+    end subroutine Scatter_field_v
+              
+end module mod_Hallo 
+   
Index: LMDZ5/trunk/libf/mod_interface_dyn_phys.F90
===================================================================
--- LMDZ5/trunk/libf/mod_interface_dyn_phys.F90	(revision 1630)
+++ LMDZ5/trunk/libf/mod_interface_dyn_phys.F90	(revision 1630)
@@ -0,0 +1,59 @@
+! 
+! $Id: mod_interface_dyn_phys.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE mod_interface_dyn_phys
+  INTEGER,SAVE,dimension(:),allocatable :: index_i
+  INTEGER,SAVE,dimension(:),allocatable :: index_j
+  
+  
+#ifdef CPP_EARTH
+! Interface with parallel physics,
+! for now this routine only works with Earth physics
+CONTAINS
+  
+  SUBROUTINE Init_interface_dyn_phys
+    USE mod_phys_lmdz_mpi_data
+    IMPLICIT NONE
+    include 'dimensions.h'    
+    
+    INTEGER :: i,j,k
+    
+    ALLOCATE(index_i(klon_mpi))
+    ALLOCATE(index_j(klon_mpi))
+    
+    k=1
+    IF (is_north_pole) THEN
+      index_i(k)=1
+      index_j(k)=1
+      k=2
+    ELSE
+      DO i=ii_begin,iim
+	index_i(k)=i
+	index_j(k)=jj_begin
+	k=k+1
+       ENDDO
+    ENDIF
+    
+    DO j=jj_begin+1,jj_end-1
+      DO i=1,iim
+	index_i(k)=i
+	index_j(k)=j
+	k=k+1
+      ENDDO
+    ENDDO
+    
+    IF (is_south_pole) THEN
+      index_i(k)=1
+      index_j(k)=jj_end
+    ELSE
+      DO i=1,ii_end
+	index_i(k)=i
+	index_j(k)=jj_end
+	k=k+1
+       ENDDO
+    ENDIF
+  
+  END SUBROUTINE Init_interface_dyn_phys 
+#endif
+! of #ifdef CPP_EARTH
+END MODULE mod_interface_dyn_phys
Index: LMDZ5/trunk/libf/nxgrad.F
===================================================================
--- LMDZ5/trunk/libf/nxgrad.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrad.F	(revision 1630)
@@ -0,0 +1,48 @@
+!
+! $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 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgrad_gam.F
===================================================================
--- LMDZ5/trunk/libf/nxgrad_gam.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrad_gam.F	(revision 1630)
@@ -0,0 +1,47 @@
+!
+! $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 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgrad_gam_loc.F
===================================================================
--- LMDZ5/trunk/libf/nxgrad_gam_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrad_gam_loc.F	(revision 1630)
@@ -0,0 +1,69 @@
+      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
+      
+      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 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if(pole_nord) ijb=ij_begin+iip1
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+    
+      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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgrad_gam_p.F
===================================================================
--- LMDZ5/trunk/libf/nxgrad_gam_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrad_gam_p.F	(revision 1630)
@@ -0,0 +1,67 @@
+      SUBROUTINE nxgrad_gam_p( 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
+      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
+      integer ismin,ismax
+      external ismin,ismax
+      INTEGER :: ijb,ije
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if(pole_nord) ijb=ij_begin+iip1
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+    
+      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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgrad_loc.F
===================================================================
--- LMDZ5/trunk/libf/nxgrad_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrad_loc.F	(revision 1630)
@@ -0,0 +1,68 @@
+      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
+      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 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+       
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_nord)  ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+   
+      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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgrad_p.F
===================================================================
--- LMDZ5/trunk/libf/nxgrad_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrad_p.F	(revision 1630)
@@ -0,0 +1,67 @@
+      SUBROUTINE nxgrad_p (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
+      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
+      INTEGER :: ijb,ije
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+       
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_nord)  ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+   
+      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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgradst.F
===================================================================
--- LMDZ5/trunk/libf/nxgradst.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgradst.F	(revision 1630)
@@ -0,0 +1,47 @@
+!
+! $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 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y(ij,l)=( rot(ij,l) - rot(ij-1,l))
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgraro2.F
===================================================================
--- LMDZ5/trunk/libf/nxgraro2.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgraro2.F	(revision 1630)
@@ -0,0 +1,68 @@
+!
+! $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: LMDZ5/trunk/libf/nxgraro2_loc.F
===================================================================
--- LMDZ5/trunk/libf/nxgraro2_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgraro2_loc.F	(revision 1630)
@@ -0,0 +1,142 @@
+       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
+      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) :: 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: LMDZ5/trunk/libf/nxgraro2_mod.F90
===================================================================
--- LMDZ5/trunk/libf/nxgraro2_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/nxgraro2_mod.F90	(revision 1630)
@@ -0,0 +1,39 @@
+MODULE nxgraro2_mod
+
+  REAL,POINTER,SAVE ::  grx( :,: )
+  REAL,POINTER,SAVE ::  gry( :,: )
+  REAL,POINTER,SAVE ::  rot( :,: )
+  
+CONTAINS
+
+  SUBROUTINE nxgraro2_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE dimensions
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(grx,llm,d)
+    CALL allocate_v(gry,llm,d)
+    CALL allocate_v(rot,llm,d)
+
+    
+  END SUBROUTINE nxgraro2_allocate
+  
+  SUBROUTINE nxgraro2_switch_dissip(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(grx,distrib_dissip,dist)
+    CALL switch_v(gry,distrib_dissip,dist)
+    CALL switch_v(rot,distrib_dissip,dist)
+
+
+  END SUBROUTINE nxgraro2_switch_dissip
+  
+END MODULE nxgraro2_mod  
Index: LMDZ5/trunk/libf/nxgraro2_p.F
===================================================================
--- LMDZ5/trunk/libf/nxgraro2_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgraro2_p.F	(revision 1630)
@@ -0,0 +1,141 @@
+       SUBROUTINE nxgraro2_p (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
+      USE times
+      USE mod_hallo
+      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,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
+      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL,SAVE :: rot(ip1jm,llm)
+      REAL  signe, nugradrs
+      INTEGER l,ij,iter,lr
+      Type(Request) :: 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(grx,ip1jmp1,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_p     ( klevel, grx, gry, rot )
+c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+
+c$OMP BARRIER
+       call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+      
+      CALL laplacien_rot_p ( 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(rot,ip1jm,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+	CALL laplacien_rotgam_p ( 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,jje,jjm, klevel, 2,1, .FALSE.,1)
+c$OMP BARRIER
+       call Register_Hallo(rot,ip1jm,llm,1,0,0,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      CALL nxgrad_p ( 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: LMDZ5/trunk/libf/nxgrarot.F
===================================================================
--- LMDZ5/trunk/libf/nxgrarot.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrarot.F	(revision 1630)
@@ -0,0 +1,55 @@
+!
+! $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"
+#include "logic.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 10 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 5  l = 1, klevel
+      DO 2 ij = 1, ip1jm
+      gry( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      DO 3 ij = 1, ip1jmp1
+      grx( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/nxgrarot_p.F
===================================================================
--- LMDZ5/trunk/libf/nxgrarot_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/nxgrarot_p.F	(revision 1630)
@@ -0,0 +1,101 @@
+      SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out )
+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
+      USE parallel
+      USE times
+      USE write_field_p
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
+      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
+
+c
+      REAL,SAVE :: rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+c      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      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      
+
+      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
+      
+      DO 10 iter = 1,lr
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(grx,ip1jmp1,llm,0,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+      CALL  rotat_p (klevel,grx, gry, rot )
+c      call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/)))
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2)
+
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(rot,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL nxgrad_p (klevel,rot, grx, gry )
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5  l = 1, klevel
+      if(pole_sud) ije=ij_end-iip1
+      DO 2 ij = ijb, ije
+      gry_out( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      if(pole_sud) ije=ij_end
+      DO 3 ij = ijb, ije
+      grx_out( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c      call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/)))
+c      call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/)))
+c      stop
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/omp_chunk.h
===================================================================
--- LMDZ5/trunk/libf/omp_chunk.h	(revision 1630)
+++ LMDZ5/trunk/libf/omp_chunk.h	(revision 1630)
@@ -0,0 +1,1 @@
+#define OMP_CHUNK 5
Index: LMDZ5/trunk/libf/parallel.F90
===================================================================
--- LMDZ5/trunk/libf/parallel.F90	(revision 1630)
+++ LMDZ5/trunk/libf/parallel.F90	(revision 1630)
@@ -0,0 +1,739 @@
+! 
+! $Id: parallel.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+  module parallel
+  USE mod_const_mpi
+    
+    INTEGER,PARAMETER :: halo_max=3
+    
+    LOGICAL,SAVE :: using_mpi
+    LOGICAL,SAVE :: using_omp
+    
+    integer, save :: mpi_size
+    integer, save :: mpi_rank
+    integer, save :: jj_begin
+    integer, save :: jj_end
+    integer, save :: jj_nb
+    integer, save :: ij_begin
+    integer, save :: ij_end
+    logical, save :: pole_nord
+    logical, save :: pole_sud
+
+    integer,save  :: jjb_u
+    integer,save  :: jje_u
+    integer,save  :: jjnb_u
+    integer,save  :: jjb_v
+    integer,save  :: jje_v
+    integer,save  :: jjnb_v    
+
+    integer,save  :: ijb_u
+    integer,save  :: ije_u
+    integer,save  :: ijnb_u    
+    
+    integer,save  :: ijb_v
+    integer,save  :: ije_v
+    integer,save  :: ijnb_v    
+     
+    
+    integer, allocatable, save, dimension(:) :: jj_begin_para
+    integer, allocatable, save, dimension(:) :: jj_end_para
+    integer, allocatable, save, dimension(:) :: jj_nb_para
+    integer, save :: OMP_CHUNK
+    integer, save :: omp_rank
+    integer, save :: omp_size  
+!$OMP THREADPRIVATE(omp_rank)
+
+    TYPE distrib
+      integer :: jj_begin
+      integer :: jj_end
+      integer :: jj_nb
+      integer :: ij_begin
+      integer :: ij_end
+
+      integer  :: jjb_u
+      integer  :: jje_u
+      integer  :: jjnb_u
+      integer  :: jjb_v
+      integer  :: jje_v
+      integer  :: jjnb_v    
+ 
+      integer  :: ijb_u
+      integer  :: ije_u
+      integer  :: ijnb_u    
+    
+      integer  :: ijb_v
+      integer  :: ije_v
+      integer  :: ijnb_v    
+     
+    
+      integer, pointer :: jj_begin_para(:) => NULL()
+      integer, pointer :: jj_end_para(:) => NULL()
+      integer, pointer :: jj_nb_para(:) => NULL()
+    END TYPE distrib  
+    
+    INTERFACE ASSIGNMENT (=)
+      MODULE PROCEDURE copy_distrib
+    END INTERFACE
+    TYPE(distrib),SAVE :: current_dist
+    
+ contains
+ 
+    subroutine init_parallel
+    USE vampir
+    implicit none
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+
+      integer :: ierr
+      integer :: i,j
+      integer :: type_size
+      integer, dimension(3) :: blocklen,type
+      integer :: comp_id
+
+#ifdef CPP_OMP    
+      INTEGER :: OMP_GET_NUM_THREADS
+      EXTERNAL OMP_GET_NUM_THREADS
+      INTEGER :: OMP_GET_THREAD_NUM
+      EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef CPP_MPI
+       using_mpi=.TRUE.
+#else
+       using_mpi=.FALSE.
+#endif
+      
+
+#ifdef CPP_OMP
+       using_OMP=.TRUE.
+#else
+       using_OMP=.FALSE.
+#endif
+      
+      call InitVampir
+      
+      IF (using_mpi) THEN
+#ifdef CPP_MPI
+        call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
+        call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
+#endif
+      ELSE
+        mpi_size=1
+        mpi_rank=0
+      ENDIF
+  
+      
+      allocate(jj_begin_para(0:mpi_size-1))
+      allocate(jj_end_para(0:mpi_size-1))
+      allocate(jj_nb_para(0:mpi_size-1))
+      
+      do i=0,mpi_size-1
+        jj_nb_para(i)=(jjm+1)/mpi_size
+        if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
+        
+        if (jj_nb_para(i) <= 2 ) then
+          
+         write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
+         write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
+          
+#ifdef CPP_MPI
+          IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
+#endif          
+        endif
+        
+      enddo
+      
+!      jj_nb_para(0)=11
+!      jj_nb_para(1)=25
+!      jj_nb_para(2)=25
+!      jj_nb_para(3)=12      
+
+      j=1
+      
+      do i=0,mpi_size-1 
+        
+        jj_begin_para(i)=j
+        jj_end_para(i)=j+jj_Nb_para(i)-1
+        j=j+jj_Nb_para(i)
+      
+      enddo
+      
+      jj_begin = jj_begin_para(mpi_rank)
+      jj_end   = jj_end_para(mpi_rank)
+      jj_nb    = jj_nb_para(mpi_rank)
+      
+      ij_begin=(jj_begin-1)*iip1+1
+      ij_end=jj_end*iip1
+      
+      if (mpi_rank.eq.0) then
+        pole_nord=.TRUE.
+      else 
+        pole_nord=.FALSE.
+      endif
+      
+      if (mpi_rank.eq.mpi_size-1) then
+        pole_sud=.TRUE.
+      else 
+        pole_sud=.FALSE.
+      endif
+        
+      write(lunout,*)"init_parallel: jj_begin",jj_begin
+      write(lunout,*)"init_parallel: jj_end",jj_end
+      write(lunout,*)"init_parallel: ij_begin",ij_begin
+      write(lunout,*)"init_parallel: ij_end",ij_end
+      jjb_u=MAX(jj_begin-halo_max,1)
+      jje_u=MIN(jj_end+halo_max,jjp1)
+      jjnb_u=jje_u-jjb_u+1
+
+      jjb_v=MAX(jj_begin-halo_max,1)
+      jje_v=MIN(jj_end+halo_max,jjm)
+      jjnb_v=jje_v-jjb_v+1
+
+      ijb_u=MAX(ij_begin-halo_max*iip1,1)
+      ije_u=MIN(ij_end+halo_max*iip1,ip1jmp1)
+      ijnb_u=ije_u-ijb_u+1
+
+      ijb_v=MAX(ij_begin-halo_max*iip1,1)
+      ije_v=MIN(ij_end+halo_max*iip1,ip1jm)
+      ijnb_v=ije_v-ijb_v+1
+      
+!$OMP PARALLEL
+
+#ifdef CPP_OMP
+!$OMP MASTER
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+        omp_size=1
+        omp_rank=0
+#endif
+!$OMP END PARALLEL         
+      CALL create_distrib(jj_nb_para,current_dist)
+      
+    end subroutine init_parallel
+
+    SUBROUTINE create_distrib(jj_nb_new,d)
+    IMPLICIT NONE
+      INCLUDE "dimensions.h"
+      INCLUDE "paramet.h"
+      
+      INTEGER,INTENT(IN) :: jj_Nb_New(0:MPI_Size-1)
+      TYPE(distrib),INTENT(INOUT) :: d
+      INTEGER :: i  
+  
+      IF (.NOT. ASSOCIATED(d%jj_nb_para)) ALLOCATE(d%jj_nb_para(0:MPI_Size-1))
+      IF (.NOT. ASSOCIATED(d%jj_begin_para)) ALLOCATE(d%jj_begin_para(0:MPI_Size-1))
+      IF (.NOT. ASSOCIATED(d%jj_end_para)) ALLOCATE(d%jj_end_para(0:MPI_Size-1))
+      
+      d%jj_Nb_Para=jj_Nb_New
+      
+      d%jj_begin_para(0)=1
+      d%jj_end_para(0)=d%jj_Nb_Para(0)
+      
+      do i=1,mpi_size-1 
+        
+        d%jj_begin_para(i)=d%jj_end_para(i-1)+1
+        d%jj_end_para(i)=d%jj_begin_para(i)+d%jj_Nb_para(i)-1
+      
+      enddo
+      
+      d%jj_begin = d%jj_begin_para(mpi_rank)
+      d%jj_end   = d%jj_end_para(mpi_rank)
+      d%jj_nb    = d%jj_nb_para(mpi_rank)
+      
+      d%ij_begin=(d%jj_begin-1)*iip1+1
+      d%ij_end=d%jj_end*iip1
+
+      d%jjb_u=MAX(d%jj_begin-halo_max,1)
+      d%jje_u=MIN(d%jj_end+halo_max,jjp1)
+      d%jjnb_u=d%jje_u-d%jjb_u+1
+
+      d%jjb_v=MAX(d%jj_begin-halo_max,1)
+      d%jje_v=MIN(d%jj_end+halo_max,jjm)
+      d%jjnb_v=d%jje_v-d%jjb_v+1
+
+      d%ijb_u=MAX(d%ij_begin-halo_max*iip1,1)
+      d%ije_u=MIN(d%ij_end+halo_max*iip1,ip1jmp1)
+      d%ijnb_u=d%ije_u-d%ijb_u+1
+
+      d%ijb_v=MAX(d%ij_begin-halo_max*iip1,1)
+      d%ije_v=MIN(d%ij_end+halo_max*iip1,ip1jm)
+      d%ijnb_v=d%ije_v-d%ijb_v+1      
+
+    END SUBROUTINE create_distrib
+
+      
+    SUBROUTINE Set_Distrib(d)
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    TYPE(distrib),INTENT(IN) :: d
+
+      jj_begin = d%jj_begin
+      jj_end = d%jj_end
+      jj_nb = d%jj_nb
+      ij_begin = d%ij_begin
+      ij_end = d%ij_end
+
+      jjb_u = d%jjb_u
+      jje_u = d%jje_u
+      jjnb_u = d%jjnb_u
+      jjb_v = d%jjb_v
+      jje_v = d%jje_v
+      jjnb_v = d%jjnb_v
+ 
+      ijb_u = d%ijb_u
+      ije_u = d%ije_u
+      ijnb_u = d%ijnb_u
+    
+      ijb_v = d%ijb_v
+      ije_v = d%ije_v
+      ijnb_v = d%ijnb_v
+     
+    
+      jj_begin_para(:) = d%jj_begin_para(:)
+      jj_end_para(:) = d%jj_end_para(:)
+      jj_nb_para(:) = d%jj_nb_para(:)
+      current_dist=d 
+
+    END SUBROUTINE Set_Distrib
+
+    SUBROUTINE copy_distrib(dist,new_dist)
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    TYPE(distrib),INTENT(INOUT) :: dist
+    TYPE(distrib),INTENT(IN) :: new_dist
+
+     dist%jj_begin = new_dist%jj_begin
+     dist%jj_end = new_dist%jj_end
+     dist%jj_nb = new_dist%jj_nb
+     dist%ij_begin = new_dist%ij_begin
+     dist%ij_end = new_dist%ij_end
+
+     dist%jjb_u = new_dist%jjb_u
+     dist%jje_u = new_dist%jje_u
+     dist%jjnb_u = new_dist%jjnb_u
+     dist%jjb_v = new_dist%jjb_v
+     dist%jje_v = new_dist%jje_v
+     dist%jjnb_v = new_dist%jjnb_v
+   
+     dist%ijb_u = new_dist%ijb_u
+     dist%ije_u = new_dist%ije_u
+     dist%ijnb_u = new_dist%ijnb_u
+     
+     dist%ijb_v = new_dist%ijb_v
+     dist%ije_v = new_dist%ije_v
+     dist%ijnb_v = new_dist%ijnb_v
+         
+     
+     dist%jj_begin_para(:) = new_dist%jj_begin_para(:)
+     dist%jj_end_para(:) = new_dist%jj_end_para(:)
+     dist%jj_nb_para(:) = new_dist%jj_nb_para(:)
+ 
+    END SUBROUTINE copy_distrib
+    
+    
+    SUBROUTINE get_current_distrib(d)
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    TYPE(distrib),INTENT(OUT) :: d
+
+     d=current_dist
+
+    END SUBROUTINE get_current_distrib
+    
+    subroutine Finalize_parallel
+#ifdef CPP_COUPLE
+    use mod_prism_proto
+#endif
+#ifdef CPP_EARTH
+! Ehouarn: surface_data module is in 'phylmd' ...
+      use surface_data, only : type_ocean
+      implicit none
+#else
+      implicit none
+! without the surface_data module, we declare (and set) a dummy 'type_ocean'
+      character(len=6),parameter :: type_ocean="dummy"
+#endif
+! #endif of #ifdef CPP_EARTH
+
+      include "dimensions.h"
+      include "paramet.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif      
+
+      integer :: ierr
+      integer :: i
+      deallocate(jj_begin_para)
+      deallocate(jj_end_para)
+      deallocate(jj_nb_para)
+
+      if (type_ocean == 'couple') then
+#ifdef CPP_COUPLE
+         call prism_terminate_proto(ierr)
+         IF (ierr .ne. PRISM_Ok) THEN
+            call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
+         endif
+#endif 
+      else
+#ifdef CPP_MPI
+         IF (using_mpi) call MPI_FINALIZE(ierr)
+#endif
+      end if
+      
+    end subroutine Finalize_parallel
+        
+    subroutine Pack_Data(Field,ij,ll,row,Buffer)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer, intent(in) :: ij,ll,row
+      real,dimension(ij,ll),intent(in) ::Field
+      real,dimension(ll*iip1*row), intent(out) :: Buffer 
+            
+      integer :: Pos
+      integer :: i,l
+      
+      Pos=0
+      do l=1,ll
+        do i=1,row*iip1
+          Pos=Pos+1
+          Buffer(Pos)=Field(i,l)
+        enddo
+      enddo
+      
+    end subroutine Pack_data 
+     
+    subroutine Unpack_Data(Field,ij,ll,row,Buffer)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer, intent(in) :: ij,ll,row
+      real,dimension(ij,ll),intent(out) ::Field
+      real,dimension(ll*iip1*row), intent(in) :: Buffer 
+            
+      integer :: Pos
+      integer :: i,l
+      
+      Pos=0
+      
+      do l=1,ll
+        do i=1,row*iip1
+          Pos=Pos+1
+          Field(i,l)=Buffer(Pos)
+        enddo
+      enddo
+      
+    end subroutine UnPack_data
+
+    
+    SUBROUTINE barrier
+    IMPLICIT NONE
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+    
+!$OMP CRITICAL (MPI)      
+#ifdef CPP_MPI
+      IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+    
+    END SUBROUTINE barrier
+       
+      
+    subroutine exchange_hallo(Field,ij,ll,up,down)
+    USE Vampir
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: up,down
+      
+      INTEGER :: ierr
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+      INTEGER, DIMENSION(4) :: Request
+#ifdef CPP_MPI
+      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
+#else
+      INTEGER, DIMENSION(1,4) :: Status
+#endif
+      INTEGER :: NbRequest
+      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
+      REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
+      INTEGER :: Buffer_size      
+
+      IF (using_mpi) THEN
+
+        CALL barrier
+      
+        call VTb(VThallo)
+      
+        SendUp=.TRUE.
+        SendDown=.TRUE.
+        RecvUp=.TRUE.
+        RecvDown=.TRUE.
+          
+        IF (pole_nord) THEN
+          SendUp=.FALSE.
+          RecvUp=.FALSE.
+        ENDIF
+    
+        IF (pole_sud) THEN
+          SendDown=.FALSE.
+          RecvDown=.FALSE.
+        ENDIF
+        
+        if (up.eq.0) then
+          SendDown=.FALSE.
+          RecvUp=.FALSE.
+        endif
+      
+        if (down.eq.0) then
+          SendUp=.FALSE.
+          RecvDown=.FALSE.
+        endif
+      
+        NbRequest=0
+  
+        IF (SendUp) THEN
+          NbRequest=NbRequest+1
+          buffer_size=down*iip1*ll
+          allocate(Buffer_Send_up(Buffer_size))
+          call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+        ENDIF
+  
+        IF (SendDown) THEN
+          NbRequest=NbRequest+1
+           
+          buffer_size=up*iip1*ll
+          allocate(Buffer_Send_down(Buffer_size))
+          call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
+        
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+        ENDIF
+    
+  
+        IF (RecvUp) THEN
+          NbRequest=NbRequest+1
+          buffer_size=up*iip1*ll
+          allocate(Buffer_recv_up(Buffer_size))
+              
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+     
+       
+        ENDIF
+  
+        IF (RecvDown) THEN
+          NbRequest=NbRequest+1
+          buffer_size=down*iip1*ll
+          allocate(Buffer_recv_down(Buffer_size))
+        
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+        
+        ENDIF
+  
+#ifdef CPP_MPI
+        if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
+#endif
+        IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
+        IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)  
+
+        call VTe(VThallo)
+        call barrier
+      
+      ENDIF  ! using_mpi
+      
+      RETURN
+      
+    end subroutine exchange_Hallo
+    
+
+    subroutine Gather_Field(Field,ij,ll,rank)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h" 
+#include "iniprint.h"
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll,rank
+      REAL, dimension(ij,ll) :: Field
+      REAL, dimension(:),allocatable :: Buffer_send   
+      REAL, dimension(:),allocatable :: Buffer_Recv
+      INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
+      INTEGER :: ierr
+      INTEGER ::i
+      
+      IF (using_mpi) THEN
+
+        if (ij==ip1jmp1) then 
+           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
+           call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
+        else if (ij==ip1jm) then
+           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
+           call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
+        else
+           write(lunout,*)ij  
+        stop 'erreur dans Gather_Field'
+        endif
+        
+        if (MPI_Rank==rank) then
+          allocate(Buffer_Recv(ij*ll))
+
+!CDIR NOVECTOR
+          do i=0,MPI_Size-1
+             
+            if (ij==ip1jmp1) then 
+              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
+            else if (ij==ip1jm) then
+              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
+            else
+              stop 'erreur dans Gather_Field'
+            endif
+                   
+            if (i==0) then 
+              displ(i)=0 
+            else
+              displ(i)=displ(i-1)+Recv_count(i-1)
+            endif
+            
+          enddo
+          
+        endif
+  
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+        call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
+                          Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      
+        if (MPI_Rank==rank) then                  
+      
+          if (ij==ip1jmp1) then 
+            do i=0,MPI_Size-1
+              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
+                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
+            enddo
+          else if (ij==ip1jm) then
+            do i=0,MPI_Size-1
+               call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
+                               min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
+            enddo
+          endif
+        endif 
+      ENDIF ! using_mpi
+      
+    end subroutine Gather_Field
+
+
+    subroutine AllGather_Field(Field,ij,ll)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: ierr
+      
+      IF (using_mpi) THEN
+        call Gather_Field(Field,ij,ll,0)
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      ENDIF
+      
+    end subroutine AllGather_Field
+    
+   subroutine Broadcast_Field(Field,ij,ll,rank)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: rank
+      INTEGER :: ierr
+      
+      IF (using_mpi) THEN
+      
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      
+      ENDIF
+    end subroutine Broadcast_Field
+        
+   
+    /*  
+  Subroutine verif_hallo(Field,ij,ll,up,down)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: up,down 
+      
+      REAL,dimension(ij,ll): NewField
+      
+      NewField=0
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) 
+      NewField(ij_be       
+*/
+  end module parallel
Index: LMDZ5/trunk/libf/paramet.h
===================================================================
--- LMDZ5/trunk/libf/paramet.h	(revision 1630)
+++ LMDZ5/trunk/libf/paramet.h	(revision 1630)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3                &
+     &    ,jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/pbar.F
===================================================================
--- LMDZ5/trunk/libf/pbar.F	(revision 1630)
+++ LMDZ5/trunk/libf/pbar.F	(revision 1630)
@@ -0,0 +1,124 @@
+!
+! $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 1 ij = 1, ip1jmp1 - 1
+      pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
+   1  CONTINUE
+
+c    .... correction pour pbarx( iip1,j) .....
+
+c    ...    pbarx(iip1,j)= pbarx(1,j) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jmp1, iip1
+      pbarx( ij ) = pbarx( ij - iim )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     +
+     *              pext( ij+iip1 ) * alpha1p4( ij+iip1 )
+   3  CONTINUE
+
+
+      DO 5 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)
+   5  CONTINUE
+
+
+c    ....  correction pour     pbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      pbarxy( ij ) = pbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/pentes_ini.F
===================================================================
--- LMDZ5/trunk/libf/pentes_ini.F	(revision 1630)
+++ LMDZ5/trunk/libf/pentes_ini.F	(revision 1630)
@@ -0,0 +1,474 @@
+!
+! $Header$
+!
+      SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
+      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 "comconst.h"
+#include "comvert.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  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.ge.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.eq.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.eq.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.eq.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.eq.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.eq.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.ge.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.eq.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.eq.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).lt.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).lt.qmin)
+     ,       print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)
+           enddo
+          enddo
+       enddo
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ5/trunk/libf/ppm3d.F
===================================================================
--- LMDZ5/trunk/libf/ppm3d.F	(revision 1630)
+++ LMDZ5/trunk/libf/ppm3d.F	(revision 1630)
@@ -0,0 +1,2001 @@
+!
+! $Id: ppm3d.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+
+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)
+
+c      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
+      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./
+      SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML,
+     &     DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
+C
+            
+      JMR = JNP -1
+      IMJM  = IMR*JNP
+      j2 = JNP - j1 + 1
+      NSTEP = NSTEP + 1
+C
+C *********** Initialization **********************
+      if(NSTEP.eq.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.LT.6) then
+        write(6,*) 'NLAY must be >= 6'
+        stop
+      endif
+      if (JNP.LT.NLAY) then
+         write(6,*) 'JNP must be >= NLAY'
+        stop
+      endif
+      IMRD2=mod(IMR,2)
+      if (j1.eq.2.and.IMRD2.NE.0) then
+         write(6,*) 'if j1=2 IMR must be an even integer'
+        stop
+      endif
+
+C
+      if(Jmax.lt.JNP .or. Kmax.lt.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.eq.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 15 J=2,JMR
+15    acosp(j) = 1. / cosp(j)
+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 .ne. NDT) then
+      DT   = NDT
+      NDT0 = NDT
+
+	if(Umax .lt. 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 .lt. abs(NDT)) then
+            write(6,*) 'Warning!!! NDT maybe too large!'
+      endif
+C
+      if(CR1.ge.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.ne.2) then
+      DO 40 IC=1,NC
+      DO 40 L=1,NLAY
+      DO 40 I=1,IMR
+      Q(I,  2,L,IC) = Q(I,  1,L,IC)
+40    Q(I,JMR,L,IC) = Q(I,JNP,L,IC)
+      endif
+C
+C Compute "tracer density"
+      DO 550 IC=1,NC
+      DO 44 k=1,NLAY
+      DO 44 j=1,JNP
+      DO 44 i=1,IMR
+44    DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k)
+550	continue
+C
+      do 1500 k=1,NLAY
+C
+      if(IGD.eq.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 45 j=j1,j2
+      do 45 i=2,IMR
+45    CRX(i,J) = dtdx(j)*U(i-1,j,k)
+   
+C
+      do 50 j=j1,j2
+50    CRX(1,J) = dtdx(j)*U(IMR,j,k)
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY*V(i,1,k)
+      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)).GT.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)).GT.1.) then
+            JN = j
+            go to 2233
+      endif
+      enddo
+      enddo
+2233  continue
+C
+      if(j1.ne.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 95 j=j1,j2
+      DO 95 i=1,IMR
+95    DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
+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 110 j=j1,j2
+      DO 110 i=1,IMR
+110   xmass(i,j) = PU(i,j)*CRX(i,j)
+C
+      DO 120 j=j1,j2
+      DO 120 i=1,IMR-1
+120   DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j)
+C
+      DO 130 j=j1,j2
+130   DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j)
+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.eq.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 1000 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 250 j=J1,J2
+      if(J.GT.JS  .and. J.LT.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 230 i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.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)
+230   continue
+250   continue
+C
+      if(JN.ne.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 .GE. 2) then
+		iad = 2
+	else
+		iad = 1
+	endif
+C
+	if(JORD .GE. 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
+1000  continue
+1500  continue
+C
+C ******* Compute vertical mass flux (same unit as PS) ***********
+C
+C 1st step: compute total column mass CONVERGENCE.
+C
+      do 320 j=1,JNP
+      do 320 i=1,IMR
+320   CRY(i,j) = DPI(i,j,1)
+C
+      do 330 k=2,NLAY
+      do 330 j=1,JNP
+      do 330 i=1,IMR
+      CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
+330   continue
+C
+      do 360 j=1,JNP
+      do 360 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.
+360   continue
+C
+      do 370 k=2,NLAY-1
+      do 370 j=1,JNP
+      do 370 i=1,IMR
+      W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
+370   continue
+C
+      DO 380 k=1,NLAY
+      DO 380 j=1,JNP
+      DO 380 i=1,IMR
+      delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j)
+380   continue
+C
+	KRD = max(3, KORD)
+      do 4000 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.ne.2) then
+      DO 400 k=1,NLAY
+      DO 400 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)
+400   CONTINUE
+      endif
+4000  continue
+C
+      if(j1.ne.2) then
+      DO 5000 k=1,NLAY
+      DO 5000 i=1,IMR
+      W(i,  2,k) = W(i,  1,k)
+      W(i,JMR,k) = W(i,JNP,k)
+5000  continue
+      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)
+      parameter ( kmax = 150 )
+      parameter ( R23 = 2./3., R3 = 1./3.)
+      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,*)
+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 1000 k=1,NLAYM1
+      do 1000 i=1,IMJM
+      DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
+1000  continue
+C
+      DO 1220 k=2,NLAYM1
+      DO 1220 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)   
+1220  CONTINUE
+     
+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 2000 j=1,JNP
+      if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.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 10 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).le.0.) then
+		 AL(i,1) = 0.
+             flux(i,1) = 0.
+	else
+             flux(i,1) =  wk1(i,1) - AL(i,1)
+	endif
+10    continue
+C
+C Bottom
+      DO 15 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).le.0.) AR(i,NLAY) = 0.
+      flux(i,NLAY) = AR(i,NLAY) -  wk1(i,NLAY)
+15    continue
+     
+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 14 k=3,NLAYM1
+      DO 12 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)
+12    CONTINUE
+14    continue
+C
+      do 20 i=1,IMR*NLAYM1
+      AR(i,1) = AL(i,2)
+C      print *,'AR1',i,AR(i,1)
+20    continue
+C
+      do 30 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)
+30    continue
+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.LE.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 140 i=1,IMR*NLAYM1
+      IF(wz2(i,1).GT.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
+140   continue
+C
+      DO 250 i=1,IMR*NLAYM1
+      flux(i,2) = wz2(i,1) * flux(i,2)
+250   continue
+C
+      do 350 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)
+350   continue
+C
+      do 360 k=2,NLAYM1
+      do 360 i=1,IMR
+360   DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
+2000  continue
+      return
+      end
+C
+      subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC,
+     &               fx1,xmass,IORD)
+      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),ISAVE(IMR)
+C
+      IMP = IMR + 1
+C
+C van Leer at high latitudes
+      jvan = max(1,JNP/18)
+      j1vl = j1+jvan
+      j2vl = j2-jvan
+C
+      do 1310 j=j1,j2
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j)
+      enddo
+C
+      if(j.ge.JN .or. j.le.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.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1406 i=1,IMR
+      iu = REAL(i) - uc(i,j)
+1406  fx1(i) = qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+      DC(0) = DC(IMR)
+C
+      if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then
+      DO 1408 i=1,IMR
+      iu = REAL(i) - uc(i,j)
+1408  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
+      else
+      call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
+      endif
+C
+      ENDIF
+C
+      DO 1506 i=1,IMR
+1506  fx1(i) = fx1(i)*xmass(i,j)
+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.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1306 i=1,IMR
+      itmp = INT(uc(i,j))
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1306  fx1(i) = (uc(i,j) - itmp)*qtmp(iu)
+      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 1307 i=1,IMR
+      itmp = INT(uc(i,j))
+      rut  = uc(i,j) - itmp
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1307  fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut))
+      ENDIF
+C
+      do 1308 i=1,IMR
+      IF(uc(i,j).GT.1.) then
+CDIR$ NOVECTOR
+        do ist = ISAVE(i),i-1
+        fx1(i) = fx1(i) + qtmp(ist)
+        enddo
+      elseIF(uc(i,j).LT.-1.) then
+        do ist = i,ISAVE(i)-1
+        fx1(i) = fx1(i) - qtmp(ist)
+        enddo
+CDIR$ VECTOR
+      endif
+1308  continue
+      do i=1,IMR
+      fx1(i) = PU(i,j)*fx1(i)
+      enddo
+C
+C ***************************************
+C
+1309  fx1(IMP) = fx1(1)
+      DO 1215 i=1,IMR
+1215  DQ(i,j) =  DQ(i,j) + fx1(i)-fx1(i+1)
+C
+C ***************************************
+C
+1310  continue
+      return
+      end
+C
+      subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
+      DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR)
+      integer LMT 
+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 10 i=1,IMR
+10    AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3
+C
+      do 20 i=1,IMR-1
+20    AR(i) = AL(i+1)
+      AR(IMR) = AL(1)
+C
+      do 30 i=1,IMR
+30    A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
+C
+      if(LMT.LE.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).GT.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)
+      parameter( R24 = 1./24.)
+      dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+C
+      do 10  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))
+10    DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp)
+      return
+      end
+C
+      subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2
+     &              ,ymass,fx,A6,AR,AL,JORD)
+      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)
+C
+      JMR = JNP - 1
+      len = IMR*(J2-J1+2)
+C
+      if(JORD.eq.1) then
+      DO 1000 i=1,len
+      JT = REAL(J1) - VC(i,J1)
+1000  fx(i,j1) = p(i,JT)
+      else
+   
+      call ymist(IMR,JNP,j1,P,DC2,4)
+C
+      if(JORD.LE.0 .or. JORD.GE.3) then
+   
+      call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+    
+      else
+      DO 1200 i=1,len
+      JT = REAL(J1) - VC(i,J1)
+1200  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
+      endif
+      endif
+C
+      DO 1300 i=1,len
+1300  fx(i,j1) = fx(i,j1)*ymass(i,j1)
+C
+      DO 1400 j=j1,j2
+      DO 1400 i=1,IMR
+1400  DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j)
+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.ne.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)
+      parameter ( R24 = 1./24. )
+      dimension P(IMR,JNP),DC(IMR,JNP)
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      IJM3 = IMR*(JMR-3)
+C
+      IF(ID.EQ.2) THEN
+      do 10 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)
+10    CONTINUE
+      ELSE
+      do 12 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)
+12    CONTINUE
+      do 14 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)
+14    CONTINUE
+C
+      do 15 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)
+15    CONTINUE
+      ENDIF
+C
+      if(j1.ne.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 13 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)
+13    continue
+C
+      do 25 i=imh+1,IMR
+      DC(i,  1) =  - DC(i-imh,  1)
+      DC(i,JNP) =  - DC(i-imh,JNP)
+25    continue
+      endif
+      return
+      end
+C
+      subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+      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
+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 10 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)
+10    CONTINUE
+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 30 i=1,len
+30    A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
+C
+      if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11)
+     &                       ,AL(1,j11),P(1,j11),len,LMT)
+C
+     
+      DO 140 i=1,IMJM1
+      IF(VC(i,j1).GT.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
+140   continue
+      return
+      end
+C
+	subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
+	REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
+        REAL WK(IMR,-1:JNP+2)
+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.eq.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.eq.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.ne.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)
+	REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
+C
+	JMR = JNP-1
+      do 1309 j=j1,j2
+      if(J.GT.JS  .and. J.LT.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.eq.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.eq.1) then
+      DO i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.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
+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.eq.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.eq.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.ne.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)
+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
+      parameter ( R12 = 1./12. )
+      dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+C
+      if(LMT.eq.0) then
+C Full constraint
+      do 100 i=1,IM
+      if(DC(i).eq.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 .lt. -da2) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      elseif(A6DA .gt. da2) then
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+      endif
+100   continue
+      elseif(LMT.eq.1) then
+C Semi-monotonic constraint
+      do 150 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. 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
+      elseif(LMT.eq.2) then
+      do 250 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250
+      fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
+      if(fmin.ge.0.) go to 250
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. 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
+      endif
+      return
+      end
+C
+      subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*)
+C
+      do 35 j=j1,j2
+      do 35 i=2,IMR
+35    CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
+C
+      do 45 j=j1,j2
+45    CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
+      return
+      end
+C
+      subroutine cosa(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+      JMR = JNP-1
+      do 55 j=2,JNP
+        ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
+55      cose(j) = cos(ph5)
+C
+      JEQ = (JNP+1) / 2
+      if(JMR .eq. 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 66 j=2,JMR
+66    cosp(j) = 0.5*(cose(j)+cose(j+1))
+      cosp(1) = 0.
+      cosp(JNP) = 0.
+      return
+      end
+C
+      subroutine cosc(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+C
+      phi = -0.5*PI
+      do 55 j=2,JNP-1
+      phi  =  phi + DP
+55    cosp(j) = cos(phi)
+        cosp(  1) = 0.
+        cosp(JNP) = 0.
+C
+      do 66 j=2,JNP
+        cose(j) = 0.5*(cosp(j)+cosp(j-1))
+66    CONTINUE
+C
+      do 77 j=2,JNP-1
+       cosp(j) = 0.5*(cose(j)+cose(j+1))
+77    CONTINUE
+      return
+      end
+C
+      SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp,
+     &                   cross,IC,NSTEP)
+C
+      parameter( tiny = 1.E-60 )
+      DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
+      logical cross
+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.eq.0) goto 50
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 50
+C
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 50
+C
+C Vertical filling...
+      do i=1,len
+      IF( Q(i,j1,1).LT.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 225 L = 2,NLAYM1
+      icr = 1
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 225
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) go to 225
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 225
+C
+      do i=1,len
+      IF( Q(I,j1,L).LT.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
+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.eq.0) goto 911
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 911
+C
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      if(icr.eq.0) goto 911
+C
+      DO  I=1,len
+      IF( Q(I,j1,L).LT.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.gt.IMR) then
+      write(6,*) 'IC=',IC,' STEP=',NSTEP,
+     &           ' Vertical filling pts=',ip
+      endif
+C
+      if(sum.gt.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)
+      dimension q(IMR,*),cosp(*),acosp(*)
+      icr = 0
+      do 65 j=j1+1,j2-1
+      DO 50 i=1,IMR-1
+      IF(q(i,j).LT.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
+50    continue
+      if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65
+      DO 55 i=2,IMR
+      IF(q(i,j).LT.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
+55    continue
+C *****************************************
+C i=1
+      i=1
+      IF(q(i,j).LT.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).LT.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
+C
+      do i=1,IMR
+      if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then
+      icr = 1
+      goto 80
+      endif
+      enddo
+C
+80    continue
+C
+      if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then
+      icr = 1
+      endif
+C
+      return
+      end
+C
+      subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+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 55 j=j1+1,j2-1
+      DO 55 i=1,IMR
+      IF(q(i,j).LT.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
+55    continue
+C
+      do i=1,imr
+      IF(q(i,j1).LT.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).LT.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).lt.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).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      if(q(1,JNP).lt.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).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      dimension q(IMR,*),qtmp(JNP,IMR)
+C
+      ipx = 0
+C Copy & swap direction for vectorization.
+      do 25 i=1,imr
+      do 25 j=j1,j2
+25    qtmp(j,i) = q(i,j)
+C
+      do 55 i=2,imr-1
+      do 55 j=j1,j2
+      if(qtmp(j,i).lt.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
+55    continue
+c
+      i=1
+      do 65 j=j1,j2
+      if(qtmp(j,i).lt.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
+65    continue
+      i=IMR
+      do 75 j=j1,j2
+      if(qtmp(j,i).lt.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
+75    continue
+C
+      if(ipx.ne.0) then
+      do 85 j=j1,j2
+      do 85 i=1,imr
+85    q(i,j) = qtmp(j,i)
+      else
+C
+C Poles.
+      if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1
+      endif
+      return
+      end
+C
+      subroutine zflip(q,im,km,nc)
+C This routine flip the array q (in the vertical).
+      real q(im,km,nc)
+C local dynamic array
+      real qtmp(im,km)
+C
+      do 4000 IC = 1, nc
+C
+      do 1000 k=1,km
+      do 1000 i=1,im
+      qtmp(i,k) = q(i,km+1-k,IC)
+1000  continue
+C
+      do 2000 i=1,im*km
+2000  q(i,1,IC) = qtmp(i,1)
+4000  continue
+      return
+      end
Index: LMDZ5/trunk/libf/prather.F
===================================================================
--- LMDZ5/trunk/libf/prather.F	(revision 1630)
+++ LMDZ5/trunk/libf/prather.F	(revision 1630)
@@ -0,0 +1,359 @@
+!
+! $Header$
+!
+      SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
+      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 "comconst.h"
+#include "comvert.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
+
+      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).lt.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).lt.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: LMDZ5/trunk/libf/pres2lev.F90
===================================================================
--- LMDZ5/trunk/libf/pres2lev.F90	(revision 1630)
+++ LMDZ5/trunk/libf/pres2lev.F90	(revision 1630)
@@ -0,0 +1,74 @@
+! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $
+!
+!******************************************************
+SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp)
+!
+! interpolation lineaire pour passer
+! a une nouvelle discretisation verticale pour
+! les variables de GCM
+! Francois Forget (01/1995)
+! MOdif remy roca 12/97 pour passer de pres2sig
+! Modif F.Codron 07/08 po en 3D
+!**********************************************************
+
+  IMPLICIT NONE
+
+!   Declarations:
+! ==============
+!
+!  ARGUMENTS
+!  """""""""
+  LOGICAL, INTENT(IN) :: ok_invertp
+  INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches
+  INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches
+  
+  REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille
+  REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille
+
+  INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal
+
+  REAL, INTENT(IN)  :: varo(ni*nj,lmo) ! var dans l'ancienne grille
+  REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille
+
+  REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo)
+
+! Autres variables
+! """"""""""""""""
+  INTEGER ::  ln ,lo, k
+  REAL    :: coef
+
+
+! Inversion de l'ordre des niveaux verticaux
+  IF (ok_invertp) THEN
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lmo+1-lo)
+        zvaro(k,lo)=varo(k,lmo+1-lo)
+      ENDDO
+    ENDDO
+  ELSE
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lo)
+        zvaro(k,lo)=varo(k,lo)
+      ENDDO
+    ENDDO
+  ENDIF 
+
+  DO ln=1,lmn
+    DO lo=1,lmo-1
+      DO k=1,ni*nj
+        IF (pn(k,ln) >= zpo(k,1) ) THEN
+          varn(k,ln) = varo(k,1)
+        ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN
+          varn(k,ln) = zvaro(k,lmo)
+        ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN
+          coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo))
+          varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo))
+        ENDIF
+         
+      ENDDO  
+    ENDDO
+  ENDDO                
+
+END SUBROUTINE pres2lev    
Index: LMDZ5/trunk/libf/pression.F
===================================================================
--- LMDZ5/trunk/libf/pression.F	(revision 1630)
+++ LMDZ5/trunk/libf/pression.F	(revision 1630)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+      SUBROUTINE pression( ngrid, ap, bp, ps, p )
+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 ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      DO    l    = 1, llmp1
+        DO  ij   = 1, ngrid
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+   
+      RETURN
+      END
Index: LMDZ5/trunk/libf/pression_loc.F
===================================================================
--- LMDZ5/trunk/libf/pression_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/pression_loc.F	(revision 1630)
@@ -0,0 +1,41 @@
+      SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
+      USE parallel
+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 ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
+      REAL 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: LMDZ5/trunk/libf/pression_p.F
===================================================================
--- LMDZ5/trunk/libf/pression_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/pression_p.F	(revision 1630)
@@ -0,0 +1,40 @@
+      SUBROUTINE pression_p( ngrid, ap, bp, ps, p )
+      USE parallel
+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 ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,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: LMDZ5/trunk/libf/profvert.def
===================================================================
--- LMDZ5/trunk/libf/profvert.def	(revision 1630)
+++ LMDZ5/trunk/libf/profvert.def	(revision 1630)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+nom_courbes=F
+titre=/home/hourdin/LMDZ4/libf/dyn3d
+xinf=0.
+xsup=669.
+yinf=6.5
+ysup=10.5
+axtxtx=sols
+axtxty=pressure (mb)
+pathcham=.
+lstyles=1 9999
+linewidth=.2
+lcolors=1 9999
+frwidth=.5
+repery0=T
+txtheight=2.5
+freecoord=/d2/hourdin/Ames/saison.def
+
+determination du champ physique
+xlength=195.
+ylength=105.
Index: LMDZ5/trunk/libf/psextbar.F
===================================================================
--- LMDZ5/trunk/libf/psextbar.F	(revision 1630)
+++ LMDZ5/trunk/libf/psextbar.F	(revision 1630)
@@ -0,0 +1,107 @@
+!
+! $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     5     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)
+   5  CONTINUE
+
+
+c    ....  correction pour     psexbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      psexbarxy( ij ) = psexbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/q_sat.F
===================================================================
--- LMDZ5/trunk/libf/q_sat.F	(revision 1630)
+++ LMDZ5/trunk/libf/q_sat.F	(revision 1630)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+c
+c
+
+      subroutine q_sat(np,temp,pres,qsat)
+c
+      IMPLICIT none
+c======================================================================
+c Autheur(s): Z.X. Li (LMD/CNRS)
+c  reecriture vectorisee par F. Hourdin.
+c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+c======================================================================
+c Arguments:
+c kelvin---input-R: temperature en Kelvin
+c millibar--input-R: pression en mb
+c
+c q_sat----output-R: vapeur d'eau saturante en kg/kg
+c======================================================================
+c
+      integer np
+      REAL temp(np),pres(np),qsat(np)
+c
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+c
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+c
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+c
+      REAL rtt
+      PARAMETER (rtt=273.16)
+c
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+
+      real zqsat
+      integer ip
+c
+C     ------------------------------------------------------------------
+c
+c
+
+      do ip=1,np
+
+c      write(*,*)'kelvin,millibar=',kelvin,millibar
+c       write(*,*)'temp,pres=',temp(ip),pres(ip)
+c
+         IF (temp(ip) .LE. rtt) THEN
+            r3es = r3ies
+            r4es = r4ies
+         ELSE
+            r3es = r3les
+            r4es = r4les
+         ENDIF
+c
+         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+         zqsat=MIN(0.5,ZQSAT)
+         zqsat=zqsat/(1.-retv *zqsat)
+c
+         qsat(ip)= zqsat
+c      write(*,*)'qsat=',qsat(ip)
+
+      enddo
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/qminimum_loc.F
===================================================================
--- LMDZ5/trunk/libf/qminimum_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/qminimum_loc.F	(revision 1630)
@@ -0,0 +1,107 @@
+      SUBROUTINE qminimum_loc( q,nq,deltap )
+      USE parallel
+      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 "comvert.h"
+c
+      INTEGER nq
+      REAL q(ijb_u:ije_u,llm,nq), deltap(ijb_u:ije_u,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      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
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
+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
+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
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO 1000 k = 1, llm
+      DO 1040 i = ijb, ije
+            if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+               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
+ 1040 CONTINUE
+ 1000 CONTINUE
+c$OMP END DO NOWAIT
+c$OMP BARRIER
+c --->  SYNCHRO OPENMP ICI
+
+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
+      iq = iq_vap
+c
+      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) .gt. 0.d0 ) then
+            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
+     &           deltap(i,k) / deltap(i,k-1)
+            q(i,k,iq)   =  seuil_vap  
+         endif
+      ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+c$OMP BARRIER
+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
+      nb_pump=0
+c$OMP DO SCHEDULE(STATIC)
+      DO i = ijb, ije
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), 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  
+!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+
+      IF (imprim.LE.100 .AND. nb_pump .GT. 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
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/qminimum_p.F
===================================================================
--- LMDZ5/trunk/libf/qminimum_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/qminimum_p.F	(revision 1630)
@@ -0,0 +1,107 @@
+      SUBROUTINE qminimum_p( q,nq,deltap )
+      USE parallel
+      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 "comvert.h"
+c
+      INTEGER nq
+      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      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
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+c
+      REAL SSUM
+      EXTERNAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+c$OMP THREADPRIVATE(imprim)
+      INTEGER ijb,ije
+      INTEGER Index_pump(ip1jmp1)
+      INTEGER nb_pump
+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
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO 1000 k = 1, llm
+      DO 1040 i = ijb, ije
+            if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+               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
+ 1040 CONTINUE
+ 1000 CONTINUE
+c$OMP END DO NOWAIT
+c$OMP BARRIER
+c --->  SYNCHRO OPENMP ICI
+
+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
+      iq = iq_vap
+c
+      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) .gt. 0.d0 ) then
+            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
+     &           deltap(i,k) / deltap(i,k-1)
+            q(i,k,iq)   =  seuil_vap  
+         endif
+      ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+c$OMP BARRIER
+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
+      nb_pump=0
+c$OMP DO SCHEDULE(STATIC)
+      DO i = ijb, ije
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), 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  
+!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+
+      IF (imprim.LE.100 .AND. nb_pump .GT. 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
+c
+      RETURN
+      END
Index: LMDZ5/trunk/libf/ran1.F
===================================================================
--- LMDZ5/trunk/libf/ran1.F	(revision 1630)
+++ LMDZ5/trunk/libf/ran1.F	(revision 1630)
@@ -0,0 +1,34 @@
+!
+! $Id: ran1.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      FUNCTION RAN1(IDUM)
+      DIMENSION R(97)
+      save r
+      save iff,ix1,ix2,ix3
+      PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6)
+      PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6)
+      PARAMETER (M3=243000,IA3=4561,IC3=51349)
+      DATA IFF /0/
+      IF (IDUM.LT.0.OR.IFF.EQ.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 11 J=1,97
+          IX1=MOD(IA1*IX1+IC1,M1)
+          IX2=MOD(IA2*IX2+IC2,M2)
+          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+11      CONTINUE
+        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.GT.97.OR.J.LT.1)PAUSE
+      RAN1=R(J)
+      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+      RETURN
+      END
Index: LMDZ5/trunk/libf/rotat.F
===================================================================
--- LMDZ5/trunk/libf/rotat.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotat.F	(revision 1630)
@@ -0,0 +1,58 @@
+!
+! $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  10 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
+  10  CONTINUE
+
+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: LMDZ5/trunk/libf/rotat_nfil.F
===================================================================
--- LMDZ5/trunk/libf/rotat_nfil.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotat_nfil.F	(revision 1630)
@@ -0,0 +1,49 @@
+!
+! $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  10 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
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/rotat_nfil_loc.F
===================================================================
--- LMDZ5/trunk/libf/rotat_nfil_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotat_nfil_loc.F	(revision 1630)
@@ -0,0 +1,52 @@
+      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
+      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  10 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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/rotat_nfil_p.F
===================================================================
--- LMDZ5/trunk/libf/rotat_nfil_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotat_nfil_p.F	(revision 1630)
@@ -0,0 +1,52 @@
+      SUBROUTINE rotat_nfil_p (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
+      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  10 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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/rotat_p.F
===================================================================
--- LMDZ5/trunk/libf/rotat_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotat_p.F	(revision 1630)
@@ -0,0 +1,63 @@
+      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
+      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  10 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
+  10  CONTINUE
+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: LMDZ5/trunk/libf/rotatf.F
===================================================================
--- LMDZ5/trunk/libf/rotatf.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotatf.F	(revision 1630)
@@ -0,0 +1,58 @@
+!
+! $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********************************************************************
+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  10 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
+  10  CONTINUE
+
+        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: LMDZ5/trunk/libf/rotatf_loc.F
===================================================================
--- LMDZ5/trunk/libf/rotatf_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotatf_loc.F	(revision 1630)
@@ -0,0 +1,69 @@
+      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
+      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  10 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
+  10  CONTINUE
+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: LMDZ5/trunk/libf/rotatf_p.F
===================================================================
--- LMDZ5/trunk/libf/rotatf_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotatf_p.F	(revision 1630)
@@ -0,0 +1,67 @@
+      SUBROUTINE rotatf_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
+      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,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  10 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
+  10  CONTINUE
+c$OMP END DO NOWAIT
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        CALL filtreg_p( rot, 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: LMDZ5/trunk/libf/rotatst.F
===================================================================
--- LMDZ5/trunk/libf/rotatst.F	(revision 1630)
+++ LMDZ5/trunk/libf/rotatst.F	(revision 1630)
@@ -0,0 +1,43 @@
+!
+! $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 5 l = 1,klevel
+c
+      DO 1 ij = 1, ip1jm - 1
+      rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   +
+     *                 x(ij +iip1, l )  -  x( ij,l )  )
+   1  CONTINUE
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim,l )
+   2  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ5/trunk/libf/serre.h
===================================================================
--- LMDZ5/trunk/libf/serre.h	(revision 1630)
+++ LMDZ5/trunk/libf/serre.h	(revision 1630)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!c
+!c
+!c..include serre.h
+!c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
+     &  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo ,     &
+     &  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: LMDZ5/trunk/libf/sort.F
===================================================================
--- LMDZ5/trunk/libf/sort.F	(revision 1630)
+++ LMDZ5/trunk/libf/sort.F	(revision 1630)
@@ -0,0 +1,37 @@
+!
+! $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).LE.p) THEN
+           k=j
+           p=d(j)
+         ENDIF
+        ENDDO
+
+       IF(k.ne.i) THEN
+         d(k)=d(i)
+         d(i)=p
+       ENDIF
+      ENDDO
+
+       RETURN
+       END
Index: LMDZ5/trunk/libf/sortvarc0.F
===================================================================
--- LMDZ5/trunk/libf/sortvarc0.F	(revision 1630)
+++ LMDZ5/trunk/libf/sortvarc0.F	(revision 1630)
@@ -0,0 +1,141 @@
+!
+! $Id: sortvarc0.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL 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 rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+      integer  ismin,ismax
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = REAL( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.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) = radsg *
+     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
+      ptot0  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot0  = SSUM(     llm, etotl, 1 )
+      ztot0  = SSUM(     llm, ztotl, 1 )
+      stot0  = SSUM(     llm, stotl, 1 )
+      rmsv   = SSUM(     llm, rmsvl, 1 )
+      ang0   = SSUM(     llm,  angl, 1 )
+
+      rday = REAL(INT (time ))
+c
+      PRINT 3500, itau, rday, heure, time
+      PRINT *, ptot0,etot0,ztot0,stot0,ang0
+
+3500   FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x 
+     *   ,'date',f10.5,4x,10("*"))
+      RETURN
+      END
+
Index: LMDZ5/trunk/libf/spline.F
===================================================================
--- LMDZ5/trunk/libf/spline.F	(revision 1630)
+++ LMDZ5/trunk/libf/spline.F	(revision 1630)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      subroutine spline(x,y,n,yp1,ypn,y2)
+     
+c
+     
+c     Routine to set up the interpolating function for a cubic spline
+     
+c     interpolation (see "Numerical Recipes" for details).
+     
+c
+	  implicit real (a-h,o-z)
+	  implicit integer (i-n)
+     
+      parameter(nllm=4096)
+     
+      dimension x(n),y(n),y2(n),u(nllm)
+     
+c
+c	write(6,*)(x(i),i=1,n)
+c	write(6,*)(y(i),i=1,n)
+     
+      if(yp1.gt.0.99E30) then
+c the lower boundary condition is set
+       y2(1)=0.
+c either to be "natural"
+       u(1)=0.
+     
+      else
+c or else to have a specified first
+       y2(1)=-0.5
+c derivative
+       u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+     
+      end if
+     
+      do 11 i=2,n-1
+c decomposition loop of the tridiagonal
+       sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+c algorithm. Y2 and U are used
+       p=sig*y2(i-1)+2.
+c for temporary storage of the decompo-
+       y2(i)=(sig-1.)/p
+c sed factors
+       u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
+     
+     . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+     
+ 11   continue
+     
+      if(ypn.gt.0.99E30) then
+c the upper boundary condition is set
+       qn=0.
+c either to be "natural"
+       un=0.
+     
+      else
+c or else to have a specified first
+       qn=0.5
+c derivative
+       un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+     
+      end if
+     
+      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+     
+      do 12 k=n-1,1,-1
+c this is the backsubstitution loop of
+       y2(k)=y2(k)*y2(k+1)+u(k)
+c the tridiagonal algorithm
+ 12   continue
+     
+c
+     
+      return
+     
+      end
+     
Index: LMDZ5/trunk/libf/splint.F
===================================================================
--- LMDZ5/trunk/libf/splint.F	(revision 1630)
+++ LMDZ5/trunk/libf/splint.F	(revision 1630)
@@ -0,0 +1,56 @@
+!
+! $Header$
+!
+     
+      SUBROUTINE splint(xa,ya,y2a,n,x,y)
+     
+c
+c     Routine to compute a cubic-spline interpolated value Y given the
+c     value of X, the arrays XA, YA and the 2nd derivative array Y2A
+c     computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details
+c
+     
+      IMPLICIT REAL (a-h,o-z)
+      IMPLICIT INTEGER (i-n)
+      DIMENSION xa(n),ya(n),y2a(n)
+     
+      kl0=1
+     
+      khi=n
+c means of bisection
+ 1    IF(khi-kl0.gt.1) THEN
+     
+       k=(khi+kl0)/2
+     
+       IF(xa(k).gt.x) THEN
+     
+        khi=k
+     
+       ELSE
+     
+        kl0=k
+     
+       END IF
+     
+       GO TO 1
+     
+      END IF
+c KL0 and KHI now bracket the X
+      h=xa(khi)-xa(kl0)
+     
+      IF(h.eq.0.0) STOP
+      a=(xa(khi)-x)/h
+c evaluation of cubic spline polynomial
+      b=(x-xa(kl0))/h
+     
+      y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2)
+     
+     ./6.
+     
+c
+     
+      RETURN
+     
+      END
+     
+
Index: LMDZ5/trunk/libf/startvar.F
===================================================================
--- LMDZ5/trunk/libf/startvar.F	(revision 1630)
+++ LMDZ5/trunk/libf/startvar.F	(revision 1630)
@@ -0,0 +1,1205 @@
+!
+! $Id: startvar.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      MODULE startvar
+#ifdef CPP_EARTH
+! This module is designed to work for Earth (and with ioipsl)
+    !
+    !
+    !      There are three ways to access data from the database of atmospheric data which 
+    !       can be used to initialize the model. This depends on the type of field which needs 
+    !       to be extracted. 
+    !       We will details the possible arguments to startget here :
+    !
+    !        - A 2D variable on the dynamical grid :
+    !           CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar )             
+    !
+    !        - A 1D variable on the physical grid :
+    !            CALL startget_phys1d(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         - A 3D variable on the dynamical grid :
+    !            CALL startget_dyn(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         There is special constraint on the atmospheric data base except that the 
+    !         the data needs to be in netCDF and the variables should have the the following 
+    !        names in the file :
+    !
+    !      'RELIEF'  : High resolution orography 
+    !       'ST'            : Surface temperature
+    !       'CDSW'     : Soil moisture
+    !       'Z'               : Surface geopotential
+    !       'SP'            : Surface pressure
+    !        'U'              : East ward wind
+    !        'V'              : Northward wind
+    !        'TEMP'             : Temperature
+    !        'R'             : Relative humidity
+    !      
+      USE ioipsl
+    !
+    !
+      IMPLICIT NONE
+    !
+    !
+      PRIVATE
+      public startget_phys2d, startget_phys1d, startget_dyn
+    !
+      INTEGER, SAVE :: fid_phys, fid_dyn
+      INTEGER, SAVE  :: iml_phys, iml_rel, iml_dyn
+      INTEGER, SAVE :: jml_phys,  jml_rel, jml_dyn
+      INTEGER, SAVE ::  llm_dyn, ttm_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lon_phys, lon_rug,
+     . lon_alb, lon_rel, lon_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lat_phys, lat_rug,
+     . lat_alb, lat_rel, lat_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:)  :: levdyn_ini
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: relief, zstd, zsig,
+     . zgam, zthe, zpic, zval
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rugo, masque, phis
+    !
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: tsol, qsol, psol_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)  ::   var_ana3d
+    !
+      CONTAINS
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in,
+     . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu )
+    !
+    !    There is a big mess with the size in logitude, should it be iml or iml+1.
+    !    I have chosen to use the iml+1 as an argument to this routine and we declare
+    !   internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. 
+    !  A convention is required.
+    !
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(iml,jml)
+      REAL, INTENT(in) :: val_exp
+      REAL, INTENT(in), optional :: masque_lu(iml,jml) 
+      LOGICAL interbar
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. 
+     .MINVAL(champ(:,:)).EQ.val_exp ) THEN
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('relief')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(relief)) THEN
+                      !
+                    if (present(masque_lu)) then
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar, masque_lu )
+                    else
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar)
+                    endif
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(relief) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 'STARTVAR module has been',
+     .' initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = relief(:,:)
+                  !
+              CASE ('rugosite')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(rugo)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(rugo) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = rugo(:,:)
+                  !
+              CASE ('masque')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(masque)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                     jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(masque) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .   'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = masque(:,:)
+                  !
+              CASE ('surfgeo')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = phis(:,:)
+                  !
+              CASE ('psol')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                      !
+                      CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = psol_dyn(:,:)
+                  !
+              CASE DEFAULT
+                  !
+                  WRITE(*,*) 'startget_phys2d'
+                  WRITE(*,*) 'No rule is present to extract variable', 
+     .                 varname(:LEN_TRIM(varname)),' from any data set'
+                  STOP
+                  !
+          END SELECT
+          !
+      ELSE
+          !
+          ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we
+          ! will catch them
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('surfgeo')
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      ALLOCATE(phis(iml,jml))
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  phis(:,:) = champ(:,:)
+                  !
+          END SELECT
+          !
+      ENDIF
+    !
+      END SUBROUTINE startget_phys2d
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 ,
+     ,   lat_in2 , interbar, masque_lu )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, intent(in), optional :: masque_lu(iml,jml)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      LOGICAL interbar2
+      REAL :: lev(1), date, dt,chmin,chmax
+      INTEGER :: itau(1), fid
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+      INTEGER :: iret
+      CHARACTER*25 title
+      REAL, ALLOCATABLE :: relief_hi(:,:)
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: tmp_var(:,:)
+      INTEGER, ALLOCATABLE :: tmp_int(:,:)
+    !
+      CHARACTER*120 :: orogfname
+      LOGICAL :: check=.TRUE.
+    !
+    !
+      orogfname = 'Relief.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Reading the high resolution orography'
+    !
+      CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)
+    !
+      ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret)
+    !
+      CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, 
+     .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp,
+     .      itau, date, dt, fid)
+    !
+      CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, 
+     . ttm_tmp, 1, 1, relief_hi)
+    !
+      CALL flinclo(fid)
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_rel))
+      ALLOCATE(lon_ini(iml_rel))
+
+      IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_rel(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_rel))
+      ALLOCATE(lat_ini(jml_rel))
+
+      IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_rel(1,:) 
+      ENDIF
+    !
+    !
+
+      title='RELIEF'
+
+      interbar2 = .FALSE.
+      CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini,
+     . lon_rad, lat_rad, relief_hi , interbar2  )
+
+      IF ( check ) WRITE(*,*) 'Computes all the parameters needed',
+     .' for the gravity wave drag code'
+    !
+    !    Allocate the data we need to put in the interpolated fields
+    !
+    !            RELIEF:  orographie moyenne
+      ALLOCATE(relief(iml,jml))
+    !            zphi :  orographie moyenne
+      ALLOCATE(phis(iml,jml))
+    !             zstd:  deviation standard de l'orographie sous-maille
+      ALLOCATE(zstd(iml,jml))
+    !             zsig:  pente de l'orographie sous-maille 
+      ALLOCATE(zsig(iml,jml))
+    !             zgam:  anisotropy de l'orographie sous maille
+      ALLOCATE(zgam(iml,jml))
+    !             zthe:  orientation de l'axe oriente dans la direction
+    !                    de plus grande pente de l'orographie sous maille
+      ALLOCATE(zthe(iml,jml))
+    !             zpic:  hauteur pics de la SSO
+      ALLOCATE(zpic(iml,jml))
+    !             zval:  hauteur vallees de la SSO
+      ALLOCATE(zval(iml,jml))
+    !             masque : Masque terre ocean
+      ALLOCATE(tmp_int(iml,jml))
+      ALLOCATE(masque(iml,jml))
+
+      masque = -99999.
+      if (present(masque_lu)) then
+        masque = masque_lu
+      endif
+    !
+      CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, 
+     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque)
+      phis = phis * 9.81
+    !
+!      masque(:,:) = REAL(tmp_int(:,:))
+    !
+    !  Compute surface roughness
+    !
+      IF ( check ) WRITE(*,*) 
+     .'Compute surface roughness induced by the orography'
+    !
+      ALLOCATE(rugo(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, tmp_var)
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          rugo(i,j) = tmp_var(i,j)
+        ENDDO
+        rugo(iml,j) = tmp_var(1,j)
+      ENDDO
+c
+cc   ***   rugo  n'est pas utilise pour l'instant  ******
+    !
+    !   Build land-sea mask
+    !
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_orog
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, 
+     .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar)
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, nbindex, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(nbindex)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. 
+     .MINVAL(champ(:)).EQ.val_exp ) THEN
+          SELECTCASE(varname)
+            CASE ('tsol')
+              IF ( .NOT.ALLOCATED(tsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2, lat_in2, interbar )
+              ENDIF
+              IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ)
+            CASE ('qsol')
+              IF ( .NOT.ALLOCATED(qsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ)
+            CASE ('psol')
+              IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ)
+            CASE ('zmea')
+              IF ( .NOT.ALLOCATED(relief)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ)
+            CASE ('zstd')
+              IF ( .NOT.ALLOCATED(zstd)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ)
+            CASE ('zsig')
+              IF ( .NOT.ALLOCATED(zsig)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .               jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ)
+            CASE ('zgam')
+              IF ( .NOT.ALLOCATED(zgam)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ)
+            CASE ('zthe')
+              IF ( .NOT.ALLOCATED(zthe)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ)
+            CASE ('zpic')
+              IF ( .NOT.ALLOCATED(zpic)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ)
+            CASE ('zval')
+              IF ( .NOT.ALLOCATED(zval)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ)
+            CASE ('rads')
+                  champ(:) = 0.0
+            CASE ('snow')
+                  champ(:) = 0.0
+cIM "slab" ocean
+            CASE ('tslab')
+                   champ(:) = 0.0
+            CASE ('seaice')
+                  champ(:) = 0.0
+            CASE ('rugmer')
+                  champ(:) = 0.001
+            CASE ('agsno')
+                  champ(:) = 50.0
+            CASE DEFAULT
+              WRITE(*,*) 'startget_phys1d'
+              WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+              STOP
+          END SELECT
+      ELSE
+        !
+        ! If we see tsol we catch it as we may need it for a 3D interpolation
+        !
+        SELECTCASE(varname)
+          CASE ('tsol')
+            IF ( .NOT.ALLOCATED(tsol)) THEN
+              ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) ))
+            ENDIF
+            CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol)
+        END SELECT
+      ENDIF
+      END SUBROUTINE startget_phys1d
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2,
+     .                 lon_in2, lat_in2 , interbar )
+
+      use inter_barxy_m, only: inter_barxy
+    !
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+!ac     REAL :: lev(1), date, dt
+      REAL :: date, dt
+      REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini
+!ac
+      INTEGER :: itau(1)
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+    !
+      CHARACTER*25 title
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:)
+    !
+      physfname = 'ECPHY.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp,
+     . ttm_tmp, fid_phys)
+    !
+      ALLOCATE (lat_phys(iml_phys,jml_phys))
+      ALLOCATE (lon_phys(iml_phys,jml_phys))
+!ac
+      ALLOCATE (levphys_ini(llm_tmp))
+    !
+!      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+!     . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, 
+!     . itau, date, dt, fid_phys)
+    !
+      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+     . llm_tmp, lon_phys, lat_phys, levphys_ini, ttm_tmp, 
+     . itau, date, dt, fid_phys)
+    !
+      DEALLOCATE (levphys_ini)
+!ac
+    !
+    ! Allocate the space we will need to get the data out of this file
+    !
+      ALLOCATE(var_ana(iml_phys, jml_phys))
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_phys))
+      ALLOCATE(lon_ini(iml_phys))
+
+      IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_phys(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_phys))
+      ALLOCATE(lat_ini(jml_phys))
+
+      IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_phys(1,:) 
+      ENDIF
+
+
+    !
+    !   We get the two standard varibales
+    !   Surface temperature
+    !
+      ALLOCATE(tsol(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+    !
+
+      CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, 
+     .llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='ST'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana , interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  ST $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy(lon_rad, lat_rad(:jml_phys -1), var_ana,
+     $       lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) 
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, tsol, iml-1, jml)
+    !
+    ! Soil moisture
+    !
+      ALLOCATE(qsol(iml,jml))
+      CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys,
+     . llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='CDSW'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  CDSW $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy(lon_rad, lat_rad(:jml_phys -1), var_ana,
+     $       lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) 
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+c
+        CALL gr_int_dyn(tmp_var, qsol, iml-1, jml)
+    !
+       CALL flinclo(fid_phys)
+    !
+      END SUBROUTINE start_init_phys
+    !
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+    !
+      SUBROUTINE startget_dyn(varname, lon_in, lat_in,
+     . pls, workvar, champ, val_exp, lon_in2, lat_in2 ,
+     ,  interbar )
+
+      use assert_eq_m, only: assert_eq
+    !
+    !   ARGUMENTS
+    !
+      CHARACTER(len=*), INTENT(in) :: varname
+      REAL, INTENT(in) :: lon_in(:) ! dim(iml)
+      REAL, INTENT(in) :: lat_in(:) ! dim(jml)
+      REAL, INTENT(in) :: lon_in2(:) ! dim(iml)
+      REAL, INTENT(in) :: lat_in2(:) ! dim(jml2)
+      REAL, INTENT(in) :: pls(:, :, :) ! dim(iml, jml, lml)
+      REAL, INTENT(in) :: workvar(:, :, :) ! dim(iml, jml, lml)
+      REAL, INTENT(inout) :: champ(:, :, :) ! dim(iml, jml, lml)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !    LOCAL
+    !
+      INTEGER :: il, ij, ii, iml, jml, lml, jml2
+      REAL :: xppn, xpps
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+C     -----------------------------
+
+      iml = assert_eq((/size(lon_in), size(pls, 1), size(workvar, 1),
+     $     size(champ, 1), size(lon_in2)/), "startget_dyn iml")
+      jml = assert_eq(size(lat_in), size(pls, 2), size(workvar, 2),
+     $     size(champ, 2), "startget_dyn jml")
+      lml = assert_eq(size(pls, 3), size(workvar, 3), size(champ, 3),
+     $     "startget_dyn lml")
+      jml2 = size(lat_in2)
+
+      IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND.
+     . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN
+        !
+        SELECTCASE(varname)
+          CASE ('u')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .          lon_in2,lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('U', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ,interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('v')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, 
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('V', iml, jml, lml, lon_in, 
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('t')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 ,interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+ 
+          CASE ('tpot')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 ,
+     .            lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) )
+     .                                    THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = champ(ii,ij,il) * cpp 
+     .                                 / workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute potential temperature as the'
+              WRITE(*,*)'Exner function is missing or constant.'
+              STOP
+            ENDIF
+          CASE ('q')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in,
+     .        jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) 
+     .                                     THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = 0.01 * champ(ii,ij,il) *
+     .                                       workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              WHERE ( champ .LT. 0.) champ = 1.0E-10
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute specific humidity as the'
+              WRITE(*,*)'saturated humidity is missing or constant.'
+              STOP
+            ENDIF
+          CASE DEFAULT
+            WRITE(*,*) 'startget_dyn'
+            WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+            STOP
+          END SELECT
+      ENDIF
+      END SUBROUTINE startget_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 ,
+     ,             lat_in2 , interbar )
+    !
+      use inter_barxy_m, only: inter_barxy
+
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1)
+      INTEGER :: i, j
+      integer :: iret
+    !
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:)
+      REAL, ALLOCATABLE :: xppn(:), xpps(:)
+      LOGICAL :: allo
+    !
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+      CHARACTER*25 title
+
+    !
+      physfname = 'ECDYN.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn,
+     .                            ttm_dyn, fid_dyn)
+      IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, 
+     .                                         llm_dyn, ttm_dyn
+    !
+      ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (levdyn_ini(llm_dyn), stat=iret)
+    !
+      CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn,
+     . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, 
+     . itau, date, dt, fid_dyn)
+    !
+
+      allo = allocated (var_ana)
+      if (allo) then
+        DEALLOCATE(var_ana, stat=iret)
+      endif
+      ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret)
+
+      allo = allocated (lon_rad)
+      if (allo) then
+        DEALLOCATE(lon_rad, stat=iret)
+      endif
+
+      ALLOCATE(lon_rad(iml_dyn), stat=iret)
+      ALLOCATE(lon_ini(iml_dyn))
+       
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+
+      ALLOCATE(z(iml, jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+c
+      title='Z'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+c
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  Z  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy(lon_rad, lat_rad(:jml_dyn -1), var_ana,
+     $       lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .               iml-1, jml, lon_in, lat_in, tmp_var)
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, z, iml-1, jml)
+    !
+      ALLOCATE(psol_dyn(iml, jml))
+    !
+      CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+
+       title='SP'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  SP  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy(lon_rad, lat_rad(:jml_dyn -1), var_ana,
+     $       lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .             iml-1, jml, lon_in, lat_in, tmp_var  )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml)
+    !
+      IF ( .NOT.ALLOCATED(tsol)) THEN
+    !   These variables may have been allocated by the need to 
+    !   create a start field for them or by the varibale
+    !   coming out of the restart file. In case we dor have it we will initialize it.
+    !
+        CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2,
+     .                 lat_in2 , interbar )
+      ELSE
+        IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN
+        WRITE(*,*) 'start_init_dyn :'
+        WRITE(*,*) 'The temperature field we have does not ',
+     .             'have the right size'
+        STOP
+      ENDIF
+      ENDIF
+      IF ( .NOT.ALLOCATED(phis)) THEN
+            !
+            !    These variables may have been allocated by the need to create a start field for them or by the varibale
+            !     coming out of the restart file. In case we dor have it we will initialize it.
+            !
+        CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 ,
+     .      lat_in2 , interbar )
+            !
+      ELSE
+            !
+          IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN
+                !
+              WRITE(*,*) 'start_init_dyn :'
+              WRITE(*,*) 'The orography field we have does not ',
+     .                   ' have the right size'
+              STOP
+          ENDIF
+            !
+      ENDIF
+    !
+    !     PSOL is computed in Pascals
+    !
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) 
+     .                    /287.0/tsol(i,j))
+        ENDDO
+        psol_dyn(iml,j) = psol_dyn(1,j)
+      ENDDO
+    !
+    !
+      ALLOCATE(xppn(iml-1))
+      ALLOCATE(xpps(iml-1)) 
+    !
+      DO  i   = 1, iml-1
+        xppn(i) = aire( i,1) * psol_dyn( i,1)
+        xpps(i) = aire( i,jml) * psol_dyn( i,jml)
+      ENDDO
+    !
+      DO i   = 1, iml
+        psol_dyn(i,1    )  = SUM(xppn)/apoln
+        psol_dyn(i,jml)  = SUM(xpps)/apols
+      ENDDO
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in,
+     .      lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar )
+    !
+    !    This subroutine gets a variables from a 3D file and does the interpolations needed
+    !
+    !
+      use inter_barxy_m, only: inter_barxy
+
+    !    ARGUMENTS
+    !
+      CHARACTER*(*) :: varname
+      INTEGER :: iml, jml, lml, jml2
+      REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml)
+      REAL :: lon_in2(iml) , lat_in2(jml2)
+      REAL :: var3d(iml, jml, lml)
+      LOGICAL interbar
+      real chmin,chmax
+    !
+    !  LOCAL
+    !
+      CHARACTER*25 title
+      INTEGER :: ii, ij, il, jsort,i,j,l
+      REAL :: bx, by
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:)
+      REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:)
+      REAL, ALLOCATABLE :: ax(:), ay(:), yder(:)
+!       REAL, ALLOCATABLE :: varrr(:,:,:)
+      INTEGER, ALLOCATABLE :: lind(:)
+    !
+      LOGICAL :: check = .TRUE.
+    !
+      IF ( .NOT. ALLOCATED(var_ana3d)) THEN
+          ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn))
+      ENDIF
+!          ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn))
+    !
+    !
+      IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ',
+     .  ' field.', fid_dyn
+      IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn,
+     .                        llm_dyn,ttm_dyn
+    !
+      CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, 
+     . ttm_dyn, 1, 1, var_ana3d)
+    !
+      IF ( check) WRITE(*,*) 'Allocating space for the interpolation',
+     . iml, jml, llm_dyn
+    !
+      ALLOCATE(lon_rad(iml_dyn))
+      ALLOCATE(lon_ini(iml_dyn))
+
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      ALLOCATE(lev_dyn(llm_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+      CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, 
+     . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d  ,
+     ,  interbar                                                   )
+
+      ALLOCATE(var_tmp2d(iml-1, jml))
+      ALLOCATE(var_tmp3d(iml, jml, llm_dyn))
+      ALLOCATE(ax(llm_dyn))
+      ALLOCATE(ay(llm_dyn))
+      ALLOCATE(yder(llm_dyn))
+      ALLOCATE(lind(llm_dyn))
+    !
+ 
+      DO il=1,llm_dyn
+        !
+      IF( interbar )  THEN
+       IF( il.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour ', varname
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+       ENDIF
+       CALL inter_barxy(lon_rad, lat_rad(:jml_dyn -1),
+     $      var_ana3d(:,:,il), lon_in2(:iml-1), lat_in2, var_tmp2d) 
+      ELSE
+       CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, 
+     .  var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d )
+      ENDIF
+        !
+        CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml)
+        !
+       ENDDO
+       !
+          DO il=1,llm_dyn
+            lind(il) = llm_dyn-il+1
+          ENDDO
+    !
+c
+c  ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere
+c                    vers  le  sol  ...
+c
+      DO ij=1,jml
+        DO ii=1,iml-1
+          !
+          ax(:) = lev_dyn(lind(:)) 
+          ay(:) = var_tmp3d(ii, ij, lind(:))
+          !
+         
+          CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder)
+          !
+          DO il=1,lml
+            bx = pls_in(ii, ij, il)
+            CALL SPLINT(ax, ay, yder, llm_dyn, bx, by)
+            var3d(ii, ij, il) = by
+          ENDDO
+          !
+        ENDDO
+        var3d(iml, ij, :) = var3d(1, ij, :) 
+      ENDDO
+
+      do il=1,lml
+        call minmax(iml*jml,var3d(1,1,il),chmin,chmax)
+      SELECTCASE(varname)
+       CASE('U')
+          WRITE(*,*) ' U  min max l ',il,chmin,chmax
+       CASE('V')
+          WRITE(*,*) ' V  min max l ',il,chmin,chmax
+       CASE('TEMP')
+          WRITE(*,*) ' TEMP  min max l ',il,chmin,chmax
+       CASE('R')
+          WRITE(*,*) ' R  min max l ',il,chmin,chmax
+      END SELECT
+           enddo
+
+      DEALLOCATE(lon_rad)
+      DEALLOCATE(lon_ini)
+      DEALLOCATE(lat_rad)
+      DEALLOCATE(lat_ini)
+      DEALLOCATE(lev_dyn)
+      DEALLOCATE(var_tmp2d)
+      DEALLOCATE(var_tmp3d)
+      DEALLOCATE(ax)
+      DEALLOCATE(ay)
+      DEALLOCATE(yder)
+      DEALLOCATE(lind)
+
+    !
+      RETURN
+    !
+      END SUBROUTINE start_inter_3d
+    !
+#endif
+! of #ifdef CPP_EARTH
+      END MODULE startvar
Index: LMDZ5/trunk/libf/temps.h
===================================================================
--- LMDZ5/trunk/libf/temps.h	(revision 1630)
+++ LMDZ5/trunk/libf/temps.h	(revision 1630)
@@ -0,0 +1,25 @@
+!
+! $Id: temps.h 1279 2009-12-10 09:02:56Z fairhead $
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! jD_ref = jour julien de la date de reference (lancement de l'experience)
+! hD_ref = "heure" julienne de la date de reference
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref,   &
+     &             itau_dyn, itau_phy, jD_ref, jH_ref, calend
+
+      INTEGER   itaufin
+      INTEGER itau_dyn, itau_phy
+      INTEGER day_ini, day_end, annee_ref, day_ref
+      REAL      dt, jD_ref, jH_ref
+      CHARACTER (len=10) :: calend
+
+!$OMP THREADPRIVATE(/temps/)
+!-----------------------------------------------------------------------
Index: LMDZ5/trunk/libf/test_period.F
===================================================================
--- LMDZ5/trunk/libf/test_period.F	(revision 1630)
+++ LMDZ5/trunk/libf/test_period.F	(revision 1630)
@@ -0,0 +1,115 @@
+!
+! $Header$
+!
+      SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
+      USE infotrac, ONLY : nqtot
+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
+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).NE.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).NE.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).ne.teta(1,l)
+     s     .or.teta(ip1jm+ij,l).ne.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).NE.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).NE.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).NE.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).NE.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).ne.p(1,l)
+     s     .or.p(ip1jm+ij,l).ne.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: LMDZ5/trunk/libf/times.F90
===================================================================
--- LMDZ5/trunk/libf/times.F90	(revision 1630)
+++ LMDZ5/trunk/libf/times.F90	(revision 1630)
@@ -0,0 +1,248 @@
+module times
+  integer,private,save :: Last_Count=0
+  real, private,save :: Last_cpuCount=0
+  logical, private,save :: AllTimer_IsActive=.false.
+  
+  integer, parameter :: nb_timer = 4
+  integer, parameter :: timer_caldyn  = 1
+  integer, parameter :: timer_vanleer = 2
+  integer, parameter :: timer_dissip = 3
+  integer, parameter :: timer_physic = 4
+  integer, parameter :: stopped = 1
+  integer, parameter :: running = 2
+  integer, parameter :: suspended = 3 
+  
+  integer :: max_size
+  real,    allocatable, dimension(:,:,:) :: timer_table
+  real,    allocatable, dimension(:,:,:) :: timer_table_sqr 
+  integer, allocatable, dimension(:,:,:) :: timer_iteration
+  real,    allocatable, dimension(:,:,:) :: timer_average
+  real,    allocatable, dimension(:,:,:) :: timer_delta
+  real,    allocatable,dimension(:) :: timer_running, last_time
+  integer, allocatable,dimension(:) :: timer_state
+  
+  contains
+  
+  subroutine init_timer
+    use parallel
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"
+    
+    max_size=jjm+1
+    allocate(timer_table(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_average(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_delta(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_running(nb_timer))
+    allocate(timer_state(nb_timer))
+    allocate(last_time(nb_timer))
+    
+    timer_table(:,:,:)=0
+    timer_table_sqr(:,:,:)=0
+    timer_iteration(:,:,:)=0
+    timer_average(:,:,:)=0
+    timer_delta(:,:,:)=0
+    timer_state(:)=stopped      
+  end subroutine init_timer
+  
+  subroutine start_timer(no_timer)
+    implicit none
+    integer :: no_timer
+    
+    if (AllTimer_IsActive) then
+    
+      if (timer_state(no_timer)/=stopped) then
+        stop 'start_timer :: timer is already running or suspended'
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      timer_running(no_timer)=0
+      call cpu_time(last_time(no_timer))
+    
+    endif
+    
+  end subroutine start_timer
+  
+  subroutine suspend_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=running) then
+        stop 'suspend_timer :: timer is not running'
+      else
+        timer_state(no_timer)=suspended
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    endif
+  end subroutine suspend_timer
+  
+  subroutine resume_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=suspended) then
+        stop 'resume_timer :: timer is not suspended'
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      call cpu_time(last_time(no_timer))
+    endif
+    
+  end subroutine resume_timer
+
+  subroutine stop_timer(no_timer)
+    use parallel
+    implicit none
+    integer :: no_timer
+    integer :: N
+    real :: V,V2
+    
+    if (AllTimer_IsActive) then
+       
+      if (timer_state(no_timer)/=running) then
+        stop 'stop_timer :: timer is not running'
+      else
+        timer_state(no_timer)=stopped
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    
+      timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)
+      timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2
+      timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1
+      timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank)
+      if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then
+        N=timer_iteration(jj_nb,no_timer,mpi_rank)
+	V2=timer_table_sqr(jj_nb,no_timer,mpi_rank)
+	V=timer_table(jj_nb,no_timer,mpi_rank)
+	timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) 
+      else
+        timer_delta(jj_nb,no_timer,mpi_rank)=0
+      endif
+    endif
+    
+  end subroutine stop_timer
+   
+  subroutine allgather_timer
+    use parallel
+    implicit none
+#ifdef CPP_MPI    
+    include 'mpif.h'
+#endif
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:) :: tmp_table
+
+    IF (using_mpi) THEN    
+   
+      if (AllTimer_IsActive) then
+    
+    
+      allocate(tmp_table(max_size,nb_timer))
+    
+      data_size=max_size*nb_timer
+    
+      tmp_table(:,:)=timer_table(:,:,mpi_rank)
+#ifdef CPP_MPI 
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif
+      tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif    
+      deallocate(tmp_table)
+    
+      endif
+      
+    ENDIF ! using_mpi
+    
+  end subroutine allgather_timer
+  
+  subroutine allgather_timer_average
+    use parallel
+    implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:),target :: tmp_table
+    integer, allocatable,dimension(:,:),target :: tmp_iter
+    integer :: istats
+
+    IF (using_mpi) THEN
+        
+      if (AllTimer_IsActive) then
+    
+      allocate(tmp_table(max_size,nb_timer))
+      allocate(tmp_iter(max_size,nb_timer))
+   
+      data_size=max_size*nb_timer
+
+      tmp_table(:,:)=timer_average(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif
+      tmp_table(:,:)=timer_delta(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif
+      tmp_iter(:,:)=timer_iteration(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr)
+#endif    
+      deallocate(tmp_table)
+    
+      endif
+      
+    ENDIF  ! using_mp�
+  end subroutine allgather_timer_average
+  
+  subroutine InitTime
+  implicit none
+    integer :: count,count_rate,count_max
+    
+    AllTimer_IsActive=.TRUE.
+    if (AllTimer_IsActive) then
+      call system_clock(count,count_rate,count_max)
+      call cpu_time(Last_cpuCount)
+      Last_Count=count
+    endif
+  end subroutine InitTime
+  
+  function DiffTime()
+  implicit none
+    double precision :: DiffTime
+    integer :: count,count_rate,count_max
+  
+    call system_clock(count,count_rate,count_max)
+    if (Count>=Last_Count) then
+      DiffTime=(1.*(Count-last_Count))/count_rate
+    else
+      DiffTime=(1.*(Count-last_Count+Count_max))/count_rate
+    endif
+    Last_Count=Count 
+  end function DiffTime
+  
+  function DiffCpuTime()
+  implicit none
+    real :: DiffCpuTime
+    real :: Count
+    
+    call cpu_time(Count)
+    DiffCpuTime=Count-Last_cpuCount
+    Last_cpuCount=Count 
+  end function DiffCpuTime
+
+end module times
Index: LMDZ5/trunk/libf/top_bound_loc.F
===================================================================
--- LMDZ5/trunk/libf/top_bound_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/top_bound_loc.F	(revision 1630)
@@ -0,0 +1,165 @@
+      SUBROUTINE top_bound_loc( vcov,ucov,teta,masse, du,dv,dh )
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.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=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL ucov(iip1,jjb_u:jje_u,llm),vcov(iip1,jjb_v:jje_v,llm)
+      REAL teta(iip1,jjb_u:jje_u,llm)
+      REAL masse(iip1,jjb_u:jje_u,llm)
+      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 NDAMP
+      PARAMETER (NDAMP=4)
+      integer i	
+      REAL,SAVE :: rdamp(llm)
+!     &   (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) 
+      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
+! couche eponge dans les 4 dernieres couches du modele
+             rdamp(:)=0.
+             rdamp(llm)=tau_top_bound
+             rdamp(llm-1)=tau_top_bound/2.
+             rdamp(llm-2)=tau_top_bound/4.
+             rdamp(llm-3)=tau_top_bound/8.
+         else if (iflag_top_bound == 2) then
+! couce eponge dans toutes les couches de pression plus faible que
+! 100 fois la pression de la derniere couche
+             rdamp(:)=tau_top_bound
+     s       *max(presnivs(llm)/presnivs(:)-0.01,0.)
+         endif
+         first=.false.
+         print*,'TOP_BOUND rdamp=',rdamp
+c$OMP END MASTER
+c$OMP BARRIER
+      endif
+
+
+      CALL massbar_loc(masse,massebx,masseby)
+C  CALCUL DES CHAMPS EN MOYENNE ZONALE:
+
+      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
+! Rm: on peut travailler directement avec la moyenne zonale de vcov
+! plutot qu'avec celle de v car le coefficient cv qui relie les deux
+! ne varie qu'en latitude
+            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   
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        do j=jjb,jje
+          do i=1,iip1
+            dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l))
+          enddo
+        enddo
+      enddo
+c$OMP END DO NOWAIT
+
+      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
+
+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
+
+C   AMORTISSEMENTS LINEAIRES:
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        do j=jjb,jje
+          do i=1,iip1
+            du(i,j,l)=du(i,j,l)
+     s               -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+            dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l))
+          enddo
+       enddo
+      enddo
+c$OMP END DO NOWAIT
+      
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/top_bound_p.F
===================================================================
--- LMDZ5/trunk/libf/top_bound_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/top_bound_p.F	(revision 1630)
@@ -0,0 +1,161 @@
+      SUBROUTINE top_bound_p( vcov,ucov,teta,masse, du,dv,dh )
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.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=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),teta(iip1,jjp1,llm)
+      REAL masse(iip1,jjp1,llm)
+      REAL dv(iip1,jjm,llm),du(iip1,jjp1,llm),dh(iip1,jjp1,llm)
+
+c   Local:
+c   ------
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm
+      REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm)
+      
+      INTEGER NDAMP
+      PARAMETER (NDAMP=4)
+      integer i	
+      REAL,SAVE :: rdamp(llm)
+!     &   (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) 
+      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
+! couche eponge dans les 4 dernieres couches du modele
+             rdamp(:)=0.
+             rdamp(llm)=tau_top_bound
+             rdamp(llm-1)=tau_top_bound/2.
+             rdamp(llm-2)=tau_top_bound/4.
+             rdamp(llm-3)=tau_top_bound/8.
+         else if (iflag_top_bound == 2) then
+! couce eponge dans toutes les couches de pression plus faible que
+! 100 fois la pression de la derniere couche
+             rdamp(:)=tau_top_bound
+     s       *max(presnivs(llm)/presnivs(:)-0.01,0.)
+         endif
+         first=.false.
+         print*,'TOP_BOUND rdamp=',rdamp
+c$OMP END MASTER
+c$OMP BARRIER
+      endif
+
+
+      CALL massbar_p(masse,massebx,masseby)
+C  CALCUL DES CHAMPS EN MOYENNE ZONALE:
+
+      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
+! Rm: on peut travailler directement avec la moyenne zonale de vcov
+! plutot qu'avec celle de v car le coefficient cv qui relie les deux
+! ne varie qu'en latitude
+            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   
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        do j=jjb,jje
+          do i=1,iip1
+            dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l))
+          enddo
+        enddo
+      enddo
+c$OMP END DO NOWAIT
+
+      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
+
+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
+
+C   AMORTISSEMENTS LINEAIRES:
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        do j=jjb,jje
+          do i=1,iip1
+            du(i,j,l)=du(i,j,l)
+     s               -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+            dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l))
+          enddo
+       enddo
+      enddo
+c$OMP END DO NOWAIT
+      
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/tourabs.F
===================================================================
--- LMDZ5/trunk/libf/tourabs.F	(revision 1630)
+++ LMDZ5/trunk/libf/tourabs.F	(revision 1630)
@@ -0,0 +1,98 @@
+      SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Modif:  I. Musat (28/10/04)
+c   -------
+c   adaptation du code tourpot.F pour le calcul de la vorticite absolue
+c   cf. P. Le Van
+c
+c   Objet: 
+c   ------
+c
+c    *******************************************************************
+c    .............  calcul de la vorticite absolue     .................
+c    *******************************************************************
+c
+c     ntetaSTD, vcov,ucov      sont des argum. d'entree pour le s-pg .
+c             vorabs            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "comconst.h"
+c
+      INTEGER ntetaSTD
+      REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD )
+      REAL vorabs( ip1jm,ntetaSTD )
+c
+c variables locales
+      INTEGER l, ij, i, j
+      REAL  rot( ip1jm,ntetaSTD )
+
+
+
+c  ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,ntetaSTD
+
+      DO 2 i = 1, iip1
+      DO 2 j = 1, jjm
+c
+       ij=i+(j-1)*iip1
+       IF(ij.LE.ip1jm - 1) THEN
+c
+        IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR.
+     $     cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN
+         rot( ij,l ) = 0.
+         continue
+        ELSE
+         rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/
+     $                 (2.*pi*RAD*cos(rlatv(j)))*REAL(iim)
+     $                +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/
+     $                 (pi*RAD)*(REAL(jjm)-1.)
+c
+        ENDIF
+       ENDIF !(ij.LE.ip1jm - 1) THEN
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, ntetaSTD
+
+      DO 6 ij = 1, ip1jm - 1
+      vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) )
+   6  CONTINUE
+
+c    ..... correction pour  vorabs( iip1,j,l)  .....
+c    ....   vorabs(iip1,j,l)= vorabs(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorabs( ij,l ) = vorabs( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/tourpot.F
===================================================================
--- LMDZ5/trunk/libf/tourpot.F	(revision 1630)
+++ LMDZ5/trunk/libf/tourpot.F	(revision 1630)
@@ -0,0 +1,81 @@
+!
+! $Header$
+!
+      SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ip1jm,llm )
+      REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm )
+      REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm )
+
+      INTEGER l, ij
+
+
+
+
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,llm
+
+      DO 2 ij = 1, ip1jm - 1
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, llm
+
+      DO 6 ij = 1, ip1jm - 1
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/tourpot_loc.F
===================================================================
--- LMDZ5/trunk/libf/tourpot_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/tourpot_loc.F	(revision 1630)
@@ -0,0 +1,95 @@
+      SUBROUTINE tourpot_loc ( vcov, ucov, massebxy, vorpot )
+      USE parallel
+      USE mod_filtreg_p
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ijb_v:ije_v,llm )
+      REAL vcov( ijb_v:ije_v,llm ),ucov( ijb_u:ije_u,llm )
+      REAL massebxy( ijb_v:ije_v,llm ),vorpot( ijb_v:ije_v,llm )
+
+      INTEGER l, ij ,ije,ijb,jje,jjb
+
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      
+      if (pole_nord) ijb=ij_begin
+      
+      
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+
+      if (pole_sud)  ije=ij_end-iip1-1
+      DO 2 ij = ijb, ije 
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      if (pole_sud)  ije=ij_end-iip1
+     
+      DO 3 ij = ijb+iip1-1, ije, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+      jjb=jj_begin-1
+      jje=jj_end
+      
+      if (pole_nord) jjb=jjb+1
+      if (pole_sud)  jje=jje-1
+      CALL  filtreg_p( rot, jjb_v,jje_v,jjb,jje,jjm, llm, 
+     &                 2, 1, .FALSE., 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO 10 l = 1, llm
+      
+      if (pole_sud)  ije=ij_end-iip1-1  
+      
+      DO 6 ij = ijb, ije
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      if (pole_sud)  ije=ij_end-iip1
+      DO 8 ij = ijb+iip1-1, ije, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/traceurpole.F
===================================================================
--- LMDZ5/trunk/libf/traceurpole.F	(revision 1630)
+++ LMDZ5/trunk/libf/traceurpole.F	(revision 1630)
@@ -0,0 +1,70 @@
+!
+! $Id: traceurpole.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+          subroutine traceurpole(q,masse)
+
+      USE control_mod
+
+          implicit none
+      
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.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: LMDZ5/trunk/libf/tracstoke.h
===================================================================
--- LMDZ5/trunk/libf/tracstoke.h	(revision 1630)
+++ LMDZ5/trunk/libf/tracstoke.h	(revision 1630)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: LMDZ5/trunk/libf/ugeostr.F
===================================================================
--- LMDZ5/trunk/libf/ugeostr.F	(revision 1630)
+++ LMDZ5/trunk/libf/ugeostr.F	(revision 1630)
@@ -0,0 +1,69 @@
+!
+! $Id: ugeostr.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      subroutine ugeostr(phi,ucov)
+
+
+c  Calcul du vent covariant geostrophique a partir du champs de
+c  geopotentiel en supposant que le vent au sol est nul.
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+      real um(jjm,llm),fact,u(iip1,jjm,llm)
+      integer i,j,l
+
+      real zlat
+
+      um(:,:)=0 ! initialize um()
+
+      DO j=1,jjm
+
+         if (abs(sin(rlatv(j))).lt.1.e-4) then
+             zlat=1.e-4
+         else
+             zlat=rlatv(j)
+         endif
+         fact=cos(zlat)
+         fact=fact*fact
+         fact=fact*fact
+         fact=fact*fact
+         fact=(1.-fact)/
+     s    (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j)))
+         fact=-fact/rad
+         DO l=1,llm
+            DO i=1,iim
+               u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
+               um(j,l)=um(j,l)+u(i,j,l)/REAL(iim)
+            ENDDO
+         ENDDO
+      ENDDO
+      call dump2d(jjm,llm,um,'Vent-u geostrophique')
+
+c
+c-----------------------------------------------------------------------
+c   calcul des champ de vent:
+c   -------------------------
+
+      DO 301 l=1,llm
+         DO 302 i=1,iip1
+            ucov(i,1,l)=0.
+            ucov(i,jjp1,l)=0.
+302      CONTINUE
+         DO 304 j=2,jjm
+            DO 305 i=1,iim
+               ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j)
+305         CONTINUE
+            ucov(iip1,j,l)=ucov(1,j,l)
+304      CONTINUE
+301   CONTINUE
+
+      print*,301
+
+      return
+      end
Index: LMDZ5/trunk/libf/vitvert.F
===================================================================
--- LMDZ5/trunk/libf/vitvert.F	(revision 1630)
+++ LMDZ5/trunk/libf/vitvert.F	(revision 1630)
@@ -0,0 +1,52 @@
+!
+! $Header$
+!
+      SUBROUTINE vitvert ( convm , w )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ip1jmp1,llm),convm(ip1jmp1,llm)
+      INTEGER   l, ij
+
+
+
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = 1,ip1jmp1
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+
+      DO 5 ij  = 1,ip1jmp1
+      w(ij,1)  = 0.
+5     CONTINUE
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/vitvert_loc.F
===================================================================
--- LMDZ5/trunk/libf/vitvert_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/vitvert_loc.F	(revision 1630)
@@ -0,0 +1,56 @@
+      SUBROUTINE vitvert_loc ( convm , w )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ijb_u:ije_u,llm),convm(ijb_u:ije_u,llm)
+      INTEGER   l, ij,ijb,ije
+
+
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_sud) ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = ijb,ije
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+c$OMP END DO
+c$OMP MASTER
+      DO 5 ij  = ijb,ije
+      w(ij,1)  = 0.
+5     CONTINUE
+c$OMP END MASTER
+c$OMP BARRIER
+      RETURN
+      END
Index: LMDZ5/trunk/libf/vlsplt_loc.F
===================================================================
--- LMDZ5/trunk/libf/vlsplt_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/vlsplt_loc.F	(revision 1630)
@@ -0,0 +1,910 @@
+      SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x)
+
+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
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL u_m( ijb_u:ije_u,llm ),pbarv( iip1,jjb_v:jje_v,llm)
+      REAL q(ijb_u:ije_u,llm)
+      REAL w(ijb_u:ije_u,llm)
+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)
+
+      Logical extremum
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      REAL z1,z2,z3
+
+      INTEGER ijb,ije,ijb_x,ije_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.gt.-1.e-5) THEN
+c       IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
+         DO l = 1, llm
+            
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=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
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+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)-q(ij,l)
+            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).gt.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
+c	 print*,'Bouclage en iip1'
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+c	print*,'Cumule ....'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+c	print*,'masse(',ij,')=',masse(ij,l)
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
+          ENDIF
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+c	stop
+
+c	go to 9999
+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).lt.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).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+c$OMP END DO NOWAIT
+cym      ENDIF  ! n0.gt.0 
+9999    continue
+
+
+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
+
+c   calcul des tENDances
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+1,ije
+            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=ijb+iip1-1,ije,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+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
+
+
+      SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL masse_adv_v( ijb_v:ije_v,llm)
+      REAL q(ijb_u:ije_u,llm), dq( ijb_u:ije_u,llm)
+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,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical extremum,first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+      SAVE first,testcpu
+c$OMP THREADPRIVATE(first,testcpu)
+
+      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)
+c
+c
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+      INTEGER ijb,ije
+
+      IF(first) THEN
+c         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)
+        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)
+        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)-q(ij+iip1,l)
+         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)
+        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)-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     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+      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).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+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).gt.0) THEN
+              qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
+     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
+          ELSE
+              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+          ENDIF
+          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      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)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+     
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+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),1)
+           qpn=0.
+           do ij=1,iim
+              qpn=qpn+masse(ij,l)*q(ij,l)
+           enddo
+           qpn=(qpn+convpn)/(massepn+convmpn)
+           do ij=1,iip1
+              q(ij,l)=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),1)
+           qps=0.
+           do ij = ip1jm+1,ip1jmp1-1
+              qps=qps+masse(ij,l)*q(ij,l)
+           enddo
+           qps=(qps+convps)/(masseps+convmps)
+           do ij=ip1jm+1,ip1jmp1
+              q(ij,l)=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)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
+      
+      
+      
+      SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x)
+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
+      USE vlz_mod
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL q(ijb_u:ije_u,llm)
+      REAL w(ijb_u:ije_u,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL newmasse
+
+      REAL dzqmax
+      REAL sigw
+
+      LOGICAL testcpu
+      SAVE testcpu
+c$OMP THREADPRIVATE(testcpu)
+      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
+      EXTERNAL  SSUM
+
+      DATA testcpu/.false./
+      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)
+      
+
+      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
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps0=second(0.)
+      ENDIF
+#endif
+
+      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)-q(ij,l)
+            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
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            ELSE
+                dzq(ij,l)=0.
+            ENDIF
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         ENDDO
+      ENDDO
+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
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps1=temps1+second(0.)-temps0
+      ENDIF
+#endif
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l = 1,llm-1
+         do  ij = ijb,ije
+          IF(w(ij,l+1).gt.0.) THEN
+             sigw=w(ij,l+1)/masse(ij,l+1)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
+          ELSE
+             sigw=w(ij,l+1)/masse(ij,l)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+          ENDIF
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+       DO ij=ijb,ije
+          wq(ij,llm+1)=0.
+          wq(ij,1)=0.
+       ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije
+            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+      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: LMDZ5/trunk/libf/vlspltgen_loc.F
===================================================================
--- LMDZ5/trunk/libf/vlspltgen_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/vlspltgen_loc.F	(revision 1630)
@@ -0,0 +1,518 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltgen_loc( q,iadv,pente_max,masse,w,pbaru,pbarv,
+     &                           pdt, p,pk,teta                 )
+     
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
+c
+c    ********************************************************************
+c          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      USE parallel
+      USE mod_hallo
+      USE Write_Field_loc
+      USE VAMPIR
+      USE infotrac, ONLY : nqtot
+      USE vlspltgen_mod
+      IMPLICIT NONE
+
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      INTEGER iadv(nqtot)
+      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot)
+      REAL w(ijb_u:ije_u,llm),pdt
+      REAL p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm)
+      REAL pk(ijb_u:ije_u,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      REAL zzpbar, zzw
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+      REAL tempe(ijb_u:ije_u)
+      INTEGER ijb,ije,iq
+      LOGICAL, SAVE :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c Allocate variables depending on dynamic variable nqtot
+
+         IF (firstcall) THEN
+            firstcall=.FALSE.
+         END IF
+c-- Calcul de Qsat en chaque point
+c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+c   pour eviter une exponentielle.
+
+      call SetTag(MyRequest1,100)
+      call SetTag(MyRequest2,101)
+
+        
+	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, llm
+         DO ij = ijb, ije
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = ijb, ije
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         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
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+         DO ij=ijb,ije
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+c$OMP END MASTER
+
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+       ijb=ij_begin
+       ije=ij_end
+
+      DO iq=1,nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+        DO l=1,llm
+          zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
+          zm(ijb:ije,l,iq)=masse(ijb:ije,l)
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+
+#ifdef DEBUG_IO    
+       CALL WriteField_u('mu',mu)
+       CALL WriteField_v('mv',mv)
+       CALL WriteField_u('mw',mw)
+       CALL WriteField_u('qsat',qsat)
+#endif
+
+c$OMP BARRIER           
+      DO iq=1,nqtot
+
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+
+#ifdef _ADV_HALO        
+	  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &	             ij_begin,ij_begin+2*iip1-1)
+          call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &               ij_end-2*iip1+1,ij_end)
+#else
+	  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &	             ij_begin,ij_end)
+#endif
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER
+	else if (iadv(iq)==14) then
+
+#ifdef _ADV_HALO           
+          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &                   qsat,ij_begin,ij_begin+2*iip1-1)
+          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &                   qsat,ij_end-2*iip1+1,ij_end)
+#else
+
+          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &                   qsat,ij_begin,ij_end)
+#endif
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+      
+      
+c$OMP BARRIER      
+c$OMP MASTER      
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call SendRequest(MyRequest1)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER       
+c$OMP BARRIER
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+
+#ifdef _ADV_HALLO
+          call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &                 ij_begin+2*iip1,ij_end-2*iip1)
+#endif        
+	else if (iadv(iq)==14) then
+#ifdef _ADV_HALLO
+          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1)
+#endif    
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+c$OMP BARRIER      
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+!      call WaitRecvRequest(MyRequest1)
+!      call WaitSendRequest(MyRequest1)
+c$OMP BARRIER
+       call WaitRequest(MyRequest1)
+
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+
+
+      do iq=1,nqtot
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
+     &                   qsat)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+
+      do iq=1,nqtot
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+
+c$OMP BARRIER        
+#ifdef _ADV_HALLO
+          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
+     &               ij_begin,ij_begin+2*iip1-1)
+          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
+     &               ij_end-2*iip1+1,ij_end)
+#else
+          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
+     &               ij_begin,ij_end)
+#endif
+c$OMP BARRIER
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER	
+c$OMP BARRIER
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+c$OMP BARRIER      
+
+c$OMP MASTER        
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call SendRequest(MyRequest2)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER	
+
+c$OMP BARRIER
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+c$OMP BARRIER        
+
+#ifdef _ADV_HALLO
+          call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
+     &               ij_begin+2*iip1,ij_end-2*iip1)
+#endif
+
+c$OMP BARRIER        
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+
+c$OMP BARRIER
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+!      call WaitRecvRequest(MyRequest2)
+!      call WaitSendRequest(MyRequest2)
+c$OMP BARRIER
+       CALL WaitRequest(MyRequest2)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+
+
+      do iq=1,nqtot
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
+     &                   qsat)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+
+      do iq=1,nqtot
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &               ij_begin,ij_end)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
+     &                 qsat, ij_begin,ij_end)
+ 
+        else
+	
+          stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+     
+      ijb=ij_begin
+      ije=ij_end
+c$OMP BARRIER      
+
+
+      DO iq=1,nqtot
+#ifdef DEBUG_IO    
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+        DO l=1,llm
+           DO ij=ijb,ije
+c             print *,'zq-->',ij,l,iq,zq(ij,l,iq)
+c	     print *,'q-->',ij,l,iq,q(ij,l,iq)
+	     q(ij,l,iq)=zq(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT          
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           DO ij=ijb,ije-iip1+1,iip1
+              q(ij+iim,l,iq)=q(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT  
+
+      ENDDO
+        
+      
+c$OMP BARRIER
+
+cc$OMP MASTER      
+c      call WaitSendRequest(MyRequest1) 
+c      call WaitSendRequest(MyRequest2)
+cc$OMP END MASTER
+cc$OMP BARRIER
+
+      RETURN
+      END
Index: LMDZ5/trunk/libf/vlspltgen_mod.F90
===================================================================
--- LMDZ5/trunk/libf/vlspltgen_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/vlspltgen_mod.F90	(revision 1630)
@@ -0,0 +1,54 @@
+MODULE vlspltgen_mod
+
+  REAL,POINTER,SAVE :: qsat(:,:)
+  REAL,POINTER,SAVE :: mu(:,:)
+  REAL,POINTER,SAVE :: mv(:,:)
+  REAL,POINTER,SAVE :: mw(:,:)
+  REAL,POINTER,SAVE :: zm(:,:,:)
+  REAL,POINTER,SAVE :: zq(:,:,:)
+ 
+CONTAINS
+
+  SUBROUTINE vlspltgen_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE infotrac
+  USE vlz_mod,ONLY : vlz_allocate 
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+    
+    d=>distrib_vanleer
+    CALL allocate_u(qsat,llm,d)
+    CALL allocate_u(mu,llm,d)
+    CALL allocate_v(mv,llm,d)
+    CALL allocate_u(mw,llm+1,d)
+    CALL allocate_u(zm,llm,nqtot,d)
+    CALL allocate_u(zq,llm,nqtot,d)
+
+    CALL vlz_allocate
+
+  END SUBROUTINE vlspltgen_allocate
+  
+  SUBROUTINE vlspltgen_switch_vanleer(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  USE vlz_mod,ONLY : vlz_switch_vanleer 
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(qsat,distrib_vanleer,dist)
+    CALL switch_u(mu,distrib_vanleer,dist)
+    CALL switch_u(mv,distrib_vanleer,dist)
+    CALL switch_u(mw,distrib_vanleer,dist)
+    CALL switch_u(zm,distrib_vanleer,dist)
+    CALL switch_u(zq,distrib_vanleer,dist)
+
+    CALL vlz_switch_vanleer(dist)
+
+  END SUBROUTINE vlspltgen_switch_vanleer  
+  
+END MODULE vlspltgen_mod  
Index: LMDZ5/trunk/libf/vlspltqs_loc.F
===================================================================
--- LMDZ5/trunk/libf/vlspltqs_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/vlspltqs_loc.F	(revision 1630)
@@ -0,0 +1,717 @@
+      SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c
+c   --------------------------------------------------------------------
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL u_m( ijb_u:ije_u,llm )
+      REAL q(ijb_u:ije_u,llm)
+      REAL qsat(ijb_u:ije_u,llm)
+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      SSUM
+
+
+      INTEGER ijb,ije,ijb_x,ije_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.gt.-1.e-5) THEN
+c     IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=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
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+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)-q(ij,l)
+            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).gt.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
+
+#ifdef CRAY
+c--pas encore modification sur Qsat
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+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).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij,l)+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)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+          ENDIF
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+
+
+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).lt.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 nécessaire
+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).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+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
+
+c   calcul des tendances
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+1,ije
+            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=ijb+iip1-1,ije,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+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
+      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat)
+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
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ijb_u:ije_u,llm),pente_max
+      REAL masse_adv_v( ijb_v:ije_v,llm)
+      REAL q(ijb_u:ije_u,llm)
+      REAL qsat(ijb_u:ije_u,llm)
+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)
+
+      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      SSUM
+
+      DATA first/.true./
+      INTEGER ijb,ije
+
+      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$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)
+        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)
+        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)-q(ij+iip1,l)
+         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)
+        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).lt.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)-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).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(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     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+      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).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+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).GT.0. ) THEN
+           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
+         ELSE
+              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
+         ENDIF
+          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      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)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+
+         IF (pole_nord) THEN
+
+           convpn=SSUM(iim,qbyv(1,l),1)/apoln
+           convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+           DO ij = 1,iip1
+              newmasse=masse(ij,l)+convmpn*aire(ij)
+              q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
+     &                 newmasse
+              masse(ij,l)=newmasse
+           ENDDO
+	 
+	 ENDIF
+         
+	 IF (pole_sud) THEN
+	 
+	   convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+           convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+           DO ij = ip1jm+1,ip1jmp1
+              newmasse=masse(ij,l)+convmps*aire(ij)
+              q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
+     &                 newmasse
+              masse(ij,l)=newmasse
+           ENDDO
+	 
+	 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)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ5/trunk/libf/vlz_mod.F90
===================================================================
--- LMDZ5/trunk/libf/vlz_mod.F90	(revision 1630)
+++ LMDZ5/trunk/libf/vlz_mod.F90	(revision 1630)
@@ -0,0 +1,41 @@
+MODULE vlz_mod
+
+  REAL,POINTER,SAVE :: wq(:,:)
+  REAL,POINTER,SAVE :: dzq(:,:)
+  REAL,POINTER,SAVE :: dzqw(:,:)
+  REAL,POINTER,SAVE :: adzqw(:,:)
+  
+CONTAINS
+
+  SUBROUTINE vlz_allocate
+  USE bands
+  USE allocate_field
+  USE parallel
+  USE infotrac
+  USE dimensions
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+    
+    d=>distrib_vanleer
+    CALL allocate_u(wq,llm+1,d)
+    CALL allocate_u(dzq,llm,d)
+    CALL allocate_u(dzqw,llm,d)
+    CALL allocate_u(adzqw,llm,d)
+
+  END SUBROUTINE vlz_allocate
+  
+  SUBROUTINE vlz_switch_vanleer(dist)
+  USE allocate_field
+  USE bands
+  USE parallel
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(wq,distrib_vanleer,dist)
+    CALL switch_u(dzq,distrib_vanleer,dist)
+    CALL switch_u(dzqw,distrib_vanleer,dist)
+    CALL switch_u(adzqw,distrib_vanleer,dist)
+
+  END SUBROUTINE vlz_switch_vanleer  
+  
+END MODULE vlz_mod  
Index: LMDZ5/trunk/libf/wrgrads.F
===================================================================
--- LMDZ5/trunk/libf/wrgrads.F	(revision 1630)
+++ LMDZ5/trunk/libf/wrgrads.F	(revision 1630)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+      subroutine wrgrads(if,nl,field,name,titlevar)
+      implicit none
+
+c   Declarations
+c    if indice du fichier
+c    nl nombre de couches
+c    field   champ
+c    name    petit nom
+c    titlevar   Titre
+
+#include "gradsdef.h"
+
+c   arguments
+      integer if,nl
+      real field(imx*jmx*lmx)
+      character*10 name,file
+      character*10 titlevar
+
+c   local
+
+      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
+
+      logical writectl
+
+
+      writectl=.false.
+
+      print*,if,iid(if),jid(if),ifd(if),jfd(if)
+      iii=iid(if)
+      iji=jid(if)
+      iif=ifd(if)
+      ijf=jfd(if)
+      im=iif-iii+1
+      jm=ijf-iji+1
+      lm=lmd(if)
+
+      print*,'im,jm,lm,name,firsttime(if)'
+      print*,im,jm,lm,name,firsttime(if)
+
+      if(firsttime(if)) then
+         if(name.eq.var(1,if)) then
+            firsttime(if)=.false.
+            ivar(if)=1
+         print*,'fin de l initialiation de l ecriture du fichier'
+         print*,file
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+         else
+            ivar(if)=ivar(if)+1
+            nvar(if)=ivar(if)
+            var(ivar(if),if)=name
+            tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
+            nld(ivar(if),if)=nl
+            print*,'initialisation ecriture de ',var(ivar(if),if)
+            print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+      print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+      print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      do l=1,nl
+         irec(if)=irec(if)+1
+c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+         write(unit(if)+1,rec=irec(if))
+     s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
+     s   ,i=iii,iif),j=iji,ijf)
+      enddo
+      if (writectl) then
+
+      file=fichier(if)
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      open(unit(if),file=file(1:lnblnk(file))//'.ctl'
+     &         ,form='formatted',status='unknown')
+      write(unit(if),'(a5,1x,a40)')
+     &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
+
+      write(unit(if),'(a12)') 'UNDEF 1.0E30'
+      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+      write(unit(if),'(a4,i10,a30)')
+     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+      do iv=1,nvar(if)
+c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
+     &     ,99,tvar(iv,if)
+      enddo
+      write(unit(if),'(a7)') 'ENDVARS'
+c
+1000  format(a5,3x,i4,i3,1x,a39)
+
+      close(unit(if))
+
+      endif ! writectl
+
+      return
+
+      END
+
Index: LMDZ5/trunk/libf/write_field_loc.F90
===================================================================
--- LMDZ5/trunk/libf/write_field_loc.F90	(revision 1630)
+++ LMDZ5/trunk/libf/write_field_loc.F90	(revision 1630)
@@ -0,0 +1,153 @@
+module write_field_loc
+implicit none
+  
+  interface WriteField_u
+    module procedure Write_field1d_u,Write_Field2d_u
+  end interface WriteField_u
+
+  interface WriteField_v
+    module procedure Write_field1d_v,Write_Field2d_v
+  end interface WriteField_v
+  
+  contains
+  
+  subroutine write_field1D_u(name,Field)
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+
+    CALL write_field_u_gen(name,Field,1)
+
+  end subroutine write_field1D_u
+
+  subroutine write_field2D_u(name,Field)
+    implicit none
+      
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    integer :: ll
+    
+    ll=size(field,2)    
+    CALL write_field_u_gen(name,Field,ll)
+    
+    end subroutine write_field2D_u
+
+
+   SUBROUTINE write_field_u_gen(name,Field,ll)
+    USE parallel
+    USE write_field
+    USE mod_hallo
+    implicit none
+    include 'dimensions.h'
+    include 'paramet.h'
+      
+    character(len=*)   :: name
+    real, dimension(ijb_u:ije_u,ll) :: Field
+    real, allocatable,SAVE :: New_Field(:,:,:)
+    integer,dimension(0:mpi_size-1) :: jj_nb_master
+    type(Request) :: Request_write
+    integer :: ll,i
+    
+    
+    jj_nb_master(:)=0
+    jj_nb_master(0)=jjp1
+!$OMP BARRIER
+!$OMP MASTER
+    allocate(New_Field(iip1,jjp1,ll))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO i=1,ll    
+      New_Field(:,jj_begin:jj_end,i)=reshape(Field(ij_begin:ij_end,i),(/iip1,jj_nb/))
+    ENDDO
+    
+    call Register_SwapField(new_field,new_field,ip1jmp1,ll,jj_Nb_master,Request_write)
+    call SendRequest(Request_write)
+!$OMP BARRIER
+    call WaitRequest(Request_write)     
+!$OMP BARRIER
+
+!$OMP MASTER
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    DEALLOCATE(New_Field)
+!$OMP END MASTER        
+!$OMP BARRIER
+    END SUBROUTINE write_field_u_gen
+
+
+  subroutine write_field1D_v(name,Field)
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+
+    CALL write_field_v_gen(name,Field,1)
+
+  end subroutine write_field1D_v
+
+  subroutine write_field2D_v(name,Field)
+    implicit none
+      
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    integer :: ll
+    
+    ll=size(field,2)    
+    CALL write_field_v_gen(name,Field,ll)
+    
+    end subroutine write_field2D_v
+
+
+   SUBROUTINE write_field_v_gen(name,Field,ll)
+    USE parallel
+    USE write_field
+    USE mod_hallo
+    implicit none
+    include 'dimensions.h'
+    include 'paramet.h'
+      
+    character(len=*)   :: name
+    real, dimension(ijb_v:ije_v,ll) :: Field
+    real, allocatable,SAVE :: New_Field(:,:,:)
+    integer,dimension(0:mpi_size-1) :: jj_nb_master
+    type(Request) :: Request_write
+    integer :: ll,i,jje,ije,jjn
+    
+    
+    jj_nb_master(:)=0
+    jj_nb_master(0)=jjp1
+
+!$OMP BARRIER
+!$OMP MASTER
+    allocate(New_Field(iip1,jjm,ll))
+!$OMP END MASTER
+!$OMP BARRIER
+
+   IF (pole_sud) THEN
+     jje=jj_end-1
+     ije=ij_end-iip1
+     jjn=jj_nb-1
+   ELSE
+     jje=jj_end
+     ije=ij_end
+     jjn=jj_nb
+   ENDIF
+   
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO i=1,ll    
+      New_Field(:,jj_begin:jje,i)=reshape(Field(ij_begin:ije,i),(/iip1,jjn/))
+    ENDDO
+    
+    call Register_SwapField(new_field,new_field,ip1jm,ll,jj_Nb_master,Request_write)
+    call SendRequest(Request_write)
+!$OMP BARRIER
+    call WaitRequest(Request_write)     
+!$OMP BARRIER
+
+!$OMP MASTER
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    DEALLOCATE(New_Field)
+!$OMP END MASTER        
+!$OMP BARRIER
+    END SUBROUTINE write_field_v_gen
+    
+end module write_field_loc
+  
Index: LMDZ5/trunk/libf/write_field_p.F90
===================================================================
--- LMDZ5/trunk/libf/write_field_p.F90	(revision 1630)
+++ LMDZ5/trunk/libf/write_field_p.F90	(revision 1630)
@@ -0,0 +1,73 @@
+module write_field_p
+implicit none
+  
+  interface WriteField_p
+    module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p
+  end interface WriteField_p
+  
+  contains
+  
+  subroutine write_field1D_p(name,Field)
+    USE parallel
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1)))
+    New_Field(:)=Field(:)
+    call Gather_Field(New_Field,dim(1),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+    end subroutine write_field1D_p
+
+  subroutine write_field2D_p(name,Field)
+    USE parallel
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2)))
+    New_Field(:,:)=Field(:,:)
+    call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+     
+  end subroutine write_field2D_p
+  
+  subroutine write_field3D_p(name,Field)
+    USE parallel
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2),Dim(3)))
+    New_Field(:,:,:)=Field(:,:,:)
+    call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0)
+    
+   if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+  end subroutine write_field3D_p  
+
+end module write_field_p
+  
Index: LMDZ5/trunk/libf/write_grads_dyn.h
===================================================================
--- LMDZ5/trunk/libf/write_grads_dyn.h	(revision 1630)
+++ LMDZ5/trunk/libf/write_grads_dyn.h	(revision 1630)
@@ -0,0 +1,31 @@
+!
+! $Header$
+!
+      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 ')
+
+        callinigrads=.false.
+
+
+      endif
+
+      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
+
Index: LMDZ5/trunk/libf/writedynav_loc.F
===================================================================
--- LMDZ5/trunk/libf/writedynav_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/writedynav_loc.F	(revision 1630)
@@ -0,0 +1,224 @@
+!
+! $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)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+      USE ioipsl
+#endif
+      USE parallel
+      USE misc_mod
+      USE infotrac, ONLY : nqtot, ttext
+      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.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
+
+
+#ifdef CPP_IOIPSL
+! 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_u:ije_u,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
+
+!$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
+!$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, ttext(iq), 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, 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, ndexu)
+!$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
+#else
+      write(lunout,*)'writedynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/writedynav_p.F
===================================================================
--- LMDZ5/trunk/libf/writedynav_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/writedynav_p.F	(revision 1630)
@@ -0,0 +1,169 @@
+!
+! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine writedynav_p( histid, time, vcov, 
+     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+      USE ioipsl
+#endif
+      USE parallel
+      USE misc_mod
+      USE infotrac
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm),ppk(ip1jmp1,llm)                  
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL phis(ip1jmp1)                  
+      REAL q(ip1jmp1,llm,nqtot)
+      integer time
+
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
+      real us(ip1jmp1,llm), vs(ip1jmp1,llm)
+      real tm(ip1jmp1,llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) 
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+      
+      ndex3d = 0
+      ndex2d = 0
+      ok_sync = .TRUE.
+      us = 999.999
+      vs = 999.999
+      tm = 999.999
+      vnat = 999.999
+      unat = 999.999
+      itau_w = itau_dyn + time
+
+C Passage aux composantes naturelles du vent
+      call covnat_p(llm, ucov, vcov, unat, vnat)
+
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U scalaire
+C
+      call gr_u_scal_p(llm, unat, us)
+      
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+      
+      call histwrite(histid, 'u', itau_w, us(ijb:ije,:), 
+     .               iip1*jjn*llm, ndex3d)
+C
+C  Vents V scalaire
+C
+      
+      call gr_v_scal_p(llm, vnat, vs)
+      call histwrite(histid, 'v', itau_w, vs(ijb:ije,:), 
+     .               iip1*jjn*llm, ndex3d)
+C
+C  Temperature potentielle moyennee
+C
+     
+      call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Temperature moyennee
+C
+      do ll=1,llm
+        do ii = ijb, ije
+          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+        enddo
+      enddo
+      
+      call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), 
+     .                   iip1*jjn*llm, ndex3d)
+        enddo
+C
+C  Masse
+C
+       call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1),
+     .                iip1*jjn, ndex2d)
+C
+C  Pression au sol
+C
+       call histwrite(histid, 'ps', itau_w, ps(ijb:ije), 
+     .                 iip1*jjn, ndex2d)
+C
+C  Geopotentiel au sol
+C
+       call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+     .                 iip1*jjn, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) call histsync(histid)
+#else
+      write(lunout,*)'writedynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/writehist_loc.F
===================================================================
--- LMDZ5/trunk/libf/writehist_loc.F	(revision 1630)
+++ LMDZ5/trunk/libf/writehist_loc.F	(revision 1630)
@@ -0,0 +1,224 @@
+!
+! $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)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+      USE ioipsl
+#endif
+      USE parallel
+      USE misc_mod
+      USE infotrac, ONLY : nqtot, ttext
+      use com_io_dyn_mod, only : histid,histvid,histuid
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.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
+
+
+#ifdef CPP_IOIPSL
+! 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_u:ije_u,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
+
+!$OMP BARRIER
+!$OMP MASTER      
+      call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), 
+     .               iip1*jjn*llm, ndexv)
+!$OMP END MASTER      
+
+
+C
+C  Temperature potentielle moyennee
+C
+!$OMP MASTER      
+      call histwrite(histid, '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(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, ttext(iq), 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, 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, ndexu)
+!$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
+#else
+      write(lunout,*)'writedynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: LMDZ5/trunk/libf/writehist_p.F
===================================================================
--- LMDZ5/trunk/libf/writehist_p.F	(revision 1630)
+++ LMDZ5/trunk/libf/writehist_p.F	(revision 1630)
@@ -0,0 +1,156 @@
+!
+! $Id: writehist_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine writehist_p( histid, histvid, time, vcov, 
+     ,                          ucov,teta,phi,q,masse,ps,phis)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+      USE ioipsl
+#endif
+      USE parallel
+      USE misc_mod
+      USE infotrac
+      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      histvid:ID du fichier histoire pour les vents V (appele a disparaitre)
+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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, histvid
+      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
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+     
+    
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
+      ok_sync =.TRUE.
+      itau_w = itau_dyn + time
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+          
+      call histwrite(histid, 'ucov', itau_w, ucov(ijb:ije,:), 
+     .               iip1*jjn*llm, ndexu)
+
+C
+C  Vents V
+C
+      if (pole_sud) ije=ij_end-iip1
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histwrite(histvid, 'vcov', itau_w, vcov(ijb:ije,:), 
+     .               iip1*jjn*llm, ndexv)
+
+C
+C  Temperature potentielle
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+
+      call histwrite(histid, 'teta', itau_w, teta(ijb:ije,:), 
+     .                iip1*jjn*llm, ndexu)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
+     .                iip1*jjn*llm, ndexu)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), 
+     .                   iip1*jjn*llm, ndexu)
+        enddo
+C
+C  Masse
+C
+      call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1),
+     .               iip1*jjn, ndex2d)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', itau_w, ps(ijb:ije),
+     .               iip1*jjn, ndex2d)
+C
+C  Geopotentiel au sol
+C
+      call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+     .               iip1*jjn, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+      endif
+#else
+      write(lunout,*)'writehist_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
