Index: LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F	(revision 5214)
+++ 	(revision )
@@ -1,59 +1,0 @@
-!
-! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
-!
-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_lmdz
-      INCLUDE "iniprint.h"
- 
-C
-C Stops the simulation cleanly, closing files and printing various
-C comments
-C
-C  Input: modname = name of calling program
-C         message = stuff to print
-C         ierr    = severity of situation ( = 0 normal )
-
-      character(len=*), intent(in):: modname
-      integer ierr, ierror_mpi
-      character(len=*), intent(in):: message
-
-      write(lunout,*) 'in abort_gcm'
-#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 = ', ierr
-
-        if (using_mpi) THEN
-C$OMP CRITICAL (MPI_ABORT_GCM)
-          call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
-C$OMP END CRITICAL (MPI_ABORT_GCM)
-        else
-         stop 1
-        endif          
-      
-      endif
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90	(revision 5246)
@@ -0,0 +1,59 @@
+!
+! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
+!
+!
+!
+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_lmdz
+  INCLUDE "iniprint.h"
+
+  !
+  ! Stops the simulation cleanly, closing files and printing various
+  ! comments
+  !
+  !  Input: modname = name of calling program
+  !     message = stuff to print
+  !     ierr    = severity of situation ( = 0 normal )
+
+  character(len=*), intent(in):: modname
+  integer :: ierr, ierror_mpi
+  character(len=*), intent(in):: message
+
+  write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+!$OMP MASTER
+  call histclo
+  call restclo
+  if (MPI_rank .eq. 0) then
+     call getin_dump
+  endif
+!$OMP END MASTER
+#endif
+  ! call histclo(2)
+  ! call histclo(3)
+  ! call histclo(4)
+  ! 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 = ', ierr
+
+    if (using_mpi) THEN
+!$OMP CRITICAL (MPI_ABORT_GCM)
+      call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
+!$OMP END CRITICAL (MPI_ABORT_GCM)
+    else
+     stop 1
+    endif
+
+  endif
+END SUBROUTINE abort_gcm
Index: LMDZ6/trunk/libf/dyn3dmem/addfi_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/addfi_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,263 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE addfi_loc(pdt, leapf, forward,
-     S          pucov, pvcov, pteta, pq   , pps ,
-     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
-      USE parallel_lmdz
-      USE infotrac, ONLY : nqtot
-      USE control_mod, ONLY : planet_type
-      IMPLICIT NONE
-c
-c=======================================================================
-c
-c    Addition of the physical tendencies
-c
-c    Interface :
-c    -----------
-c
-c      Input :
-c      -------
-c      pdt                    time step of integration
-c      leapf                  logical
-c      forward                logical
-c      pucov(ip1jmp1,llm)     first component of the covariant velocity
-c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
-c      pteta(ip1jmp1,llm)     potential temperature
-c      pts(ip1jmp1,llm)       surface temperature
-c      pdufi(ip1jmp1,llm)     |
-c      pdvfi(ip1jm,llm)       |   respective
-c      pdhfi(ip1jmp1)         |      tendencies
-c      pdtsfi(ip1jmp1)        |
-c
-c      Output :
-c      --------
-c      pucov
-c      pvcov
-c      ph
-c      pts
-c
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c
-c    0.  Declarations :
-c    ------------------
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c    Arguments :
-c    -----------
-c
-      REAL,INTENT(IN) :: pdt ! time step for the integration (s)
-c
-      REAL,INTENT(INOUT) :: pvcov(ijb_v:ije_v,llm) ! covariant meridional wind
-      REAL,INTENT(INOUT) :: pucov(ijb_u:ije_u,llm) ! covariant zonal wind
-      REAL,INTENT(INOUT) :: pteta(ijb_u:ije_u,llm) ! potential temperature
-      REAL,INTENT(INOUT) :: pq(ijb_u:ije_u,llm,nqtot) ! tracers
-      REAL,INTENT(INOUT) :: pps(ijb_u:ije_u) ! surface pressure (Pa)
-c respective tendencies (.../s) to add
-      REAL,INTENT(IN) :: pdvfi(ijb_v:ije_v,llm)
-      REAL,INTENT(IN) :: pdufi(ijb_u:ije_u,llm)
-      REAL,INTENT(IN) :: pdqfi(ijb_u:ije_u,llm,nqtot)
-      REAL,INTENT(IN) :: pdhfi(ijb_u:ije_u,llm)
-      REAL,INTENT(IN) :: pdpfi(ijb_u:ije_u)
-c
-      LOGICAL,INTENT(IN) :: leapf,forward ! not used
-c
-c
-c    Local variables :
-c    -----------------
-c
-      REAL xpn(iim),xps(iim),tpn,tps
-      INTEGER j,k,iq,ij
-      REAL,PARAMETER :: qtestw = 1.0e-15
-      REAL,PARAMETER :: qtestt = 1.0e-40
-
-      REAL SSUM
-      EXTERNAL SSUM
-      
-      INTEGER :: ijb,ije
-c
-c-----------------------------------------------------------------------
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO k = 1,llm
-         DO j = ijb,ije
-            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      if (pole_nord) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO  k    = 1, llm
-         DO  ij   = 1, iim
-           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
-         ENDDO
-         tpn      = SSUM(iim,xpn,1)/ apoln
-
-         DO ij   = 1, iip1
-           pteta(   ij   ,k)  = tpn
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-      endif
-
-      if (pole_sud) then
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO  k    = 1, llm
-         DO  ij   = 1, iim
-           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
-         ENDDO
-         tps      = SSUM(iim,xps,1)/ apols
-
-         DO ij   = 1, iip1
-           pteta(ij+ip1jm,k)  = tps
-         ENDDO
-       ENDDO
-c$OMP END DO NOWAIT
-      endif
-c
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO k = 1,llm
-         DO j = ijb,ije
-            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      if (pole_nord) ijb=ij_begin
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO k = 1,llm
-         DO j = ijb,ije
-            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c
-      if (pole_sud)  ije=ij_end
-c$OMP MASTER
-      DO j = ijb,ije
-         pps(j) = pps(j) + pdpfi(j) * pdt
-      ENDDO
-c$OMP END MASTER
- 
-      if (planet_type=="earth") then
-      ! earth case, special treatment for first 2 tracers (water)
-      DO iq = 1, 2
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1,llm
-            DO j = ijb,ije
-               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
-               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
-            ENDDO
-         ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-      DO iq = 3, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1,llm
-            DO j = ijb,ije
-               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
-               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
-            ENDDO
-         ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-      else
-      ! general case, treat all tracers equally)
-       DO iq = 1, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1,llm
-            DO j = ijb,ije
-               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
-               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
-            ENDDO
-         ENDDO
-c$OMP END DO NOWAIT
-       ENDDO
-      endif ! of if (planet_type=="earth")
-
-c$OMP MASTER
-      if (pole_nord) then
-      
-        DO  ij   = 1, iim
-          xpn(ij) = aire(   ij   ) * pps(  ij     )
-        ENDDO
-
-        tpn      = SSUM(iim,xpn,1)/apoln
-
-        DO ij   = 1, iip1
-          pps (   ij     )  = tpn
-        ENDDO
-      
-      endif
-
-      if (pole_sud) then
-      
-        DO  ij   = 1, iim
-          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
-        ENDDO
-
-        tps      = SSUM(iim,xps,1)/apols
-
-        DO ij   = 1, iip1
-          pps ( ij+ip1jm )  = tps
-        ENDDO
-      
-      endif
-c$OMP END MASTER
-
-      if (pole_nord) then
-        DO iq = 1, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO  k    = 1, llm
-            DO  ij   = 1, iim
-              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
-            ENDDO
-            tpn      = SSUM(iim,xpn,1)/apoln
-  
-            DO ij   = 1, iip1
-              pq (   ij   ,k,iq)  = tpn
-            ENDDO
-          ENDDO
-c$OMP END DO NOWAIT	  
-        ENDDO
-      endif
-      
-      if (pole_sud) then
-        DO iq = 1, nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO  k    = 1, llm
-            DO  ij   = 1, iim
-              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
-            ENDDO
-            tps      = SSUM(iim,xps,1)/apols
-  
-            DO ij   = 1, iip1
-              pq (ij+ip1jm,k,iq)  = tps
-            ENDDO
-          ENDDO
-c$OMP END DO NOWAIT	  
-        ENDDO
-      endif
-      
-      
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/addfi_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/addfi_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/addfi_loc.f90	(revision 5246)
@@ -0,0 +1,263 @@
+!
+! $Id$
+!
+SUBROUTINE addfi_loc(pdt, leapf, forward, &
+        pucov, pvcov, pteta, pq   , pps , &
+        pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot
+  USE control_mod, ONLY : planet_type
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !    Addition of the physical tendencies
+  !
+  !    Interface :
+  !    -----------
+  !
+  !  Input :
+  !  -------
+  !  pdt                    time step of integration
+  !  leapf                  logical
+  !  forward                logical
+  !  pucov(ip1jmp1,llm)     first component of the covariant velocity
+  !  pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+  !  pteta(ip1jmp1,llm)     potential temperature
+  !  pts(ip1jmp1,llm)       surface temperature
+  !  pdufi(ip1jmp1,llm)     |
+  !  pdvfi(ip1jm,llm)       |   respective
+  !  pdhfi(ip1jmp1)         |      tendencies
+  !  pdtsfi(ip1jmp1)        |
+  !
+  !  Output :
+  !  --------
+  !  pucov
+  !  pvcov
+  !  ph
+  !  pts
+  !
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    0.  Declarations :
+  !    ------------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !    Arguments :
+  !    -----------
+  !
+  REAL,INTENT(IN) :: pdt ! time step for the integration (s)
+  !
+  REAL,INTENT(INOUT) :: pvcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(INOUT) :: pucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(INOUT) :: pteta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(INOUT) :: pq(ijb_u:ije_u,llm,nqtot) ! tracers
+  REAL,INTENT(INOUT) :: pps(ijb_u:ije_u) ! surface pressure (Pa)
+  ! respective tendencies (.../s) to add
+  REAL,INTENT(IN) :: pdvfi(ijb_v:ije_v,llm)
+  REAL,INTENT(IN) :: pdufi(ijb_u:ije_u,llm)
+  REAL,INTENT(IN) :: pdqfi(ijb_u:ije_u,llm,nqtot)
+  REAL,INTENT(IN) :: pdhfi(ijb_u:ije_u,llm)
+  REAL,INTENT(IN) :: pdpfi(ijb_u:ije_u)
+  !
+  LOGICAL,INTENT(IN) :: leapf,forward ! not used
+  !
+  !
+  !    Local variables :
+  !    -----------------
+  !
+  REAL :: xpn(iim),xps(iim),tpn,tps
+  INTEGER :: j,k,iq,ij
+  REAL,PARAMETER :: qtestw = 1.0e-15
+  REAL,PARAMETER :: qtestt = 1.0e-40
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+
+  INTEGER :: ijb,ije
+  !
+  !-----------------------------------------------------------------------
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  k    = 1, llm
+     DO  ij   = 1, iim
+       xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+     ENDDO
+     tpn      = SSUM(iim,xpn,1)/ apoln
+
+     DO ij   = 1, iip1
+       pteta(   ij   ,k)  = tpn
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  k    = 1, llm
+     DO  ij   = 1, iim
+       xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+     ENDDO
+     tps      = SSUM(iim,xps,1)/ apols
+
+     DO ij   = 1, iip1
+       pteta(ij+ip1jm,k)  = tps
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  endif
+  !
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_nord) ijb=ij_begin
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+  if (pole_sud)  ije=ij_end
+!$OMP MASTER
+  DO j = ijb,ije
+     pps(j) = pps(j) + pdpfi(j) * pdt
+  ENDDO
+!$OMP END MASTER
+
+  if (planet_type=="earth") then
+  ! ! earth case, special treatment for first 2 tracers (water)
+  DO iq = 1, 2
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  DO iq = 3, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  else
+  ! ! general case, treat all tracers equally)
+   DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+   ENDDO
+  endif ! of if (planet_type=="earth")
+
+!$OMP MASTER
+  if (pole_nord) then
+
+    DO  ij   = 1, iim
+      xpn(ij) = aire(   ij   ) * pps(  ij     )
+    ENDDO
+
+    tpn      = SSUM(iim,xpn,1)/apoln
+
+    DO ij   = 1, iip1
+      pps (   ij     )  = tpn
+    ENDDO
+
+  endif
+
+  if (pole_sud) then
+
+    DO  ij   = 1, iim
+      xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+    ENDDO
+
+    tps      = SSUM(iim,xps,1)/apols
+
+    DO ij   = 1, iip1
+      pps ( ij+ip1jm )  = tps
+    ENDDO
+
+  endif
+!$OMP END MASTER
+
+  if (pole_nord) then
+    DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  k    = 1, llm
+        DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+        ENDDO
+        tpn      = SSUM(iim,xpn,1)/apoln
+
+        DO ij   = 1, iip1
+          pq (   ij   ,k,iq)  = tpn
+        ENDDO
+      ENDDO
+!$OMP END DO NOWAIT	
+    ENDDO
+  endif
+
+  if (pole_sud) then
+    DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  k    = 1, llm
+        DO  ij   = 1, iim
+          xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+        ENDDO
+        tps      = SSUM(iim,xps,1)/apols
+
+        DO ij   = 1, iip1
+          pq (ij+ip1jm,k,iq)  = tps
+        ENDDO
+      ENDDO
+!$OMP END DO NOWAIT	
+    ENDDO
+  endif
+
+
+  RETURN
+END SUBROUTINE addfi_loc
Index: LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,294 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby,
-     &                        du,dv,dteta)
-      USE parallel_lmdz
-      USE write_field_loc
-      USE advect_new_mod
-      USE comconst_mod, ONLY: daysec
-      USE logic_mod, ONLY: conser
-      
-      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 "comgeom.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.AND.1==0)  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: LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90	(revision 5246)
@@ -0,0 +1,294 @@
+!
+! $Header$
+!
+SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, &
+        du,dv,dteta)
+  USE parallel_lmdz
+  USE write_field_loc
+  USE advect_new_mod
+  USE comconst_mod, ONLY: daysec
+  USE logic_mod, ONLY: conser
+
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   Auteurs:  P. Le Van , Fr. Hourdin  .
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   *************************************************************
+  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+  !   *************************************************************
+  !    ces termes sont ajoutes a du,dv,dteta et dq .
+  !  Modif F.Forget 03/94 : on retire q de advect
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  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)
+  !   Local:
+  !   ------
+
+  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
+
+
+
+  !-----------------------------------------------------------------------
+  !   2. Calculs preliminaires:
+  !   -------------------------
+
+  IF (conser.AND.1==0)  THEN
+     deuxjour = 2. * daysec
+
+     DO  ij   = 1, ip1jmp1
+     unsaire2(ij) = unsaire(ij) * unsaire(ij)
+     END DO
+  END IF
+
+
+  !------------------  -yy ----------------------------------------------
+  !   .  Calcul de     u
+
+!$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
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l=1,llm
+
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_nord) ijb=ijb+iip1
+     if (pole_sud)  ije=ije-iip1
+
+      ! DO    ij     = iip2, ip1jmp1
+      !    uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+      ! ENDDO
+
+      ! DO    ij     = iip2, ip1jm
+      !    uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+      ! 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
+!$OMP END DO
+   ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+
+  !------------------  -xx ----------------------------------------------
+  !   .  Calcul de     v
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+!$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
+!$OMP END DO
+    ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+
+  !-----------------------------------------------------------------------
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llmm1
+
+
+    ! ......   calcul de  - w/2.    au niveau  l+1   .......
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_sud)  ije=ij_end
+
+  DO   ij   = ijb, ije
+  wsur2( ij ) = - 0.5 * w( ij,l+1 )
+  END DO
+
+
+  ! .....................     calcul pour  du     ..................
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+
+  DO 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)
+  END DO
+
+  ! .................    calcul pour   dv      .....................
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO 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)
+  END DO
+
+  !
+
+  ! ............................................................
+  ! ...............    calcul pour   dh      ...................
+  ! ............................................................
+
+  !                   ---z
+  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
+  !               ...............
+    ijb=ij_begin
+    ije=ij_end
+
+    DO ij = ijb, ije
+     ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+     dteta1(ij, l ) =   ww
+     dteta2(ij,l+1) =   ww
+    END DO
+
+  ! ym ---> conser a voir plus tard
+
+   ! IF( conser)  THEN
+  !
+  !    DO 17 ij = 1,ip1jmp1
+  !    ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+  !  17    CONTINUE
+  !    gt       = SSUM( ip1jmp1,ge,1 )
+  !    gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+  !  END IF
+
+  END DO
+!$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
+!$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
+!$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
+
+!$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
+!$OMP END DO NOWAIT
+  ijb=ij_begin
+  ije=ij_end
+
+!$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
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE advect_new_loc
Index: LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,76 +1,0 @@
-      SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:   P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c     calcul de la fonction de Bernouilli aux niveaux s  .....
-c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
-c          bern       est un  argument de sortie pour le s-pg  ......
-c
-c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
-c                              energ.cinet.)
-c
-c=======================================================================
-c
-c-----------------------------------------------------------------------
-c   Decalrations:
-c   -------------
-c
-      include "dimensions.h"
-      include "paramet.h"
-c
-c   Arguments:
-c   ----------
-c
-      INTEGER nlay,ngrid
-      REAL pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay)
-      REAL pbern(ijb_u:ije_u,nlay)
-c
-c   Local:
-c   ------
-c
-      INTEGER   ij,l,ijb,ije,jjb,jje
-c
-c-----------------------------------------------------------------------
-c   calcul de Bernouilli:
-c   ---------------------
-c
-      ijb=ij_begin
-      ije=ij_end+iip1
-      if (pole_sud) ije=ij_end
-
-      jjb=jj_begin
-      jje=jj_end+1
-      if (pole_sud) jje=jj_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)                
-      DO l=1,llm
-    
-        DO 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: LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.f90	(revision 5246)
@@ -0,0 +1,76 @@
+SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  ! calcul de la fonction de Bernouilli aux niveaux s  .....
+  ! phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+  !      bern       est un  argument de sortie pour le s-pg  ......
+  !
+  !    fonction de Bernouilli = bern = filtre de( geopotentiel +
+  !                          energ.cinet.)
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !   Decalrations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !   Arguments:
+  !   ----------
+  !
+  INTEGER :: nlay,ngrid
+  REAL :: pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay)
+  REAL :: pbern(ijb_u:ije_u,nlay)
+  !
+  !   Local:
+  !   ------
+  !
+  INTEGER :: ij,l,ijb,ije,jjb,jje
+  !
+  !-----------------------------------------------------------------------
+  !   calcul de Bernouilli:
+  !   ---------------------
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_sud) ije=ij_end
+
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+
+    DO ij = ijb,ije
+      pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
+    END DO
+
+   ENDDO
+!$OMP END DO NOWAIT
+  !
+  !-----------------------------------------------------------------------
+  !   filtre:
+  !   -------
+  !
+
+
+    CALL filtreg_p( pbern,jjb_u,jje_u,jjb,jje, jjp1, llm, &
+          2,1, .true., 1 )
+  !
+  !-----------------------------------------------------------------------
+
+
+  RETURN
+END SUBROUTINE bernoui_loc
Index: LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,845 +1,0 @@
-!
-! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-      SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum,
-     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
-
-c   AFAIRE
-c   Prevoir en champ nq+1 le diagnostique de l'energie
-c   en faisant Qzon=Cv T + L * ...
-c             vQ..A=Cp T + L * ...
-
-#ifdef CPP_IOIPSL
-      USE IOIPSL
-#endif
-      USE parallel_lmdz
-      USE mod_hallo
-      use misc_mod
-      USE write_field_loc
-      USE comconst_mod, ONLY: cpp, pi
-      USE comvert_mod, ONLY: presnivs
-      USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-      
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-      include "iniprint.h"
-
-c====================================================================
-c
-c   Sous-programme consacre à des diagnostics dynamiques de base
-c
-c 
-c   De facon generale, les moyennes des scalaires Q sont ponderees par
-c   la masse.
-c
-c   Les flux de masse sont eux simplement moyennes.
-c
-c====================================================================
-
-c   Arguments :
-c   ===========
-
-      integer ntrac
-      real dt_app,dt_cum
-      real ps(iip1,jjb_u:jje_u)
-      real masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
-      real flux_u(iip1,jjb_u:jje_u,llm)
-      real flux_v(iip1,jjb_v:jje_v,llm)
-      real teta(iip1,jjb_u:jje_u,llm)
-      real phi(iip1,jjb_u:jje_u,llm)
-      real ucov(iip1,jjb_u:jje_u,llm)
-      real vcov(iip1,jjb_v:jje_v,llm)
-      real trac(iip1,jjb_u:jje_u,llm,ntrac)
-
-c   Local :
-c   =======
-
-      integer,SAVE :: icum,ncum
-!$OMP THREADPRIVATE(icum,ncum)
-      LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)      
-      
-      real zz,zqy
-      REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
-
-      INTEGER,PARAMETER :: nQ=7
-
-
-cym      character*6 nom(nQ)
-cym      character*6 unites(nQ)
-      character(len=6),save :: nom(nQ)
-      character(len=6),save :: unites(nQ)
-
-      character(len=10) file
-      integer ifile
-      parameter (ifile=4)
-
-      integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
-      INTEGER,PARAMETER :: iovap=6,iun=7
-      integer,PARAMETER :: i_sortie=1
-
-      real,SAVE :: time=0.
-      integer,SAVE :: itau=0.
-!$OMP THREADPRIVATE(time,itau)
-
-      real ww
-
-c   variables dynamiques intermédiaires
-      REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
-      REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
-
-c   champ contenant les scalaires advectés.
-      real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
-    
-c   champs cumulés
-      real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
-      real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
-      real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
-      real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
-
- 
-c   champs de tansport en moyenne zonale
-      integer ntr,itr
-      parameter (ntr=5)
-
-cym      character*10 znom(ntr,nQ)
-cym      character*20 znoml(ntr,nQ)
-cym      character*10 zunites(ntr,nQ)
-      character*10,save :: znom(ntr,nQ)
-      character*20,save :: znoml(ntr,nQ)
-      character*10,save :: zunites(ntr,nQ)
-
-      INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
-
-      character*3 ctrs(ntr)
-      data ctrs/'  ','TOT','MMC','TRS','STN'/
-
-      real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
-      real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
-      real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
-
-      real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
-
-      integer i,j,l,iQ
-
-
-c   Initialisation du fichier contenant les moyennes zonales.
-c   ---------------------------------------------------------
-
-      character*10 infile
-
-      integer, save :: fileid
-      integer thoriid, zvertiid
-
-      INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
-
-C   Variables locales
-C
-      integer tau0
-      real zjulian
-      character*3 str
-      character*10 ctrac
-      integer ii,jj
-      integer zan, dayref
-C
-      real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
-      integer :: jjb,jje,jjn,ijb,ije
-      type(Request),SAVE :: Req
-!$OMP THREADPRIVATE(Req)
-
-! definition du domaine d'ecriture pour le rebuild
-
-      INTEGER,DIMENSION(1) :: ddid
-      INTEGER,DIMENSION(1) :: dsg
-      INTEGER,DIMENSION(1) :: dsl
-      INTEGER,DIMENSION(1) :: dpf
-      INTEGER,DIMENSION(1) :: dpl
-      INTEGER,DIMENSION(1) :: dhs
-      INTEGER,DIMENSION(1) :: dhe 
-      
-      INTEGER :: bilan_dyn_domain_id
-
-c=====================================================================
-c   Initialisation
-c=====================================================================
-      if (adjust) return
-      
-      time=time+dt_app
-      itau=itau+1
-
-      if (first) then
-!$OMP BARRIER
-!$OMP MASTER
-      ALLOCATE(zfactv(jjb_v:jje_v,llm))
-      ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(w(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(bern(iip1,jjb_u:jje_u,llm))      
-      ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))      
-      ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
-      ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
-      ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
-      ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
-      ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
-      ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
-      ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
-      ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
-      ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
-      ALLOCATE(zmasse(jjb_v:jje_v,llm))
-      ALLOCATE(zamasse(jjb_v:jje_v))
-      ALLOCATE(zv(jjb_v:jje_v,llm))
-      ALLOCATE(psi(jjb_v:jje_v,llm+1))
-      ALLOCATE(ndex3d(jjb_v:jje_v*llm))
-      ndex3d=0
-      ALLOCATE(rlong(1))
-      ALLOCATE(rlatg(jjm))
-      
-!$OMP END MASTER
-!$OMP BARRIER
-        icum=0
-c       initialisation des fichiers
-        first=.false.
-c   ncum est la frequence de stokage en pas de temps
-        ncum=dt_cum/dt_app
-        if (abs(ncum*dt_app-dt_cum).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
-           CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
-        endif
-
-!$OMP MASTER
-        nom(itemp)='T'
-        nom(igeop)='gz'
-        nom(iecin)='K'
-        nom(iang)='ang'
-        nom(iu)='u'
-        nom(iovap)='ovap'
-        nom(iun)='un'
-
-        unites(itemp)='K'
-        unites(igeop)='m2/s2'
-        unites(iecin)='m2/s2'
-        unites(iang)='ang'
-        unites(iu)='m/s'
-        unites(iovap)='kg/kg'
-        unites(iun)='un'
-
-
-c   Initialisation du fichier contenant les moyennes zonales.
-c   ---------------------------------------------------------
-
-      infile='dynzon'
-
-      zan = annee_ref
-      dayref = day_ref
-      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-      tau0 = itau_dyn
-      
-      rlong=0.
-      rlatg=rlatv*180./pi
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-      IF (pole_sud) THEN
-        jjn=jj_nb-1
-        jje=jj_end-1
-      ENDIF
-
-      ddid=(/ 2 /)
-      dsg=(/ jjm /)
-      dsl=(/ jjn /)
-      dpf=(/ jjb /)
-      dpl=(/ jje /)
-      dhs=(/ 0 /)
-      dhe=(/ 0 /)
-
-      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
-     .                 'box',bilan_dyn_domain_id)
-       
-      call histbeg(trim(infile),
-     .             1, rlong, jjn, rlatg(jjb:jje),
-     .             1, 1, 1, jjn,
-     .             tau0, zjulian, dt_cum, thoriid, fileid,
-     .             bilan_dyn_domain_id)
-
-C
-C  Appel a histvert pour la grille verticale
-C
-      call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
-     .              llm, presnivs, zvertiid)
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-      do iQ=1,nQ
-         do itr=1,ntr
-            if(itr.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.
-          if (pole_sud) jje=jj_end-1
-          flux_v_cum(:,jjb:jje,l)=0.
-          flux_vQ_cum(:,jjb:jje,l,:)=0.
-        ENDDO
-!$OMP END DO NOWAIT
-      endif
-
-      IF (prt_level > 5)
-     . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
-      icum=icum+1
-
-c   accumulation des flux de masse horizontaux
-      jjb=jj_begin
-      jje=jj_end
-
-!$OMP MASTER
-      ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
-!$OMP END MASTER
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
-        flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)
-     .                         +flux_u(:,jjb:jje,l)
-      ENDDO
-!$OMP END DO NOWAIT
-      
-      if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-       flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)
-     .                          +flux_v(:,jjb:jje,l)
-      ENDDO
-!$OMP END DO NOWAIT
-      
-      jjb=jj_begin
-      jje=jj_end
-
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ)
-     .                       +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
-        ENDDO
-!$OMP END DO NOWAIT
-      enddo
-
-c=====================================================================
-c  FLUX ET TENDANCES
-c=====================================================================
-
-c   Flux longitudinal
-c   -----------------
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            do j=jjb,jje
-               do i=1,iim
-                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
-     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
-               enddo
-               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
-            enddo
-         enddo
-!$OMP END DO NOWAIT
-      enddo
-
-c    flux méridien
-c    -------------
-      do iQ=1,nQ
-        call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req) 
-      enddo
-      call SendRequest(Req)
-!$OMP BARRIER      
-      call WaitRequest(Req)
-      
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            do j=jjb,jje
-               do i=1,iip1
-                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
-     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
-               enddo
-            enddo
-         enddo
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-      enddo
-
-c    tendances
-c    ---------
-
-c   convergence horizontale
-      call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
-      call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
-      call SendRequest(Req)
-!$OMP BARRIER      
-      call WaitRequest(Req)
-
-      call  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
-
-c   calcul de la vitesse verticale
-      call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
-      call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
-      call SendRequest(Req)
-!$OMP BARRIER      
-      call WaitRequest(Req)
-
-      call convmas_loc(flux_u_cum,flux_v_cum,convm)
-      CALL vitvert_loc(convm,w)
-!$OMP BARRIER
-
-
-      jjb=jj_begin
-      jje=jj_end
-
-!      do iQ=1,nQ
-!         do l=1,llm-1
-!            do j=jjb,jje
-!               do i=1,iip1
-!                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-!                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-!                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-!               enddo
-!            enddo
-!          enddo
-!       enddo
-       
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            IF (l<llm) THEN
-              do j=jjb,jje
-                 do i=1,iip1
-                    ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-                    dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-                    dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-                 enddo
-              enddo
-            ENDIF
-            IF (l>2) THEN
-              do j=jjb,jje
-                do i=1,iip1
-                  ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
-                  dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
-                enddo
-              enddo
-            ENDIF
-         enddo
-!$OMP ENDDO NOWAIT 
-      enddo
-      IF (prt_level > 5)
-     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
-c=====================================================================
-c   PAS DE TEMPS D'ECRITURE
-c=====================================================================
-      if (icum.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 
-!$OMP BARRIER
-          
-      jjb=jj_begin
-      jje=jj_end
-
-
-c   A retravailler eventuellement
-c   division de dQ par la masse pour revenir aux bonnes grandeurs
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-           dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
-        ENDDO
-!$OMP ENDDO NOWAIT 
-      enddo
-
-c=====================================================================
-c   Transport méridien
-c=====================================================================
-
-c   cumul zonal des masses des mailles
-c   ----------------------------------
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          zv(jjb:jje,l)=0.
-          zmasse(jjb:jje,l)=0.
-        ENDDO
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-
-      call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
-      do iQ=1,nQ
-        call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
-      enddo
-
-      call SendRequest(Req)
-!$OMP BARRIER
-      call WaitRequest(Req)
-
-      call massbar_loc(masse_cum,massebx,masseby)
-      
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do l=1,llm
-         do j=jjb,jje
-            do i=1,iim
-               zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
-               zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
-            enddo
-            zfactv(j,l)=cv(1,j)/zmasse(j,l)
-         enddo
-      enddo
-!$OMP ENDDO NOWAIT 
-!$OMP BARRIER
-
-c     print*,'3OK'
-c   --------------------------------------------------------------
-c   calcul de la moyenne zonale du transport :
-c   ------------------------------------------
-c
-c                                     --
-c TOT : la circulation totale       [ vq ]
-c
-c                                      -     -
-c MMC : mean meridional circulation [ v ] [ q ]
-c
-c                                     ----      --       - -
-c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
-c
-c                                     - * - *       - -       -     -
-c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
-c
-c                                              - -
-c    on utilise aussi l'intermediaire TMP :  [ v q ]
-c
-c    la variable zfactv transforme un transport meridien cumule
-c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
-c
-c   --------------------------------------------------------------
-
-
-c   ----------------------------------------
-c   Transport dans le plan latitude-altitude
-c   ----------------------------------------
-
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-      zvQ=0.
-      psiQ=0.
-      do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         do l=1,llm
-            zvQtmp(:,l)=0.
-            do j=jjb,jje
-c              print*,'j,l,iQ=',j,l,iQ
-c   Calcul des moyennes zonales du transort total et de zvQtmp
-               do i=1,iim
-                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
-     s                            +flux_vQ_cum(i,j,l,iQ)
-                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
-     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
-                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
-     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
-                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
-               enddo
-c              print*,'aOK'
-c   Decomposition
-               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
-               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
-               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
-               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
-               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
-               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
-            enddo
-         enddo
-!$OMP ENDDO NOWAIT 
-c   fonction de courant meridienne pour la quantite Q
-!$OMP BARRIER
-!$OMP MASTER
-         do l=llm,1,-1
-            do j=jjb,jje
-               psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
-            enddo
-         enddo
-!$OMP END MASTER
-!$OMP BARRIER
-      enddo
-
-c   fonction de courant pour la circulation meridienne moyenne
-!$OMP BARRIER
-!$OMP MASTER
-      psi(jjb:jje,:)=0.
-      do l=llm,1,-1
-         do j=jjb,jje
-            psi(j,l)=psi(j,l+1)+zv(j,l)
-            zv(j,l)=zv(j,l)*zfactv(j,l)
-         enddo
-      enddo
-!$OMP END MASTER
-!$OMP BARRIER
-
-c     print*,'4OK'
-c   sorties proprement dites
-!$OMP MASTER      
-      if (i_sortie.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=====================================================================
-!$OMP MASTER
-      call histsync(fileid)
-!$OMP END MASTER
-
-
-      return
-      end
Index: LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90	(revision 5246)
@@ -0,0 +1,845 @@
+!
+! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, &
+        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+  !   AFAIRE
+  !   Prevoir en champ nq+1 le diagnostique de l'energie
+  !   en faisant Qzon=Cv T + L * ...
+  !             vQ..A=Cp T + L * ...
+
+#ifdef CPP_IOIPSL
+  USE IOIPSL
+#endif
+  USE parallel_lmdz
+  USE mod_hallo
+  use misc_mod
+  USE write_field_loc
+  USE comconst_mod, ONLY: cpp, pi
+  USE comvert_mod, ONLY: presnivs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+
+  !====================================================================
+  !
+  !   Sous-programme consacre à des diagnostics dynamiques de base
+  !
+  !
+  !   De facon generale, les moyennes des scalaires Q sont ponderees par
+  !   la masse.
+  !
+  !   Les flux de masse sont eux simplement moyennes.
+  !
+  !====================================================================
+
+  !   Arguments :
+  !   ===========
+
+  integer :: ntrac
+  real :: dt_app,dt_cum
+  real :: ps(iip1,jjb_u:jje_u)
+  real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
+  real :: flux_u(iip1,jjb_u:jje_u,llm)
+  real :: flux_v(iip1,jjb_v:jje_v,llm)
+  real :: teta(iip1,jjb_u:jje_u,llm)
+  real :: phi(iip1,jjb_u:jje_u,llm)
+  real :: ucov(iip1,jjb_u:jje_u,llm)
+  real :: vcov(iip1,jjb_v:jje_v,llm)
+  real :: trac(iip1,jjb_u:jje_u,llm,ntrac)
+
+  !   Local :
+  !   =======
+
+  integer,SAVE :: icum,ncum
+!$OMP THREADPRIVATE(icum,ncum)
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  real :: zz,zqy
+  REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
+
+  INTEGER,PARAMETER :: nQ=7
+
+
+  !ym      character*6 nom(nQ)
+  !ym      character*6 unites(nQ)
+  character(len=6),save :: nom(nQ)
+  character(len=6),save :: unites(nQ)
+
+  character(len=10) file
+  integer :: ifile
+  parameter (ifile=4)
+
+  integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
+  INTEGER,PARAMETER :: iovap=6,iun=7
+  integer,PARAMETER :: i_sortie=1
+
+  real,SAVE :: time=0.
+  integer,SAVE :: itau=0.
+!$OMP THREADPRIVATE(time,itau)
+
+  real :: ww
+
+  !   variables dynamiques intermédiaires
+  REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
+
+  !   champ contenant les scalaires advectés.
+  real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
+
+  !   champs cumulés
+  real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
+  real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
+
+
+  !   champs de tansport en moyenne zonale
+  integer :: ntr,itr
+  parameter (ntr=5)
+
+  !ym      character*10 znom(ntr,nQ)
+  !ym      character*20 znoml(ntr,nQ)
+  !ym      character*10 zunites(ntr,nQ)
+  character*10,save :: znom(ntr,nQ)
+  character*20,save :: znoml(ntr,nQ)
+  character*10,save :: zunites(ntr,nQ)
+
+  INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
+
+  character(len=3) :: ctrs(ntr)
+  data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+  real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
+  real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
+  real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
+
+  real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
+
+  integer :: i,j,l,iQ
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  character(len=10) :: infile
+
+  integer, save :: fileid
+  integer :: thoriid, zvertiid
+
+  INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
+
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: ii,jj
+  integer :: zan, dayref
+  !
+  real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
+  integer :: jjb,jje,jjn,ijb,ije
+  type(Request),SAVE :: Req
+!$OMP THREADPRIVATE(Req)
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(1) :: ddid
+  INTEGER,DIMENSION(1) :: dsg
+  INTEGER,DIMENSION(1) :: dsl
+  INTEGER,DIMENSION(1) :: dpf
+  INTEGER,DIMENSION(1) :: dpl
+  INTEGER,DIMENSION(1) :: dhs
+  INTEGER,DIMENSION(1) :: dhe
+
+  INTEGER :: bilan_dyn_domain_id
+
+  !=====================================================================
+  !   Initialisation
+  !=====================================================================
+  if (adjust) return
+
+  time=time+dt_app
+  itau=itau+1
+
+  if (first) then
+!$OMP BARRIER
+!$OMP MASTER
+  ALLOCATE(zfactv(jjb_v:jje_v,llm))
+  ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(w(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(bern(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
+  ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
+  ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
+  ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
+  ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
+  ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
+  ALLOCATE(zmasse(jjb_v:jje_v,llm))
+  ALLOCATE(zamasse(jjb_v:jje_v))
+  ALLOCATE(zv(jjb_v:jje_v,llm))
+  ALLOCATE(psi(jjb_v:jje_v,llm+1))
+  ALLOCATE(ndex3d(jjb_v:jje_v*llm))
+  ndex3d=0
+  ALLOCATE(rlong(1))
+  ALLOCATE(rlatg(jjm))
+
+!$OMP END MASTER
+!$OMP BARRIER
+    icum=0
+    ! initialisation des fichiers
+    first=.false.
+  !   ncum est la frequence de stokage en pas de temps
+    ncum=dt_cum/dt_app
+    if (abs(ncum*dt_app-dt_cum).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
+       CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
+    endif
+
+!$OMP MASTER
+    nom(itemp)='T'
+    nom(igeop)='gz'
+    nom(iecin)='K'
+    nom(iang)='ang'
+    nom(iu)='u'
+    nom(iovap)='ovap'
+    nom(iun)='un'
+
+    unites(itemp)='K'
+    unites(igeop)='m2/s2'
+    unites(iecin)='m2/s2'
+    unites(iang)='ang'
+    unites(iu)='m/s'
+    unites(iovap)='kg/kg'
+    unites(iun)='un'
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  infile='dynzon'
+
+  zan = annee_ref
+  dayref = day_ref
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  rlong=0.
+  rlatg=rlatv*180./pi
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) THEN
+    jjn=jj_nb-1
+    jje=jj_end-1
+  ENDIF
+
+  ddid=(/ 2 /)
+  dsg=(/ jjm /)
+  dsl=(/ jjn /)
+  dpf=(/ jjb /)
+  dpl=(/ jje /)
+  dhs=(/ 0 /)
+  dhe=(/ 0 /)
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',bilan_dyn_domain_id)
+
+  call histbeg(trim(infile), &
+        1, rlong, jjn, rlatg(jjb:jje), &
+        1, 1, 1, jjn, &
+        tau0, zjulian, dt_cum, thoriid, fileid, &
+        bilan_dyn_domain_id)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
+        llm, presnivs, zvertiid)
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  do iQ=1,nQ
+     do itr=1,ntr
+        if(itr.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
+
+  !   Declarations des champs avec dimension verticale
+   ! print*,'1HISTDEF'
+  do iQ=1,nQ
+     do itr=1,ntr
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'var ',itr,iQ &
+        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+        call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  !   Declarations pour les fonctions de courant
+   ! print*,'2HISTDEF'
+      call histdef(fileid,'psi'//nom(iQ) &
+            ,'stream fn. '//znoml(itot,iQ), &
+            zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+  enddo
+
+
+  !   Declarations pour les champs de transport d'air
+   ! print*,'3HISTDEF'
+  call histdef(fileid, 'masse', 'masse', &
+        'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  call histdef(fileid, 'v', 'v', &
+        'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  !   Declarations pour les fonctions de courant
+   ! print*,'4HISTDEF'
+      call histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
+            1,jjn,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+
+
+  !   Declaration des champs 1D de transport en latitude
+   ! print*,'5HISTDEF'
+  do iQ=1,nQ
+     do itr=2,ntr
+        call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  enddo
+
+
+   ! print*,'8HISTDEF'
+           CALL histend(fileid)
+
+!$OMP END MASTER
+  endif
+
+
+  !=====================================================================
+  !   Calcul des champs dynamiques
+  !   ----------------------------
+
+  jjb=jj_begin
+  jje=jj_end
+
+  !   énergie cinétique
+   ! ucont(:,jjb:jje,:)=0
+
+  call Register_Hallo_u(ucov,llm,1,1,1,1,Req)
+  call Register_Hallo_v(vcov,llm,1,1,1,1,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+  CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+
+  !   moment cinétique
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
+     unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
+  enddo
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
+    Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
+    Q(:,jjb:jje,l,iun)=1.
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !=====================================================================
+  !   Cumul
+  !=====================================================================
+  !
+  if(icum.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.
+      if (pole_sud) jje=jj_end-1
+      flux_v_cum(:,jjb:jje,l)=0.
+      flux_vQ_cum(:,jjb:jje,l,:)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+  icum=icum+1
+
+  !   accumulation des flux de masse horizontaux
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP MASTER
+  ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
+!$OMP END MASTER
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) &
+          +flux_u(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) &
+         +flux_v(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  jjb=jj_begin
+  jje=jj_end
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
+    ENDDO
+!$OMP END DO NOWAIT
+  enddo
+
+  !=====================================================================
+  !  FLUX ET TENDANCES
+  !=====================================================================
+
+  !   Flux longitudinal
+  !   -----------------
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iim
+              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
+                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+           enddo
+           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+        enddo
+     enddo
+!$OMP END DO NOWAIT
+  enddo
+
+  !    flux méridien
+  !    -------------
+  do iQ=1,nQ
+    call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iip1
+              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
+                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+           enddo
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  enddo
+
+  !    tendances
+  !    ---------
+
+  !   convergence horizontale
+  call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
+  call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  call  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+  !   calcul de la vitesse verticale
+  call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
+  call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  call convmas_loc(flux_u_cum,flux_v_cum,convm)
+  CALL vitvert_loc(convm,w)
+!$OMP BARRIER
+
+
+  jjb=jj_begin
+  jje=jj_end
+
+   ! do iQ=1,nQ
+   !    do l=1,llm-1
+   !       do j=jjb,jje
+   !          do i=1,iip1
+   !             ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+   !             dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+   !             dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+   !          enddo
+   !       enddo
+   !     enddo
+   !  enddo
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        IF (l<llm) THEN
+          do j=jjb,jje
+             do i=1,iip1
+                ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+             enddo
+          enddo
+        ENDIF
+        IF (l>2) THEN
+          do j=jjb,jje
+            do i=1,iip1
+              ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
+              dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
+            enddo
+          enddo
+        ENDIF
+     enddo
+!$OMP ENDDO NOWAIT
+  enddo
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+  !=====================================================================
+  !   PAS DE TEMPS D'ECRITURE
+  !=====================================================================
+  if (icum.eq.ncum) then
+  !=====================================================================
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Pas d ecriture'
+
+  jjb=jj_begin
+  jje=jj_end
+
+  !   Normalisation
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            /masse_cum(:,jjb:jje,l)
+    enddo
+!$OMP ENDDO NOWAIT
+  enddo
+
+  zz=1./REAL(ncum)
+
+!$OMP MASTER
+    ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
+!$OMP END MASTER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
+    flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
+    dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
+    flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  jjb=jj_begin
+  jje=jj_end
+
+
+  !   A retravailler eventuellement
+  !   division de dQ par la masse pour revenir aux bonnes grandeurs
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
+    ENDDO
+!$OMP ENDDO NOWAIT
+  enddo
+
+  !=====================================================================
+  !   Transport méridien
+  !=====================================================================
+
+  !   cumul zonal des masses des mailles
+  !   ----------------------------------
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      zv(jjb:jje,l)=0.
+      zmasse(jjb:jje,l)=0.
+    ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
+  do iQ=1,nQ
+    call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  call massbar_loc(masse_cum,massebx,masseby)
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        do i=1,iim
+           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+        enddo
+        zfactv(j,l)=cv(1,j)/zmasse(j,l)
+     enddo
+  enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  ! print*,'3OK'
+  !   --------------------------------------------------------------
+  !   calcul de la moyenne zonale du transport :
+  !   ------------------------------------------
+  !
+  !                                 --
+  ! TOT : la circulation totale       [ vq ]
+  !
+  !                                  -     -
+  ! MMC : mean meridional circulation [ v ] [ q ]
+  !
+  !                                 ----      --       - -
+  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+  !
+  !                                 - * - *       - -       -     -
+  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+  !
+  !                                          - -
+  !    on utilise aussi l'intermediaire TMP :  [ v q ]
+  !
+  !    la variable zfactv transforme un transport meridien cumule
+  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+  !
+  !   --------------------------------------------------------------
+
+
+  !   ----------------------------------------
+  !   Transport dans le plan latitude-altitude
+  !   ----------------------------------------
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  zvQ=0.
+  psiQ=0.
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        zvQtmp(:,l)=0.
+        do j=jjb,jje
+           ! print*,'j,l,iQ=',j,l,iQ
+  !   Calcul des moyennes zonales du transort total et de zvQtmp
+           do i=1,iim
+              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
+                    +flux_vQ_cum(i,j,l,iQ)
+              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
+                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
+                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+           enddo
+           ! print*,'aOK'
+  !   Decomposition
+           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+  !   fonction de courant meridienne pour la quantite Q
+!$OMP BARRIER
+!$OMP MASTER
+     do l=llm,1,-1
+        do j=jjb,jje
+           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+        enddo
+     enddo
+!$OMP END MASTER
+!$OMP BARRIER
+  enddo
+
+  !   fonction de courant pour la circulation meridienne moyenne
+!$OMP BARRIER
+!$OMP MASTER
+  psi(jjb:jje,:)=0.
+  do l=llm,1,-1
+     do j=jjb,jje
+        psi(j,l)=psi(j,l+1)+zv(j,l)
+        zv(j,l)=zv(j,l)*zfactv(j,l)
+     enddo
+  enddo
+!$OMP END MASTER
+!$OMP BARRIER
+
+  ! print*,'4OK'
+  !   sorties proprement dites
+!$OMP MASTER
+  if (i_sortie.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, &
+              zvQ(jjb:jje,:,itr,iQ) &
+              ,jjn*llm,ndex3d)
+     enddo
+     call histwrite(fileid,'psi'//nom(iQ), &
+           itau,psiQ(jjb:jje,1:llm,iQ) &
+           ,jjn*llm,ndex3d)
+  enddo
+
+  call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
+  call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), &
+        jjn*llm,ndex3d)
+
+  endif
+
+
+  !   -----------------
+  !   Moyenne verticale
+  !   -----------------
+
+  zamasse(jjb:jje)=0.
+  do l=1,llm
+     zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
+  enddo
+
+  zavQ(jjb:jje,:,:)=0.
+  do iQ=1,nQ
+     do itr=2,ntr
+        do l=1,llm
+           zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) &
+                 +zvQ(jjb:jje,l,itr,iQ) &
+                 *zmasse(jjb:jje,l)
+        enddo
+        zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
+        call histwrite(fileid,'a'//znom(itr,iQ),itau, &
+              zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
+     enddo
+  enddo
+!$OMP END MASTER
+  ! on doit pouvoir tracer systematiquement la fonction de courant.
+
+  !=====================================================================
+  !/////////////////////////////////////////////////////////////////////
+  icum=0                  !///////////////////////////////////////
+  endif ! icum.eq.ncum    !///////////////////////////////////////
+  !/////////////////////////////////////////////////////////////////////
+  !=====================================================================
+!$OMP MASTER
+  call histsync(fileid)
+!$OMP END MASTER
+
+
+  return
+end subroutine bilan_dyn_loc
Index: LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,217 +1,0 @@
-!
-! $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_lmdz 
-      USE infotrac, ONLY : nqtot
-      USE control_mod, ONLY : iapp_tracvl,planet_type
-      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"
-
-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, nqtot )
-      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),SAVE :: Request_vanleer
-!$OMP THREADPRIVATE(Request_vanleer)
-
-      !write(*,*) 'caladvtrac 58: entree'     
-      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
-      !write(*,*) 'caladvtrac 133'
-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.
-
-        CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-        flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl)
-      ENDDO
-c$OMP ENDDO NOWAIT
-
-#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        
-      !write(*,*) 'caladvtrac 185'  
-      CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, 
-     *             p_adv,  massem_adv,q_adv, teta_adv,
-     .             pk_adv)     
-      !write(*,*) 'caladvtrac 189'
-
-
-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: LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90	(revision 5246)
@@ -0,0 +1,217 @@
+!
+! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+!
+!
+      SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , &
+              p ,masse, dq ,  teta, &
+              flxw, pk, iapptrac)
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot
+  USE control_mod, ONLY : iapp_tracvl,planet_type
+  USE caladvtrac_mod
+  USE mod_hallo
+  USE bands
+  USE times
+  USE Vampir
+  USE write_field_loc
+  !
+  IMPLICIT NONE
+  !
+  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+  !
+  ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+  !=======================================================================
+  !
+  !   Shema de  Van Leer
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  !   Arguments:
+  !   ----------
+  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, nqtot )
+  REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm)
+  REAL :: flxw(ijb_u:ije_u,llm)
+  INTEGER :: iapptrac
+  !   Local:
+  !   ------
+   ! 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),SAVE :: Request_vanleer
+!$OMP THREADPRIVATE(Request_vanleer)
+
+  ! !write(*,*) 'caladvtrac 58: entree'
+  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
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      pbaruc(ijbu:ijeu,l)=0.
+      pbarvc(ijbv:ijev,l)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  !   accumulation des flux de masse horizontaux
+!$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
+!$OMP END DO NOWAIT
+
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(iadvtr.EQ.0) THEN
+
+      ijb=ij_begin
+      ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l=1,llm
+      massem(ijb:ije,l)=masse(ijb:ije,l)
+   ENDDO
+!$OMP END DO NOWAIT
+
+  ENDIF
+
+  iadvtr   = iadvtr+1
+
+!$OMP MASTER
+  iapptrac = iadvtr
+!$OMP END MASTER
+
+  !   Test pour savoir si on advecte a ce pas de temps
+
+  IF ( iadvtr.EQ.iapp_tracvl ) THEN
+  ! !write(*,*) 'caladvtrac 133'
+!$OMP MASTER
+    call suspend_timer(timer_caldyn)
+!$OMP END MASTER
+
+  ijb=ij_begin
+  ije=ij_end
+
+  !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
+  !c
+
+  !   traitement des flux de masse avant advection.
+  ! 1. calcul de w
+  ! 2. groupement des mailles pres du pole.
+
+    CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl)
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+#ifdef DEBUG_IO
+     CALL WriteField_u('pbarug1',pbarug)
+     CALL WriteField_v('pbarvg1',pbarvg)
+     CALL WriteField_u('wg1',wg)
+#endif
+
+!$OMP BARRIER
+
+
+!$OMP MASTER
+  call VTb(VTHallo)
+!$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)
+!$OMP BARRIER
+  call WaitRequest(Request_vanleer)
+
+
+!$OMP BARRIER
+!$OMP MASTER
+  call Set_Distrib(distrib_vanleer)
+  call VTe(VTHallo)
+  call VTb(VTadvection)
+  call start_timer(timer_vanleer)
+!$OMP END MASTER
+!$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
+  ! !write(*,*) 'caladvtrac 185'
+  CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, &
+        p_adv,  massem_adv,q_adv, teta_adv, &
+        pk_adv)
+  ! !write(*,*) 'caladvtrac 189'
+
+
+!$OMP MASTER
+    call VTe(VTadvection)
+    call stop_timer(timer_vanleer)
+    call VTb(VThallo)
+!$OMP END MASTER
+
+    call Register_SwapField_u(q_adv,q,distrib_caldyn, &
+          Request_vanleer)
+
+    call SendRequest(Request_vanleer)
+!$OMP BARRIER
+    call WaitRequest(Request_vanleer)
+
+!$OMP BARRIER
+!$OMP MASTER
+    call Set_Distrib(distrib_caldyn)
+    call VTe(VThallo)
+    call resume_timer(timer_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      iadvtr=0
+   ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+END SUBROUTINE caladvtrac_loc
+
+
Index: LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,185 +1,0 @@
-!
-! $Id: $
-!
-#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_lmdz
-      USE Write_Field_loc
-      USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby,
-     &                      vorpot, ecin, bern, massebxy, convm
-      USE comvert_mod, ONLY: ap, bp
-      
-      IMPLICIT NONE
-
-!=======================================================================
-!
-!  Auteur :  P. Le Van
-!
-!   Objet:
-!   ------
-!
-!   Calcul des tendances dynamiques.
-!
-! Modif 04/93 F.Forget
-!=======================================================================
-
-!-----------------------------------------------------------------------
-!   0. Declarations:
-!   ----------------
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-
-!   Arguments:
-!   ----------
-
-      LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used
-      INTEGER,INTENT(IN) :: itau ! time step index ! not used
-      REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
-      REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
-      REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
-      REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure
-      REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface
-      REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
-      REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner
-      REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential
-      REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass
-      REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov
-      REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov
-      REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta
-      REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps
-      REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity
-      REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction
-      REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction
-      REAL,INTENT(IN) :: time ! current time
-
-!   Local:
-!   ------
-
-      INTEGER   ij,l,ijb,ije,ierr
-
-
-!-----------------------------------------------------------------------
-!   Compute dynamical tendencies:
-!--------------------------------
-
-      ! compute contravariant winds ucont() and vcont
-      CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
-      ! compute pressure p()
-      CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
-cym      CALL psextbar (   ps   , psexbarxy                          )
-c$OMP BARRIER
-      ! compute mass in each atmospheric mesh: masse()
-      CALL massdair_loc (    p   , masse                             )
-      ! compute X and Y-averages of mass, massebx() and masseby()
-      CALL massbar_loc  (   masse, massebx , masseby                 )
-      ! compute XY-average of mass, massebxy()
-      call massbarxy_loc(   masse, massebxy                          )
-      ! compute mass fluxes pbaru() and pbarv()
-      CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
-      ! compute dteta() , horizontal converging flux of theta
-      CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
-      ! compute convm(), horizontal converging flux of mass
-      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
-      ! compute pressure variation due to mass convergence
-      DO ij =ijb, ije
-         dp( ij ) = convm( ij,1 ) / airesurg( ij )
-      ENDDO
-c$OMP END MASTER
-c$OMP BARRIER
-      
-      ! compute vertical velocity w()
-      CALL vitvert_loc ( convm  , w                                )
-      ! compute potential vorticity vorpot()
-      CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
-      ! compute rotation induced du() and dv()
-      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      
-      
-      ! compute kinetic energy ecin()
-      CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
-      ! compute Bernouilli function bern()
-      CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
-      ! compute and add du() and dv() contributions from Bernouilli and pressure
-      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
-
-      ! compute vertical advection contributions to du(), dv() and dteta()
-      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      
-
-! Ehouarn: NB: output of control variables not implemented...
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90	(revision 5246)
@@ -0,0 +1,185 @@
+!
+! $Id: $
+!
+#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_lmdz
+  USE Write_Field_loc
+  USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby, &
+        vorpot, ecin, bern, massebxy, convm
+  USE comvert_mod, ONLY: ap, bp
+
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !  Auteur :  P. Le Van
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Calcul des tendances dynamiques.
+  !
+  ! Modif 04/93 F.Forget
+  !=======================================================================
+
+  !-----------------------------------------------------------------------
+  !   0. Declarations:
+  !   ----------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used
+  INTEGER,INTENT(IN) :: itau ! time step index ! not used
+  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure
+  REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface
+  REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
+  REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner
+  REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential
+  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass
+  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov
+  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov
+  REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta
+  REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps
+  REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity
+  REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction
+  REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction
+  REAL,INTENT(IN) :: time ! current time
+
+  !   Local:
+  !   ------
+
+  INTEGER :: ij,l,ijb,ije,ierr
+
+
+  !-----------------------------------------------------------------------
+  !   Compute dynamical tendencies:
+  !--------------------------------
+
+  ! ! compute contravariant winds ucont() and vcont
+  CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
+  ! ! compute pressure p()
+  CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
+  !ym      CALL psextbar (   ps   , psexbarxy                          )
+!$OMP BARRIER
+  ! ! compute mass in each atmospheric mesh: masse()
+  CALL massdair_loc (    p   , masse                             )
+  ! ! compute X and Y-averages of mass, massebx() and masseby()
+  CALL massbar_loc  (   masse, massebx , masseby                 )
+  ! ! compute XY-average of mass, massebxy()
+  call massbarxy_loc(   masse, massebxy                          )
+  ! ! compute mass fluxes pbaru() and pbarv()
+  CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
+  ! ! compute dteta() , horizontal converging flux of theta
+  CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
+  ! ! compute convm(), horizontal converging flux of mass
+  CALL convmas1_loc  (   pbaru, pbarv   , convm                  )
+!$OMP BARRIER
+  CALL convmas2_loc  (   convm                      )
+!$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
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  ! ! compute pressure variation due to mass convergence
+  DO ij =ijb, ije
+     dp( ij ) = convm( ij,1 ) / airesurg( ij )
+  ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+
+  ! ! compute vertical velocity w()
+  CALL vitvert_loc ( convm  , w                                )
+  ! ! compute potential vorticity vorpot()
+  CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
+  ! ! compute rotation induced du() and dv()
+  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
+
+  ! ! compute kinetic energy ecin()
+  CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
+  ! ! compute Bernouilli function bern()
+  CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
+  ! ! compute and add du() and dv() contributions from Bernouilli and pressure
+  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
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        ang(ij,l) = ucov(ij,l) + constang(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO
+
+  ! ! compute vertical advection contributions to du(), dv() and dteta()
+  CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta)
+
+  !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
+       ! probablement. Observe sur le code compile avec pgf90 3.0-1
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+
+!$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
+      ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
+  !    ,   ' dans caldyn'
+      ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+      dv(ij+iim,l) = dv(ij,l)
+      endif
+     enddo
+  enddo
+!$OMP END DO NOWAIT
+
+  ! Ehouarn: NB: output of control variables not implemented...
+
+  RETURN
+END SUBROUTINE caldyn_loc
Index: LMDZ6/trunk/libf/dyn3dmem/convflu_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/convflu_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,84 +1,0 @@
-      SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl )
-c
-c  P. Le Van
-c
-c
-c    *******************************************************************
-c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
-c      composantes xflu et yflu ,variables extensives .  ......
-c    *******************************************************************
-c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
-c      convfl                est  un argument de sortie pour le s-pg .
-c
-c     njxflu  est le nombre de lignes de latitude de xflu, 
-c     ( = jjm ou jjp1 )
-c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      REAL       xflu,yflu,convfl,convpn,convps
-      INTEGER    l,ij,nbniv
-      DIMENSION  xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) ,
-     *         convfl( ijb_u:ije_u,nbniv )
-c
-      INTEGER ijb,ije
-      EXTERNAL   SSUM
-      REAL       SSUM
-c
-c
-      INCLUDE "comgeom.h"
-c
-     
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/convflu_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/convflu_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/convflu_loc.f90	(revision 5246)
@@ -0,0 +1,84 @@
+SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl )
+  !
+  !  P. Le Van
+  !
+  !
+  !    *******************************************************************
+  !  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+  !  composantes xflu et yflu ,variables extensives .  ......
+  !    *******************************************************************
+  !  xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+  !  convfl                est  un argument de sortie pour le s-pg .
+  !
+  ! njxflu  est le nombre de lignes de latitude de xflu,
+  ! ( = jjm ou jjp1 )
+  ! nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  REAL :: xflu,yflu,convfl,convpn,convps
+  INTEGER :: l,ij,nbniv
+  DIMENSION  xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) , &
+        convfl( ijb_u:ije_u,nbniv )
+  !
+  INTEGER :: ijb,ije
+  EXTERNAL   SSUM
+  REAL :: SSUM
+  !
+  !
+  INCLUDE "comgeom.h"
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,nbniv
+  !
+    ijb=ij_begin
+    ije=ij_end+iip1
+
+    IF (pole_nord) ijb=ij_begin+iip1
+    IF (pole_sud)  ije=ij_end-iip1
+
+    DO  ij = ijb , ije - 1
+      convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   + &
+            yflu(ij +1,l ) - yflu( ij -iim,l )
+    END DO
+  !
+  !
+
+  ! ....  correction pour  convfl( 1,j,l)  ......
+  ! ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+  !
+  !DIR$ IVDEP
+    DO ij = ijb,ije,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+    END DO
+  !
+  ! ......  calcul aux poles  .......
+  !
+    IF (pole_nord) THEN
+
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+
+      DO ij = 1,iip1
+        convfl(ij,l) = convpn * aire(ij) / apoln
+      ENDDO
+
+    ENDIF
+
+    IF (pole_sud) THEN
+
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+
+      DO ij = 1,iip1
+        convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
+      ENDDO
+
+    ENDIF
+
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE convflu_loc
Index: LMDZ6/trunk/libf/dyn3dmem/covcont_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/covcont_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,59 +1,0 @@
-      SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
-      USE parallel_lmdz
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c  *********************************************************************
-c    calcul des compos. contravariantes a partir des comp.covariantes
-c  ********************************************************************
-c
-c=======================================================================
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      INTEGER klevel
-      REAL ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
-      REAL ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      INTEGER ijbu,ijbv,ijeu,ijev
-
-      
-      ijbu=ij_begin-iip1
-      ijbv=ij_begin-iip1
-      ijeu=ij_end+iip1
-      ijev=ij_end+iip1
-      
-      if (pole_nord) then 
-        ijbu=ij_begin+iip1
-        ijbv=ij_begin
-      endif
-      
-      if (pole_sud) then
-        ijeu=ij_end-iip1
-        ijev=ij_end-iip1
-      endif
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/covcont_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/covcont_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/covcont_loc.f90	(revision 5246)
@@ -0,0 +1,59 @@
+SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
+  USE parallel_lmdz
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !  *********************************************************************
+  !    calcul des compos. contravariantes a partir des comp.covariantes
+  !  ********************************************************************
+  !
+  !=======================================================================
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  INTEGER :: klevel
+  REAL :: ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+  REAL :: ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijbu,ijbv,ijeu,ijev
+
+
+  ijbu=ij_begin-iip1
+  ijbv=ij_begin-iip1
+  ijeu=ij_end+iip1
+  ijev=ij_end+iip1
+
+  if (pole_nord) then
+    ijbu=ij_begin+iip1
+    ijbv=ij_begin
+  endif
+
+  if (pole_sud) then
+    ijeu=ij_end-iip1
+    ijev=ij_end-iip1
+  endif
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+
+  DO  ij = ijb_u,ije_u
+  ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+  END DO
+
+  DO ij = ijb_v,ije_v
+  vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+  END DO
+
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE covcont_loc
Index: LMDZ6/trunk/libf/dyn3dmem/covnat_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/covnat_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,84 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
-      USE parallel_lmdz
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  F Hourdin Phu LeVan
-c   -------
-c
-c   Objet:
-c   ------
-c
-c  *********************************************************************
-c    calcul des compos. naturelles a partir des comp.covariantes
-c  ********************************************************************
-c
-c=======================================================================
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-      INTEGER klevel
-      REAL ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
-      REAL unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      INTEGER :: ijb,ije
-      
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-      if (pole_nord) then
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l = 1,klevel
-           DO ij = 1, iip1
-              unat (ij,l) =0.
-           END DO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-
-      if (pole_sud) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l = 1,klevel
-           DO ij = ip1jm+1, ip1jmp1  
-            unat (ij,l) =0.
-           END DO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l = 1,klevel
-         DO ij = ijb, ije
-            unat( ij,l ) = ucov( ij,l ) / cu(ij)
-         ENDDO
-      END DO
-!$OMP ENDDO NOWAIT
-
-      ijb=ij_begin-iip1
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-     
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l = 1,klevel
-         DO ij = ijb,ije
-            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
-         ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-      
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/covnat_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/covnat_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/covnat_loc.f90	(revision 5246)
@@ -0,0 +1,84 @@
+!
+! $Header$
+!
+SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
+  USE parallel_lmdz
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  F Hourdin Phu LeVan
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !  *********************************************************************
+  !    calcul des compos. naturelles a partir des comp.covariantes
+  !  ********************************************************************
+  !
+  !=======================================================================
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  INTEGER :: klevel
+  REAL :: ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+  REAL :: unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+
+
+  ijb=ij_begin
+  ije=ij_end
+
+  if (pole_nord) then
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1,klevel
+       DO ij = 1, iip1
+          unat (ij,l) =0.
+       END DO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1,klevel
+       DO ij = ip1jm+1, ip1jmp1
+        unat (ij,l) =0.
+       END DO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+     DO ij = ijb, ije
+        unat( ij,l ) = ucov( ij,l ) / cu(ij)
+     ENDDO
+  END DO
+!$OMP ENDDO NOWAIT
+
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+     DO ij = ijb,ije
+        vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  RETURN
+END SUBROUTINE covnat_loc
Index: LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,234 +1,0 @@
-!
-! $Id: $
-!
-      SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
-c
-      USE parallel_lmdz
-      USE write_field_loc
-      USE dissip_mod, ONLY: dissip_allocate
-      USE comconst_mod, ONLY: dtdiss
-      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 "comgeom.h"
-      include "comdissnew.h"
-      include "comdissipn.h"
-
-c   Arguments:
-c   ----------
-
-      REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
-      REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
-      REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
-      REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
-      ! tendencies (.../s) on covariant winds and potential temperature
-      REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
-      REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
-      REAL,INTENT(OUT) :: 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)
-
-      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: LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90	(revision 5246)
@@ -0,0 +1,234 @@
+!
+! $Id: $
+!
+SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
+  !
+  USE parallel_lmdz
+  USE write_field_loc
+  USE dissip_mod, ONLY: dissip_allocate
+  USE comconst_mod, ONLY: dtdiss
+  IMPLICIT NONE
+
+
+  ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+                              ! (  10/01/98  )
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Dissipation horizontale
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "comdissnew.h"
+  include "comdissipn.h"
+
+  !   Arguments:
+  !   ----------
+
+  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
+  ! ! tendencies (.../s) on covariant winds and potential temperature
+  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
+  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
+  REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm)
+
+  !   Local:
+  !   ------
+
+  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)
+
+  IF (first) THEN
+    CALL dissip_allocate
+    first=.FALSE.
+  ENDIF
+  !-----------------------------------------------------------------------
+  !   initialisations:
+  !   ----------------
+
+!$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
+!$OMP END DO NOWAIT
+   ! CALL initial0( ijp1llm, du )
+   ! CALL initial0( ijmllm , dv )
+   ! CALL initial0( ijp1llm, dh )
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    du(ijb:ije,l)=0
+    dh(ijb:ije,l)=0
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    dv(ijb:ije,l)=0
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !-----------------------------------------------------------------------
+  !   Calcul de la dissipation:
+  !   -------------------------
+
+  !   Calcul de la partie   grad  ( div ) :
+  !   -------------------------------------
+
+
+
+  IF(lstardis) THEN
+   ! 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
+
+!$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
+!$OMP END DO NOWAIT
+  !   calcul de la partie   n X grad ( rot ):
+  !   ---------------------------------------
+
+  IF(lstardis) THEN
+   ! 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
+
+!$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
+!$OMP END DO NOWAIT
+
+  !   calcul de la partie   div ( grad ):
+  !   -----------------------------------
+
+
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$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
+!$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
+
+!$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
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE dissip_loc
Index: LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,98 +1,0 @@
-      SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam,
-     *                       unsapolnga,unsapolsga,  x, y,  div )
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
-      REAL div( ijb_u:ije_u,klevel )
-      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
-      REAL unsapolnga,unsapolsga
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-      INTEGER   l,ij
-c    ...................................................................
-c
-      EXTERNAL  SSUM
-      REAL      SSUM
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if(pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.f90	(revision 5246)
@@ -0,0 +1,98 @@
+SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam, &
+        unsapolnga,unsapolsga,  x, y,  div )
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
+  REAL :: div( ijb_u:ije_u,klevel )
+  REAL :: cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+  REAL :: unsapolnga,unsapolsga
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: l,ij
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = ( &
+           cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + &
+           cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* &
+           unsairegam( ij+1 )
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+   if (pole_nord) then
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+   endif
+
+    if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+   endif
+  END DO
+!$OMP END DO NOWAIT
+  !
+
+   RETURN
+END SUBROUTINE diverg_gam_loc
Index: LMDZ6/trunk/libf/dyn3dmem/diverg_p.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/diverg_p.F	(revision 5214)
+++ 	(revision )
@@ -1,106 +1,0 @@
-      SUBROUTINE diverg_p(klevel,x,y,div)
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
-      INTEGER   l,ij
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-      INTEGER ijb,ije
-c    ...................................................................
-c
-      EXTERNAL  SSUM
-      REAL      SSUM
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if(pole_sud)  ije=ij_end-iip1
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/diverg_p.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/diverg_p.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/diverg_p.f90	(revision 5246)
@@ -0,0 +1,106 @@
+SUBROUTINE diverg_p(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: ijb,ije
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    if (pole_nord) then
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) / apoln
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+    endif
+
+   if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+    endif
+
+
+  END DO
+!$OMP END DO NOWAIT
+  !
+
+  !cc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+       DO ij = ijb,ije
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE diverg_p
Index: LMDZ6/trunk/libf/dyn3dmem/divergf_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/divergf_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,118 +1,0 @@
-      SUBROUTINE divergf_loc(klevel,x,y,div)
-c
-c     P. Le Van
-c
-c  *********************************************************************
-c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
-c     x et y...
-c              x et y  etant des composantes covariantes   ...
-c  *********************************************************************
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-c      x  et  y  sont des arguments  d'entree pour le s-prog
-c        div      est  un argument  de sortie pour le s-prog
-c
-c
-c   ---------------------------------------------------------------------
-c
-c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
-c
-c   ---------------------------------------------------------------------
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c    ..........          variables en arguments    ...................
-c
-      INTEGER klevel
-      REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
-      REAL div( ijb_u:ije_u,klevel )
-      INTEGER   l,ij
-c
-c    ...............     variables  locales   .........................
-
-      REAL aiy1( iip1 ) , aiy2( iip1 )
-      REAL sumypn,sumyps
-c    ...................................................................
-c
-      EXTERNAL  SSUM
-      REAL      SSUM
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if(pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/divergf_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/divergf_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/divergf_loc.f90	(revision 5246)
@@ -0,0 +1,118 @@
+SUBROUTINE divergf_loc(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
+  REAL :: div( ijb_u:ije_u,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
+
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    if (pole_nord) then
+
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) / apoln
+
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+
+    endif
+
+    if (pole_sud) then
+
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+
+    endif
+
+  END DO
+!$OMP END DO NOWAIT
+
+  !
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+
+    CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1, &
+          klevel, 2, 2, .TRUE., 1 )
+
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+       DO ij = ijb,ije
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE divergf_loc
Index: LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,121 +1,0 @@
-      SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
-c
-c     P. Le Van
-c
-c   ***************************************************************
-c
-c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
-c   ****************************************************************
-c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
-c         divgra     est  un argument  de sortie pour le s-prg
-c
-      USE parallel_lmdz
-      USE times
-      USE mod_hallo
-      USE divgrad2_mod
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom2.h"
-      INCLUDE "comdissipn.h"
-
-c    .......    variables en arguments   .......
-c
-      INTEGER klevel
-      REAL h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel )
-      REAL divgra_out( ijb_u:ije_u,klevel)
-c    .......    variables  locales    ..........
-c
-      REAL     signe, nudivgrs, sqrtps( ijb_u:ije_u,llm )
-      INTEGER  l,ij,iter,lh
-c    ...................................................................
-      Type(Request),SAVE :: request_dissip
-!$OMP THREADPRIVATE(request_dissip)
-      INTEGER ijb,ije
-
-c
-c
-      signe    = (-1.)**lh
-      nudivgrs = signe * cdivh
-
-c      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
-      ijb=ij_begin
-      ije=ij_end
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1, klevel
-        divgra(ijb:ije,l)=h(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-c
-c$OMP BARRIER
-       call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      CALL laplacien_loc( klevel, divgra, divgra )
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
-      DO l = 1, klevel
-       DO ij = ijb, ije
-        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
-      DO l = 1, klevel
-        DO ij = ijb, ije
-         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-   
-c    ........    Iteration de l'operateur  laplacien_gam    ........
-c
-      DO  iter = 1, lh - 2
-c$OMP BARRIER
-       call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-
-c$OMP BARRIER
-
-
-       CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
-     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
-      ENDDO
-c
-c    ...............................................................
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
-      DO l = 1, klevel
-        DO ij = ijb, ije
-          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-c
-c$OMP BARRIER
-       call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      CALL laplacien_loc ( klevel, divgra, divgra )
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l  = 1,klevel
-      DO ij = ijb,ije
-      divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
-      ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.f90	(revision 5246)
@@ -0,0 +1,121 @@
+SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
+  !
+  ! P. Le Van
+  !
+  !   ***************************************************************
+  !
+  ! .....   calcul de  (div( grad ))   de (  pext * h ) .....
+  !   ****************************************************************
+  !   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+  !     divgra     est  un argument  de sortie pour le s-prg
+  !
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE divgrad2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom2.h"
+  INCLUDE "comdissipn.h"
+
+  !    .......    variables en arguments   .......
+  !
+  INTEGER :: klevel
+  REAL :: h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel )
+  REAL :: divgra_out( ijb_u:ije_u,klevel)
+  !    .......    variables  locales    ..........
+  !
+  REAL :: signe, nudivgrs, sqrtps( ijb_u:ije_u,llm )
+  INTEGER :: l,ij,iter,lh
+  !    ...................................................................
+  Type(Request),SAVE :: request_dissip
+!$OMP THREADPRIVATE(request_dissip)
+  INTEGER :: ijb,ije
+
+  !
+  !
+  signe    = (-1.)**lh
+  nudivgrs = signe * cdivh
+
+   ! CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    divgra(ijb:ije,l)=h(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+!$OMP BARRIER
+   call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL laplacien_loc( klevel, divgra, divgra )
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+   DO ij = ijb, ije
+    sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+     divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !    ........    Iteration de l'operateur  laplacien_gam    ........
+  !
+  DO  iter = 1, lh - 2
+!$OMP BARRIER
+   call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+
+!$OMP BARRIER
+
+
+   CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2, &
+         unsapolnga2, unsapolsga2,  divgra, divgra )
+  ENDDO
+  !
+  !    ...............................................................
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+      divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+!$OMP BARRIER
+   call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL laplacien_loc ( klevel, divgra, divgra )
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l  = 1,klevel
+  DO ij = ijb,ije
+  divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+  ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE divgrad2_loc
Index: LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,90 +1,0 @@
-      SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
-      USE parallel_lmdz
-      USE write_field_p
-      USE mod_filtreg_p
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
-c
-c   ********************************************************************
-c   ... calcul du terme de convergence horizontale du flux d'enthalpie
-c        potentielle   ......
-c   ********************************************************************
-c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
-c     dteta 	          sont des arguments de sortie pour le s-pg ....
-c
-c=======================================================================
-
-
-      include "dimensions.h"
-      include "paramet.h"
-
-      REAL teta( ijb_u:ije_u,llm )
-      REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
-      REAL dteta( ijb_u:ije_u,llm )
-      INTEGER   l,ij
-
-      REAL hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm )
-
-c
-      INTEGER ijb,ije,jjb,jje
-
-      
-      jjb=jj_begin
-      jje=jj_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.f90	(revision 5246)
@@ -0,0 +1,90 @@
+SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
+  USE parallel_lmdz
+  USE write_field_p
+  USE mod_filtreg_p
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+  !
+  !   ********************************************************************
+  !   ... calcul du terme de convergence horizontale du flux d'enthalpie
+  !    potentielle   ......
+  !   ********************************************************************
+  !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+  ! dteta 	          sont des arguments de sortie pour le s-pg ....
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  REAL :: teta( ijb_u:ije_u,llm )
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: dteta( ijb_u:ije_u,llm )
+  INTEGER :: l,ij
+
+  REAL :: hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm )
+
+  !
+  INTEGER :: ijb,ije,jjb,jje
+
+
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+
+  ijb=ij_begin
+  ije=ij_end
+
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO  ij = ijb, ije - 1
+    hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
+  END DO
+
+  !    .... correction pour  hbxu(iip1,j,l)  .....
+  !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+    hbxu( ij, l ) = hbxu( ij - iim, l )
+  END DO
+
+  ijb=ij_begin-iip1
+  if (pole_nord) ijb=ij_begin
+
+  DO ij = ijb,ije
+    hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
+  END DO
+
+   if (.not. pole_sud) then
+      hbxu(ije+1:ije+iip1,l) = 0
+      hbyv(ije+1:ije+iip1,l) = 0
+    endif
+
+  END DO
+!$OMP END DO NOWAIT
+
+
+    CALL  convflu_loc ( hbxu, hbyv, llm, dteta )
+
+
+  !    stockage dans  dh de la convergence horizont. filtree' du  flux
+               ! ....                           ...........
+        ! d'enthalpie potentielle .
+
+
+  CALL filtreg_p( dteta,jjb_u,jje_u,jjb,jje,jjp1, llm, &
+        2, 2, .true., 1)
+
+
+  RETURN
+END SUBROUTINE dteta1_loc
Index: LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,65 +1,0 @@
-      SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c-----------------------------------------------------------------------
-c
-c   Auteur:   P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c   calcul du terme de  rotation
-c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
-c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
-c   du  et dv              sont des arguments de sortie pour le s-pg ..
-c
-c-----------------------------------------------------------------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-
-      REAL vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) ,
-     *     pbarv( ijb_v:ije_v,llm )
-      REAL du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm )
-      INTEGER  l,ij,ijb,ije
-c
-c
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.f90	(revision 5246)
@@ -0,0 +1,65 @@
+SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !-----------------------------------------------------------------------
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !   calcul du terme de  rotation
+  !   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
+  !   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
+  !   du  et dv              sont des arguments de sortie pour le s-pg ..
+  !
+  !-----------------------------------------------------------------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+
+  REAL :: vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) , &
+        pbarv( ijb_v:ije_v,llm )
+  REAL :: du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm )
+  INTEGER :: l,ij,ijb,ije
+  !
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO  ij = ijb, ije-1
+  du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) * &
+        (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) + &
+        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
+  END DO
+
+
+  !
+  if (pole_nord) ijb=ij_begin
+
+  DO ij = ijb, ije-1
+  dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) * &
+        (   pbaru(ij, l)  +  pbaru(ij+1   , l) + &
+        pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
+  END DO
+  !
+  !    .... correction  pour  dv( 1,j,l )  .....
+  !    ....   dv(1,j,l)= dv(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+  DO ij = ijb, ije, iip1
+  dv( ij,l ) = dv( ij + iim, l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE dudv1_loc
Index: LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,69 +1,0 @@
-      SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   *****************************************************************
-c   ..... calcul du terme de pression (gradient de p/densite )   et
-c          du terme de ( -gradient de la fonction de Bernouilli ) ...
-c   *****************************************************************
-c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
-c
-c
-c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
-c    du et dv          sont des arguments de sortie pour le s-pg  ....
-c
-c=======================================================================
-c
-      include "dimensions.h"
-      include "paramet.h"
-
-      REAL teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm )
-      REAL bern( ijb_u:ije_u,llm )
-      REAL du( ijb_u:ije_u,llm ),  dv( ijb_v:ije_v,llm )
-      INTEGER  l,ij,ijb,ije
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.f90	(revision 5246)
@@ -0,0 +1,69 @@
+SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   *****************************************************************
+  !   ..... calcul du terme de pression (gradient de p/densite )   et
+  !      du terme de ( -gradient de la fonction de Bernouilli ) ...
+  !   *****************************************************************
+  !      Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+  !
+  !
+  !    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+  !    du et dv          sont des arguments de sortie pour le s-pg  ....
+  !
+  !=======================================================================
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+  REAL :: teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm )
+  REAL :: bern( ijb_u:ije_u,llm )
+  REAL :: du( ijb_u:ije_u,llm ),  dv( ijb_v:ije_v,llm )
+  INTEGER :: l,ij,ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+
+  DO  ij  = ijb, ije - 1
+   du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * &
+         ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
+  END DO
+  !
+  !
+  !    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
+  !    ...          du(iip1,j,l) = du(1,j,l)                 ...
+  !
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+  du( ij,l ) = du( ij - iim,l )
+  END DO
+  !
+  !
+  if (pole_nord) ijb=ijb-iip1
+
+  DO ij  = ijb,ije
+  dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * &
+        ( pkf(ij+iip1,l) - pkf(  ij,l  ) ) &
+        +   bern( ij+iip1,l ) - bern( ij  ,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  !
+  RETURN
+END SUBROUTINE dudv2_loc
Index: LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.F	(revision 5214)
+++ 	(revision )
@@ -1,175 +1,0 @@
-!
-! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-c
-c
-            SUBROUTINE fluxstokenc_p(pbaru,pbarv ,
-     *                   masse,  teta, phi)
-      USE parallel_lmdz 
-      USE control_mod, ONLY : iapp_tracvl,planet_type,iphysiq
-      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=======================================================================
-c
-c       Shema de  Van Leer
-c
-c=======================================================================
-
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "tracstoke.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 :: teta( ijb_u:ije_u,llm)
-      REAL :: phi(ijb_u:ije_u,llm)
-      
-      INTEGER,SAVE :: pasflx=0
-!$OMP THREADPRIVATE(pasflx)
-      INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
-      INTEGER :: ij,l
-      TYPE(Request),SAVE :: Request_vanleer
-!$OMP THREADPRIVATE(Request_vanleer)
-
-
-
-      !write(*,*) 'caladvtrac 58: entree'     
-      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(pasflx.EQ.0) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
-      DO l=1,llm   
-          tetac(ijbu:ijeu,l)=0.
-          phic(ijbu:ijeu,l)=0.
-          pbarucc(ijbu:ijeu,l)=0.
-          pbarvcc(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
-            pbarucc(ij,l) = pbarucc(ij,l) + pbaru(ij,l)
-            tetac(ij,l) = tetac(ij,l) + teta(ij,l) 
-            phic(ij,l) = phic(ij,l) + phi(ij,l)
-
-         ENDDO
-         DO ij = ijbv,ijev
-            pbarvcc(ij,l) = pbarvcc(ij,l) + pbarv(ij,l)
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-c   selection de la masse instantannee des mailles avant le transport.
-      IF(pasflx.EQ.0) THEN
-
-          ijb=ij_begin
-          ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-          massec(ijb:ije,l)=masse(ijb:ije,l)
-       ENDDO
-c$OMP END DO NOWAIT
-
-      ENDIF
-
-      pasflx   = pasflx+1
-
-
-c   Test pour savoir si on advecte a ce pas de temps
-
-      IF ( pasflx.EQ.(iphysiq*istphy) ) THEN
-      !write(*,*) 'caladvtrac 133'
-c$OMP MASTER
-      call suspend_timer(timer_caldyn)
-c$OMP END MASTER
-      
-      ijb=ij_begin
-      ije=ij_end
-
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-            pbarucc(ijb:ije,l) = pbarucc(ijb:ije,l)/REAL(iphysiq*istphy)
-            tetac(ijb:ije,l) = tetac(ijb:ije,l)/REAL(iphysiq*istphy)
-            phic(ijb:ije,l) = phic(ijb:ije,l)/REAL(iphysiq*istphy)
-      ENDDO
-c$OMP ENDDO NOWAIT
-
-      if (pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-            pbarvcc(ijb:ije,l) = pbarvcc(ijb:ije,l)/REAL(iphysiq*istphy)
-      ENDDO
-c$OMP ENDDO NOWAIT
-
-
-c$OMP BARRIER
-        call Register_Hallo_u(pbarucc,llm,1,1,1,1,Request_vanleer)
-        call Register_Hallo_v(pbarvcc,llm,1,1,1,1,Request_vanleer)
-        call SendRequest(Request_vanleer)
-c$OMP BARRIER
-        call WaitRequest(Request_vanleer)
-c$OMP BARRIER
-
-
-
-      
-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.
-
-        CALL groupe_loc( massec, pbarucc,pbarvcc, pbarugg,pbarvgg,wgg )
-
-
-
-         ijb=ij_begin
-         ije=ij_end
-
-c$OMP BARRIER
-         CALL WriteField_u('pbarug',pbarugg)
-         CALL WriteField_v('pbarvg',pbarvgg)
-         CALL WriteField_u('wg',wgg)
-         CALL WriteField_u('tetag',tetac)
-         CALL WriteField_u('phig',phic)
-         CALL WriteField_u('masseg',massec)
-
-
-c$OMP MASTER
-        call Set_Distrib(distrib_caldyn)
-        call VTe(VThallo)
-        call resume_timer(timer_caldyn)
-c$OMP END MASTER
-
-
-c$OMP BARRIER
-          pasflx=0
-       ENDIF ! if iadvtr.EQ.iapp_tracvl
-
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.f90	(revision 5246)
@@ -0,0 +1,175 @@
+!
+! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+!
+!
+      SUBROUTINE fluxstokenc_p(pbaru,pbarv , &
+              masse,  teta, phi)
+  USE parallel_lmdz
+  USE control_mod, ONLY : iapp_tracvl,planet_type,iphysiq
+  USE caladvtrac_mod
+  USE mod_hallo
+  USE bands
+  USE times
+  USE Vampir
+  USE write_field_loc
+
+  !
+  IMPLICIT NONE
+  !
+  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+  !
+  !=======================================================================
+  !
+  !   Shema de  Van Leer
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "tracstoke.h"
+
+  !   Arguments:
+  !   ----------
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: masse(ijb_u:ije_u,llm)
+  REAL :: teta( ijb_u:ije_u,llm)
+  REAL :: phi(ijb_u:ije_u,llm)
+
+  INTEGER,SAVE :: pasflx=0
+!$OMP THREADPRIVATE(pasflx)
+  INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
+  INTEGER :: ij,l
+  TYPE(Request),SAVE :: Request_vanleer
+!$OMP THREADPRIVATE(Request_vanleer)
+
+
+
+  ! !write(*,*) 'caladvtrac 58: entree'
+  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(pasflx.EQ.0) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+      tetac(ijbu:ijeu,l)=0.
+      phic(ijbu:ijeu,l)=0.
+      pbarucc(ijbu:ijeu,l)=0.
+      pbarvcc(ijbv:ijev,l)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  !   accumulation des flux de masse horizontaux
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij = ijbu,ijeu
+        pbarucc(ij,l) = pbarucc(ij,l) + pbaru(ij,l)
+        tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+        phic(ij,l) = phic(ij,l) + phi(ij,l)
+
+     ENDDO
+     DO ij = ijbv,ijev
+        pbarvcc(ij,l) = pbarvcc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(pasflx.EQ.0) THEN
+
+      ijb=ij_begin
+      ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+      massec(ijb:ije,l)=masse(ijb:ije,l)
+   ENDDO
+!$OMP END DO NOWAIT
+
+  ENDIF
+
+  pasflx   = pasflx+1
+
+
+  !   Test pour savoir si on advecte a ce pas de temps
+
+  IF ( pasflx.EQ.(iphysiq*istphy) ) THEN
+  ! !write(*,*) 'caladvtrac 133'
+!$OMP MASTER
+  call suspend_timer(timer_caldyn)
+!$OMP END MASTER
+
+  ijb=ij_begin
+  ije=ij_end
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+        pbarucc(ijb:ije,l) = pbarucc(ijb:ije,l)/REAL(iphysiq*istphy)
+        tetac(ijb:ije,l) = tetac(ijb:ije,l)/REAL(iphysiq*istphy)
+        phic(ijb:ije,l) = phic(ijb:ije,l)/REAL(iphysiq*istphy)
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  if (pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+        pbarvcc(ijb:ije,l) = pbarvcc(ijb:ije,l)/REAL(iphysiq*istphy)
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+
+!$OMP BARRIER
+    call Register_Hallo_u(pbarucc,llm,1,1,1,1,Request_vanleer)
+    call Register_Hallo_v(pbarvcc,llm,1,1,1,1,Request_vanleer)
+    call SendRequest(Request_vanleer)
+!$OMP BARRIER
+    call WaitRequest(Request_vanleer)
+!$OMP BARRIER
+
+
+
+
+  !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
+  !c
+
+  !   traitement des flux de masse avant advection.
+  ! 1. calcul de w
+  ! 2. groupement des mailles pres du pole.
+
+    CALL groupe_loc( massec, pbarucc,pbarvcc, pbarugg,pbarvgg,wgg )
+
+
+
+     ijb=ij_begin
+     ije=ij_end
+
+!$OMP BARRIER
+     CALL WriteField_u('pbarug',pbarugg)
+     CALL WriteField_v('pbarvg',pbarvgg)
+     CALL WriteField_u('wg',wgg)
+     CALL WriteField_u('tetag',tetac)
+     CALL WriteField_u('phig',phic)
+     CALL WriteField_u('masseg',massec)
+
+
+!$OMP MASTER
+    call Set_Distrib(distrib_caldyn)
+    call VTe(VThallo)
+    call resume_timer(timer_caldyn)
+!$OMP END MASTER
+
+
+!$OMP BARRIER
+      pasflx=0
+   ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+END SUBROUTINE fluxstokenc_p
Index: LMDZ6/trunk/libf/dyn3dmem/friction_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/friction_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,203 +1,0 @@
-!
-! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-c=======================================================================
-      SUBROUTINE friction_loc(ucov,vcov,pdt)
-      USE parallel_lmdz
-      USE control_mod
-#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 comconst_mod, ONLY: pi
-      IMPLICIT NONE
-
-!=======================================================================
-!
-!   Friction for the Newtonian case:
-!   --------------------------------
-!    2 possibilities (depending on flag 'friction_type'
-!     friction_type=0 : A friction that is only applied to the lowermost
-!                       atmospheric layer
-!     friction_type=1 : Friction applied on all atmospheric layer (but
-!       (default)       with stronger magnitude near the surface; see
-!                       iniacademic.F)
-!=======================================================================
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-      include "iniprint.h"
-      include "academic.h"
-
-! arguments:
-      REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
-      REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
-      REAL,INTENT(in) :: pdt ! time step
-
-! local variables:
-
-      REAL modv(iip1,jjb_u:jje_u),zco,zsi
-      REAL vpn,vps,upoln,upols,vpols,vpoln
-      REAL u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
-      INTEGER  i,j,l
-      REAL,PARAMETER :: cfric=1.e-5
-      LOGICAL,SAVE :: firstcall=.true.
-      INTEGER,SAVE :: friction_type=1
-      CHARACTER(len=20) :: modname="friction_p"
-      CHARACTER(len=80) :: abort_message
-!$OMP THREADPRIVATE(firstcall,friction_type)
-      integer :: jjb,jje
-
-!$OMP SINGLE
-      IF (firstcall) THEN
-        ! set friction type
-        call getin("friction_type",friction_type)
-        if ((friction_type.lt.0).or.(friction_type.gt.1)) then
-          abort_message="wrong friction type"
-          write(lunout,*)'Friction: wrong friction type',friction_type
-          call abort_gcm(modname,abort_message,42)
-        endif
-        firstcall=.false.
-      ENDIF
-!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
-
-      if (friction_type.eq.0) then ! friction on first layer only
-!$OMP SINGLE
-c   calcul des composantes au carre du vent naturel
-      jjb=jj_begin
-      jje=jj_end+1
-      if (pole_sud) jje=jj_end
-      
-      do j=jjb,jje
-         do i=1,iip1
-            u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
-         enddo
-      enddo
-      
-      jjb=jj_begin-1
-      jje=jj_end+1
-      if (pole_nord) jjb=jj_begin
-      if (pole_sud) jje=jj_end-1
-      
-      do j=jjb,jje
-         do i=1,iip1
-            v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
-         enddo
-      enddo
-
-c   calcul du module de V en dehors des poles
-      jjb=jj_begin
-      jje=jj_end+1
-      if (pole_nord) jjb=jj_begin+1
-      if (pole_sud) jje=jj_end-1
-      
-      do j=jjb,jje
-         do i=2,iip1
-            modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
-         enddo
-         modv(1,j)=modv(iip1,j)
-      enddo
-
-c   les deux composantes du vent au pole sont obtenues comme
-c   premiers modes de fourier de v pres du pole
-      if (pole_nord) then
-      
-        upoln=0.
-        vpoln=0.
-     
-        do i=2,iip1
-           zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           vpn=vcov(i,1,1)/cv(i,1)
-           upoln=upoln+zco*vpn
-           vpoln=vpoln+zsi*vpn
-        enddo
-        vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
-        do i=1,iip1
-c          modv(i,1)=vpn
-           modv(i,1)=modv(i,2)
-        enddo
-
-      endif
-      
-      if (pole_sud) then
-      
-        upols=0.
-        vpols=0.
-        do i=2,iip1
-           zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-           vps=vcov(i,jjm,1)/cv(i,jjm)
-           upols=upols+zco*vps
-           vpols=vpols+zsi*vps
-        enddo
-        vps=sqrt(upols*upols+vpols*vpols)/pi
-        do i=1,iip1
-c        modv(i,jjp1)=vps
-         modv(i,jjp1)=modv(i,jjm)
-        enddo
-      
-      endif
-      
-c   calcul du frottement au sol.
-
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_nord) jjb=jj_begin+1
-      if (pole_sud) jje=jj_end-1
-
-      do j=jjb,jje
-         do i=1,iim
-            ucov(i,j,1)=ucov(i,j,1)
-     s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
-         enddo
-         ucov(iip1,j,1)=ucov(1,j,1)
-      enddo
-      
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-      
-      do j=jjb,jje
-         do i=1,iip1
-            vcov(i,j,1)=vcov(i,j,1)
-     s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
-         enddo
-         vcov(iip1,j,1)=vcov(1,j,1)
-      enddo
-!$OMP END SINGLE
-      endif ! of if (friction_type.eq.0)
-
-      if (friction_type.eq.1) then
-       ! for ucov() 
-        jjb=jj_begin
-        jje=jj_end
-        if (pole_nord) jjb=jj_begin+1
-        if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-          ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)*
-     &                                  (1.-pdt*kfrict(l))
-        enddo
-!$OMP END DO NOWAIT
-        
-       ! for vcoc()
-        jjb=jj_begin
-        jje=jj_end
-        if (pole_sud) jje=jj_end-1
-        
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-          vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)*
-     &                                  (1.-pdt*kfrict(l))
-        enddo
-!$OMP END DO
-      endif ! of if (friction_type.eq.1)
-
-      RETURN
-      END
-
Index: LMDZ6/trunk/libf/dyn3dmem/friction_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/friction_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/friction_loc.F90	(revision 5246)
@@ -0,0 +1,203 @@
+!
+! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+!=======================================================================
+SUBROUTINE friction_loc(ucov,vcov,pdt)
+  USE parallel_lmdz
+  USE control_mod
+#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 comconst_mod, ONLY: pi
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Friction for the Newtonian case:
+  !   --------------------------------
+  !    2 possibilities (depending on flag 'friction_type'
+  ! friction_type=0 : A friction that is only applied to the lowermost
+  !                   atmospheric layer
+  ! friction_type=1 : Friction applied on all atmospheric layer (but
+  !   (default)       with stronger magnitude near the surface; see
+  !                   iniacademic.F)
+  !=======================================================================
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+  include "academic.h"
+
+  ! arguments:
+  REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
+  REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
+  REAL,INTENT(in) :: pdt ! time step
+
+  ! local variables:
+
+  REAL :: modv(iip1,jjb_u:jje_u),zco,zsi
+  REAL :: vpn,vps,upoln,upols,vpols,vpoln
+  REAL :: u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
+  INTEGER :: i,j,l
+  REAL,PARAMETER :: cfric=1.e-5
+  LOGICAL,SAVE :: firstcall=.true.
+  INTEGER,SAVE :: friction_type=1
+  CHARACTER(len=20) :: modname="friction_p"
+  CHARACTER(len=80) :: abort_message
+!$OMP THREADPRIVATE(firstcall,friction_type)
+  integer :: jjb,jje
+
+!$OMP SINGLE
+  IF (firstcall) THEN
+    ! ! set friction type
+    call getin("friction_type",friction_type)
+    if ((friction_type.lt.0).or.(friction_type.gt.1)) then
+      abort_message="wrong friction type"
+      write(lunout,*)'Friction: wrong friction type',friction_type
+      call abort_gcm(modname,abort_message,42)
+    endif
+    firstcall=.false.
+  ENDIF
+!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
+
+  if (friction_type.eq.0) then ! friction on first layer only
+!$OMP SINGLE
+  !   calcul des composantes au carre du vent naturel
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+
+  do j=jjb,jje
+     do i=1,iip1
+        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+     enddo
+  enddo
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iip1
+        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+     enddo
+  enddo
+
+  !   calcul du module de V en dehors des poles
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=2,iip1
+        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+     enddo
+     modv(1,j)=modv(iip1,j)
+  enddo
+
+  !   les deux composantes du vent au pole sont obtenues comme
+  !   premiers modes de fourier de v pres du pole
+  if (pole_nord) then
+
+    upoln=0.
+    vpoln=0.
+
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vpn=vcov(i,1,1)/cv(i,1)
+       upoln=upoln+zco*vpn
+       vpoln=vpoln+zsi*vpn
+    enddo
+    vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+    do i=1,iip1
+       ! modv(i,1)=vpn
+       modv(i,1)=modv(i,2)
+    enddo
+
+  endif
+
+  if (pole_sud) then
+
+    upols=0.
+    vpols=0.
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vps=vcov(i,jjm,1)/cv(i,jjm)
+       upols=upols+zco*vps
+       vpols=vpols+zsi*vps
+    enddo
+    vps=sqrt(upols*upols+vpols*vpols)/pi
+    do i=1,iip1
+     ! modv(i,jjp1)=vps
+     modv(i,jjp1)=modv(i,jjm)
+    enddo
+
+  endif
+
+  !   calcul du frottement au sol.
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iim
+        ucov(i,j,1)=ucov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+     enddo
+     ucov(iip1,j,1)=ucov(1,j,1)
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iip1
+        vcov(i,j,1)=vcov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+     enddo
+     vcov(iip1,j,1)=vcov(1,j,1)
+  enddo
+!$OMP END SINGLE
+  endif ! of if (friction_type.eq.0)
+
+  if (friction_type.eq.1) then
+   ! ! for ucov()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_nord) jjb=jj_begin+1
+    if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
+!$OMP END DO NOWAIT
+
+   ! ! for vcoc()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
+!$OMP END DO
+  endif ! of if (friction_type.eq.1)
+
+  RETURN
+END SUBROUTINE friction_loc
+
Index: LMDZ6/trunk/libf/dyn3dmem/geopot_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/geopot_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,65 +1,0 @@
-      SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
-      USE parallel_lmdz
-      IMPLICIT NONE
-      
-      
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   Objet:
-c   ------
-c
-c    *******************************************************************
-c    ....   calcul du geopotentiel aux milieux des couches    .....
-c    *******************************************************************
-c
-c     ....   l'integration se fait de bas en haut  ....
-c
-c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
-c              phi               est un  argum. de sortie pour le s-pg .
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      include "dimensions.h"
-      include "paramet.h"
-
-c   Arguments:
-c   ----------
-      INTEGER ngrid
-      REAL teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u),
-     *     pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm)
-
-
-c   Local:
-c   ------
-      
-      INTEGER  l, ij,ijb,ije
-
-
-c-----------------------------------------------------------------------
-c     calcul de phi au niveau 1 pres du sol  .....
-      ijb=ij_begin
-      ije=ij_end+iip1
-      
-      IF (pole_sud)  ije=ij_end
-
-      DO  ij  = ijb, ije
-      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
-      ENDDO
-
-c     calcul de phi aux niveaux superieurs  .......
-
-      DO  l = 2,llm
-        DO  ij    = ijb,ije
-        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
-     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
-        ENDDO
-      ENDDO
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/geopot_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/geopot_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/geopot_loc.f90	(revision 5246)
@@ -0,0 +1,65 @@
+SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
+  USE parallel_lmdz
+  IMPLICIT NONE
+
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !    *******************************************************************
+  !    ....   calcul du geopotentiel aux milieux des couches    .....
+  !    *******************************************************************
+  !
+  ! ....   l'integration se fait de bas en haut  ....
+  !
+  ! .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+  !          phi               est un  argum. de sortie pour le s-pg .
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  !   Arguments:
+  !   ----------
+  INTEGER :: ngrid
+  REAL :: teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u), &
+        pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm)
+
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l, ij,ijb,ije
+
+
+  !-----------------------------------------------------------------------
+  ! calcul de phi au niveau 1 pres du sol  .....
+  ijb=ij_begin
+  ije=ij_end+iip1
+
+  IF (pole_sud)  ije=ij_end
+
+  DO  ij  = ijb, ije
+  phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+  ENDDO
+
+  ! calcul de phi aux niveaux superieurs  .......
+
+  DO  l = 2,llm
+    DO  ij    = ijb,ije
+    phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) &
+          *   (  pk(ij,l-1) -  pk(ij,l)    )
+    ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE geopot_loc
Index: LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,75 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal)
-c%W%    %G%
-c=======================================================================
-c
-c   Author:    Frederic Hourdin      original: 11/11/92
-c   -------
-c
-c   Subject:
-c   ------
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      USE parallel_lmdz
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER nx
-      REAL x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx)
-
-c   Local:
-c   ------
-
-      INTEGER l,ij
-      INTEGER :: ijb,ije
-
-c-----------------------------------------------------------------------
-      ijb=ij_begin
-      ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l=1,nx
-         DO ij=ijb+1,ije
-            x_scal(ij,l)=
-     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
-     s      /(aireu(ij)+aireu(ij-1))
-         ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-
-      ijb=ij_begin
-      ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l=1,nx
-         DO ij=ijb,ije-iip1+1,iip1
-	   x_scal(ij,l)=x_scal(ij+iip1-1,l)
-	 ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-      RETURN
-      
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.f90	(revision 5246)
@@ -0,0 +1,75 @@
+!
+! $Header$
+!
+SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: nx
+  REAL :: x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx)
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb+1,ije
+        x_scal(ij,l)= &
+              (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) &
+              /(aireu(ij)+aireu(ij-1))
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb,ije-iip1+1,iip1
+       x_scal(ij,l)=x_scal(ij+iip1-1,l)
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+  RETURN
+
+END SUBROUTINE gr_u_scal_loc
Index: LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,85 +1,0 @@
-!
-! $Header$
-!
-      SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal)
-c%W%    %G%
-c=======================================================================
-c
-c   Author:    Frederic Hourdin      original: 11/11/92
-c   -------
-c
-c   Subject:
-c   ------
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      USE parallel_lmdz
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER nx
-      REAL x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx)
-
-c   Local:
-c   ------
-
-      INTEGER l,ij
-      INTEGER :: ijb,ije
-c-----------------------------------------------------------------------
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO l=1,nx
-         DO ij=ijb,ije
-            x_scal(ij,l)=
-     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
-     s      /(airev(ij-iip1)+airev(ij))
-         ENDDO
-      ENDDO
-!$OMP ENDDO NOWAIT
-      
-      if (pole_nord) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l=1,nx
-           DO ij=1,iip1
-              x_scal(ij,l)=0.
-           ENDDO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-    
-      if (pole_sud) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-        DO l=1,nx
-           DO ij=ip1jm+1,ip1jmp1
-              x_scal(ij,l)=0.
-           ENDDO
-        ENDDO
-!$OMP ENDDO NOWAIT
-      endif
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.f90	(revision 5246)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER :: nx
+  REAL :: x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx)
+
+  !   Local:
+  !   ------
+
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb,ije
+        x_scal(ij,l)= &
+              (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
+              /(airev(ij-iip1)+airev(ij))
+     ENDDO
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nx
+       DO ij=1,iip1
+          x_scal(ij,l)=0.
+       ENDDO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nx
+       DO ij=ip1jm+1,ip1jmp1
+          x_scal(ij,l)=0.
+       ENDDO
+    ENDDO
+!$OMP ENDDO NOWAIT
+  endif
+
+  RETURN
+END SUBROUTINE gr_v_scal_loc
Index: LMDZ6/trunk/libf/dyn3dmem/grad_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/grad_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,53 +1,0 @@
-      SUBROUTINE  grad_loc(klevel, pg,pgx,pgy )
-c
-c      P. Le Van
-c
-c    ******************************************************************
-c     .. calcul des composantes covariantes en x et y du gradient de g
-c
-c    ******************************************************************
-c             pg        est un   argument  d'entree pour le s-prog
-c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INTEGER klevel
-      REAL  pg( ijb_u:ije_u,klevel )
-      REAL pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel )
-      INTEGER  l,ij
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/grad_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/grad_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/grad_loc.f90	(revision 5246)
@@ -0,0 +1,53 @@
+SUBROUTINE  grad_loc(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ijb_u:ije_u,klevel )
+  REAL :: pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  DO  ij = ijb, ije - 1
+    pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO  ij = ijb+iip1-1, ije, iip1
+    pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+    pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE grad_loc
Index: LMDZ6/trunk/libf/dyn3dmem/grad_p.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/grad_p.F	(revision 5214)
+++ 	(revision )
@@ -1,53 +1,0 @@
-      SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
-c
-c      P. Le Van
-c
-c    ******************************************************************
-c     .. calcul des composantes covariantes en x et y du gradient de g
-c
-c    ******************************************************************
-c             pg        est un   argument  d'entree pour le s-prog
-c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INTEGER klevel
-      REAL  pg( ip1jmp1,klevel )
-      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
-      INTEGER  l,ij
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/grad_p.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/grad_p.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/grad_p.f90	(revision 5246)
@@ -0,0 +1,53 @@
+SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ip1jmp1,klevel )
+  REAL :: pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  DO  ij = ijb, ije - 1
+    pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO  ij = ijb+iip1-1, ije, iip1
+    pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+    pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE grad_p
Index: LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,149 +1,0 @@
-      SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out )
-c
-c     P. Le Van
-c
-c   **********************************************************
-c                                ld
-c       calcul  de  (grad (div) )   du vect. v ....
-c
-c     xcov et ycov etant les composant.covariantes de v
-c   **********************************************************
-c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
-c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
-c
-c
-      USE parallel_lmdz
-      USE times
-      USE Write_field_p
-      USE mod_hallo
-      USE mod_filtreg_p
-      USE gradiv2_mod
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INCLUDE "comdissipn.h"
-c
-c     ........    variables en arguments      ........
-
-      INTEGER klevel
-      REAL  xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
-      REAL gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel)
-c
-c     ........       variables locales       .........
-c
-      REAL      :: tmp_div2(ijb_u:ije_u,llm)
-      REAL signe, nugrads
-      INTEGER l,ij,iter,ld
-      INTEGER :: ijb,ije,jjb,jje
-      Type(Request),SAVE  :: request_dissip
-!$OMP THREADPRIVATE(request_dissip)      
-c    ........................................................
-c
-c
-c      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
-c      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
-      
-      ijb=ij_begin
-      ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO   l = 1, klevel
-        gdx(ijb:ije,l)=xcov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT      
-      
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO   l = 1, klevel
-        gdy(ijb:ije,l)=ycov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-c$OMP BARRIER
-       call Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-c
-c
-      signe   = (-1.)**ld
-      nugrads = signe * cdivu
-c
-
-
-      CALL    divergf_loc( klevel, gdx,   gdy , div )
-c      call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
-
-      IF( ld.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: LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.f90	(revision 5246)
@@ -0,0 +1,149 @@
+SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+  !
+  ! P. Le Van
+  !
+  !   **********************************************************
+  !                            ld
+  !   calcul  de  (grad (div) )   du vect. v ....
+  !
+  ! xcov et ycov etant les composant.covariantes de v
+  !   **********************************************************
+  ! xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+  !  gdx   et  gdy       sont des arguments de sortie pour le s-prog
+  !
+  !
+  USE parallel_lmdz
+  USE times
+  USE Write_field_p
+  USE mod_hallo
+  USE mod_filtreg_p
+  USE gradiv2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "comdissipn.h"
+  !
+  ! ........    variables en arguments      ........
+
+  INTEGER :: klevel
+  REAL :: xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+  REAL :: gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel)
+  !
+  ! ........       variables locales       .........
+  !
+  REAL      :: tmp_div2(ijb_u:ije_u,llm)
+  REAL :: signe, nugrads
+  INTEGER :: l,ij,iter,ld
+  INTEGER :: ijb,ije,jjb,jje
+  Type(Request),SAVE  :: request_dissip
+!$OMP THREADPRIVATE(request_dissip)
+  !    ........................................................
+  !
+  !
+  !  CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+  !  CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1, klevel
+    gdx(ijb:ije,l)=xcov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1, klevel
+    gdy(ijb:ije,l)=ycov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP BARRIER
+   call Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+  !
+  !
+  signe   = (-1.)**ld
+  nugrads = signe * cdivu
+  !
+
+
+  CALL    divergf_loc( klevel, gdx,   gdy , div )
+   ! call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
+
+  IF( ld.GT.1 )   THEN
+!$OMP BARRIER
+   call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+    CALL laplacien_loc( klevel, div,  div     )
+
+  !    ......  Iteration de l'operateur laplacien_gam   .......
+      ! call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
+
+    DO iter = 1, ld -2
+!$OMP BARRIER
+   call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+
+!$OMP BARRIER
+
+     CALL laplacien_gam_loc(klevel,cuvscvgam1,cvuscugam1, &
+           unsair_gam1,unsapolnga1, unsapolsga1, &
+           div, div       )
+    ENDDO
+     ! call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
+  ENDIF
+
+   jjb=jj_begin
+   jje=jj_end
+
+   CALL filtreg_p( div   ,jjb_u,jje_u,jjb,jje, jjp1, &
+         klevel, 2, 1, .TRUE., 1 )
+    ! call exchange_Hallo(div,ip1jmp1,llm,0,1)
+!$OMP BARRIER
+   call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+
+!$OMP BARRIER
+
+
+   CALL  grad_loc( klevel,  div,   gdx,  gdy )
+
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO   l = 1, klevel
+
+     if (pole_sud) ije=ij_end
+     DO  ij = ijb, ije
+      gdx_out( ij,l ) = gdx( ij,l ) * nugrads
+     ENDDO
+
+     if (pole_sud) ije=ij_end-iip1
+     DO  ij = ijb, ije
+      gdy_out( ij,l ) = gdy( ij,l ) * nugrads
+     ENDDO
+
+   ENDDO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE gradiv2_loc
Index: LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,128 +1,0 @@
-      subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
-      USE parallel_lmdz
-      USE Write_field_loc
-      USE groupe_mod
-      USE comconst_mod, ONLY: ngroup
-      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 "comgeom2.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)
-
-      integer ijb,ije,jjb,jje
-      
-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: LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F90	(revision 5246)
@@ -0,0 +1,128 @@
+subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+  USE parallel_lmdz
+  USE Write_field_loc
+  USE groupe_mod
+  USE comconst_mod, ONLY: ngroup
+  implicit none
+
+  !   sous-programme servant a fitlrer les champs de flux de masse aux
+  !   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+  !   et a mesure qu'on se rapproche du pole.
+  !
+  !   en entree: pext, pbaru et pbarv
+  !
+  !   en sortie:  pbarum,pbarvm et wm.
+  !
+  !   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+  !   pas besoin de w en entree.
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.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
+!$OMP THREADPRIVATE(firstcall)
+
+  integer :: ijb,ije,jjb,jje
+
+  !   Champs 1D
+
+  call convflu_loc(pbaru,pbarv,llm,zconvm)
+
+  !
+  !  call scopy(ijp1llm,zconvm,1,zconvmm,1)
+  !  call scopy(ijmllm,pbarv,1,pbarvm,1)
+
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+    zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
+  enddo
+!$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
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+    pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
+  enddo
+!$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
+  !   Champs 3D
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud)  jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        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
+  ! zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+  !    *                      yflu(i,j,l)-yflu(i,j-1,l)
+        enddo
+        pbarum(iip1,j,l)=pbarum(1,j,l)
+     enddo
+  enddo
+!$OMP END DO NOWAIT
+  !    integration de la convergence de masse de haut  en bas ......
+
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP BARRIER
+!$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
+  !ym	wm(:,jj_end+1,:)=0
+  endif
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+  CALL vitvert_loc(zconvmm,wm)
+
+  return
+end subroutine groupe_loc
+
Index: LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,201 +1,0 @@
-      SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
-      USE parallel_lmdz
-      USE Write_Field_p
-      USE comconst_mod, ONLY: ngroup
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-      INTEGER jjmax,llmax,sb,se,jjb,jje
-      REAL q(iip1,sb:se,llmax)
-
-!     INTEGER ngroup
-!     PARAMETER (ngroup=3)
-
-      REAL airecn,qn
-      REAL airecs,qs
-
-      INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
-
-c--------------------------------------------------------------------c 
-c Strategie d'optimisation                                           c
-c stocker les valeurs systematiquement recalculees                   c
-c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
-c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
-c de grille au cours de la simulation tout devrait bien se passer.   c
-c Autre optimisation : determination des bornes entre lesquelles "j" c
-c varie, au lieu de faire un test a chaque fois...
-c--------------------------------------------------------------------c 
-
-      INTEGER j_start, j_finish
-
-      REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
-      REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
-!$OMP THREADPRIVATE(airen_tab, aires_tab)
-
-      LOGICAL, SAVE :: first = .TRUE.
-!$OMP THREADPRIVATE(first)
-!     INTEGER,SAVE :: i_index(iim,ngroup)
-      INTEGER      :: offset
-!     REAL         :: qsum(iim/ngroup)
-
-      IF (first) THEN
-         CALL init_groupeun_loc(airen_tab, aires_tab)
-         first = .FALSE.
-      ENDIF
-
-c Champs 3D
-      jd=jjp1-jjmax
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         j1=1+jd
-         j2=2
-         DO ig=1,ngroup
-
-c     Concerne le pole nord
-            j_start  = MAX(jjb, j1-jd)
-            j_finish = MIN(jje, j2-jd)
-            DO ig2=1,ngroup-ig+1
-              offset=2**(ig2-1)
-              DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-                 DO i0=1,iim,2**ig2
-                   q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) 
-                 ENDDO
-              ENDDO
-            ENDDO
-            
-            DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
-               ENDDO
-            ENDDO
-
-            DO j=j_start, j_finish
-!CDIR ON_ADB(airen_tab)
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
-               ENDDO
-               q(iip1,j,l)=q(1,j,l)
-            ENDDO
-       
-!c     Concerne le pole sud
-            j_start  = MAX(1+jjp1-jje-jd, j1-jd)
-            j_finish = MIN(1+jjp1-jjb-jd, j2-jd)
-            DO ig2=1,ngroup-ig+1
-              offset=2**(ig2-1)
-              DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-                 DO i0=1,iim,2**ig2
-                   q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l)
-     &                                 +q(i0+offset,jjp1-j+1-jd,l) 
-                 ENDDO
-              ENDDO
-            ENDDO
-
-
-            DO j=j_start, j_finish
-!CDIR NODEP
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),
-     &                                jjp1-j+1-jd,l)
-               ENDDO
-            ENDDO
-
-            DO j=j_start, j_finish
-!CDIR ON_ADB(aires_tab)
-!CDIR ON_ADB(q)
-               DO i=1,iim
-                 q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)*  
-     &                              aires_tab(i,jjp1-j+1,jd)
-               ENDDO
-               q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
-            ENDDO
-
-        
-            j1=j2+1
-            j2=j2+2**ig
-         ENDDO
-      ENDDO
-!$OMP END DO NOWAIT
-
-      RETURN
-      END
-
-
-
-      SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
-
-      USE parallel_lmdz
-      USE comconst_mod, ONLY: ngroup
-      IMPLICIT NONE
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-!     INTEGER ngroup
-!     PARAMETER (ngroup=3)
-
-      REAL airen,airecn
-      REAL aires,airecs
-
-      INTEGER i,j,l,ig,j1,j2,i0,jd
-
-      INTEGER j_start, j_finish
-
-      REAL :: airen_tab(iip1,jjp1,0:1)
-      REAL :: aires_tab(iip1,jjp1,0:1)
-
-      DO jd=0, 1
-         j1=1+jd
-         j2=2
-         DO ig=1,ngroup
-            
-!     c     Concerne le pole nord
-            j_start = j1-jd
-            j_finish = j2-jd
-            DO j=j_start, j_finish
-               DO i0=1,iim,2**(ngroup-ig+1)
-                  airen=0.
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     airen = airen+aire(i,j)
-                  ENDDO
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     airen_tab(i,j,jd) = 
-     &                    aire(i,j) / airen
-                  ENDDO
-               ENDDO
-            ENDDO
-            
-!     c     Concerne le pole sud
-            j_start = j1-jd
-            j_finish = j2-jd
-            DO j=j_start, j_finish
-               DO i0=1,iim,2**(ngroup-ig+1)
-                  aires=0.
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     aires=aires+aire(i,jjp1-j+1)
-                  ENDDO
-                  DO i=i0,i0+2**(ngroup-ig+1)-1
-                     aires_tab(i,jjp1-j+1,jd) = 
-     &                    aire(i,jjp1-j+1) / aires
-                  ENDDO
-               ENDDO
-            ENDDO
-            
-            j1=j2+1
-            j2=j2+2**ig
-         ENDDO
-      ENDDO
-      
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.f90	(revision 5246)
@@ -0,0 +1,201 @@
+SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
+  USE parallel_lmdz
+  USE Write_Field_p
+  USE comconst_mod, ONLY: ngroup
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  INTEGER :: jjmax,llmax,sb,se,jjb,jje
+  REAL :: q(iip1,sb:se,llmax)
+
+  ! INTEGER ngroup
+  ! PARAMETER (ngroup=3)
+
+  REAL :: airecn,qn
+  REAL :: airecs,qs
+
+  INTEGER :: i,j,l,ig,ig2,j1,j2,i0,jd
+
+  !--------------------------------------------------------------------c
+  ! Strategie d'optimisation                                           c
+  ! stocker les valeurs systematiquement recalculees                   c
+  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
+  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
+  ! de grille au cours de la simulation tout devrait bien se passer.   c
+  ! Autre optimisation : determination des bornes entre lesquelles "j" c
+  ! varie, au lieu de faire un test a chaque fois...
+  !--------------------------------------------------------------------c
+
+  INTEGER :: j_start, j_finish
+
+  REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
+  REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
+!$OMP THREADPRIVATE(airen_tab, aires_tab)
+
+  LOGICAL, SAVE :: first = .TRUE.
+!$OMP THREADPRIVATE(first)
+  ! INTEGER,SAVE :: i_index(iim,ngroup)
+  INTEGER      :: offset
+  ! REAL         :: qsum(iim/ngroup)
+
+  IF (first) THEN
+     CALL init_groupeun_loc(airen_tab, aires_tab)
+     first = .FALSE.
+  ENDIF
+
+  ! Champs 3D
+  jd=jjp1-jjmax
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     j1=1+jd
+     j2=2
+     DO ig=1,ngroup
+
+  ! Concerne le pole nord
+        j_start  = MAX(jjb, j1-jd)
+        j_finish = MIN(jje, j2-jd)
+        DO ig2=1,ngroup-ig+1
+          offset=2**(ig2-1)
+          DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+             DO i0=1,iim,2**ig2
+               q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
+             ENDDO
+          ENDDO
+        ENDDO
+
+        DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
+           ENDDO
+        ENDDO
+
+        DO j=j_start, j_finish
+  !CDIR ON_ADB(airen_tab)
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
+           ENDDO
+           q(iip1,j,l)=q(1,j,l)
+        ENDDO
+
+  !c     Concerne le pole sud
+        j_start  = MAX(1+jjp1-jje-jd, j1-jd)
+        j_finish = MIN(1+jjp1-jjb-jd, j2-jd)
+        DO ig2=1,ngroup-ig+1
+          offset=2**(ig2-1)
+          DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+             DO i0=1,iim,2**ig2
+               q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) &
+                     +q(i0+offset,jjp1-j+1-jd,l)
+             ENDDO
+          ENDDO
+        ENDDO
+
+
+        DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), &
+                   jjp1-j+1-jd,l)
+           ENDDO
+        ENDDO
+
+        DO j=j_start, j_finish
+  !CDIR ON_ADB(aires_tab)
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* &
+                   aires_tab(i,jjp1-j+1,jd)
+           ENDDO
+           q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
+        ENDDO
+
+
+        j1=j2+1
+        j2=j2+2**ig
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE groupeun_loc
+
+
+
+SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
+
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: ngroup
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  ! INTEGER ngroup
+  ! PARAMETER (ngroup=3)
+
+  REAL :: airen,airecn
+  REAL :: aires,airecs
+
+  INTEGER :: i,j,l,ig,j1,j2,i0,jd
+
+  INTEGER :: j_start, j_finish
+
+  REAL :: airen_tab(iip1,jjp1,0:1)
+  REAL :: aires_tab(iip1,jjp1,0:1)
+
+  DO jd=0, 1
+     j1=1+jd
+     j2=2
+     DO ig=1,ngroup
+
+  ! c     Concerne le pole nord
+        j_start = j1-jd
+        j_finish = j2-jd
+        DO j=j_start, j_finish
+           DO i0=1,iim,2**(ngroup-ig+1)
+              airen=0.
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 airen = airen+aire(i,j)
+              ENDDO
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 airen_tab(i,j,jd) = &
+                       aire(i,j) / airen
+              ENDDO
+           ENDDO
+        ENDDO
+
+  ! c     Concerne le pole sud
+        j_start = j1-jd
+        j_finish = j2-jd
+        DO j=j_start, j_finish
+           DO i0=1,iim,2**(ngroup-ig+1)
+              aires=0.
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 aires=aires+aire(i,jjp1-j+1)
+              ENDDO
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 aires_tab(i,jjp1-j+1,jd) = &
+                       aire(i,jjp1-j+1) / aires
+              ENDDO
+           ENDDO
+        ENDDO
+
+        j1=j2+1
+        j2=j2+2**ig
+     ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE init_groupeun_loc
Index: LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,287 +1,0 @@
-!
-! $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_lmdz
-       use Write_field
-       use misc_mod
-!       USE infotrac
-       use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
-     &        dynhistave_file,dynhistvave_file,dynhistuave_file
-       USE comconst_mod, ONLY: pi
-       USE comvert_mod, ONLY: presnivs
-       USE temps_mod, ONLY: itau_dyn
-       
-       implicit none
-
-C
-C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-C   au format IOIPSL. Initialisation du fichier histoire moyenne.
-C
-C   Appels succesifs des routines: histbeg
-C                                  histhori
-C                                  histver
-C                                  histdef
-C                                  histend
-C
-C   Entree:
-C
-C      day0,anne0: date de reference
-C      tstep : frequence d'ecriture
-C      t_ops: frequence de l'operation pour IOIPSL
-C      t_wrt: frequence d'ecriture sur le fichier
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C   Arguments
-C
-      integer*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,jjm /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-
-      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
-     .                 'box',dynhistvave_domain_id)
-
-      call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn,
-     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
-     .             zjulian, tstep, vhoriid,
-     .             histvaveid,dynhistvave_domain_id)
-     
-! Grille U
-
-      do jj = 1, jjp1
-        do ii = 1, iip1
-          rlong(ii,jj) = rlonu(ii) * 180. / pi
-          rlat(ii,jj) = rlatu(jj) * 180. / pi
-        enddo
-      enddo
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-
-      ddid=(/ 1,2 /)
-      dsg=(/ iip1,jjp1 /)
-      dsl=(/ iip1,jjn /)
-      dpf=(/ 1,jjb /)
-      dpl=(/ iip1,jje /)
-      dhs=(/ 0,0 /)
-      dhe=(/ 0,0 /)
-
-
-      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
-     .                 'box',dynhistuave_domain_id)
-             
-      call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn,
-     .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
-     .             zjulian, tstep, uhoriid,
-     .             histuaveid,dynhistuave_domain_id)
-     
-     
-C
-C  Appel a histvert pour la grille verticale
-C
-      call histvert(histaveid,'presnivs','Niveaux Pression
-     &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
-      call histvert(histuaveid,'presnivs','Niveaux Pression
-     &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
-      call histvert(histvaveid,'presnivs','Niveaux Pression
-     &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
-
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-C
-C  Vents U
-C
-      jjn=jj_nb
-      call histdef(histuaveid, 'u', 'vent u moyen ',
-     .             'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu,
-     .             32, 'ave(X)', t_ops, t_wrt)
-
-C
-C  Vents V
-C
-      if (pole_sud) jjn=jj_nb-1
-      call histdef(histvaveid, 'v', 'vent v moyen',
-     .             'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv,
-     .             32, 'ave(X)', t_ops, t_wrt)
-
-C
-C  Temperature
-C
-      jjn=jj_nb
-      call histdef(histaveid, 'temp', 'temperature moyenne', 'K',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Temperature potentielle
-C
-      call histdef(histaveid, 'theta', 'temperature potentielle', 'K',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-
-
-C
-C  Geopotentiel
-C
-      call histdef(histaveid, 'phi', 'geopotentiel moyen', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Traceurs
-C
-!        DO iq=1,nqtot
-!          call histdef(histaveid, tracers(iq)%name,
-!     .                            tracers(iq)%longName, '-',
-!     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-!     .             32, 'ave(X)', t_ops, t_wrt)
-!        enddo
-C
-C  Masse
-C
-      call histdef(histaveid, 'masse', 'masse moyenne', 'kg',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Pression au sol
-C
-      call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa',
-     .             iip1, jjn, thoriid, 1, 1, 1, -99,
-     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Geopotentiel au sol
-C
-!      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
-!     .             iip1, jjn, thoriid, 1, 1, 1, -99,
-!     .             32, 'ave(X)', t_ops, t_wrt)
-C
-C  Fin
-C
-      call histend(histaveid)
-      call histend(histuaveid)
-      call histend(histvaveid)
-#else
-      write(lunout,*)'initdynav_loc: Needs IOIPSL to function'
-#endif
-! #endif of #ifdef CPP_IOIPSL
-      end
Index: LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F90	(revision 5246)
@@ -0,0 +1,287 @@
+!
+! $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_lmdz
+   use Write_field
+   use misc_mod
+    ! USE infotrac
+   use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
+         dynhistave_file,dynhistvave_file,dynhistuave_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+
+   implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep : frequence d'ecriture
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  integer(kind=4) :: day0, anne0
+  real :: tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynhistave_domain_id
+  INTEGER :: dynhistvave_domain_id
+  INTEGER :: dynhistuave_domain_id
+
+  if (adjust) return
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistave_domain_id)
+
+  call histbeg(dynhistave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, thoriid, &
+        histaveid,dynhistave_domain_id)
+
+
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistvave_domain_id)
+
+  call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, vhoriid, &
+        histvaveid,dynhistvave_domain_id)
+
+  ! Grille U
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistuave_domain_id)
+
+  call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, uhoriid, &
+        histuaveid,dynhistuave_domain_id)
+
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(histaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
+  call histvert(histuaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
+  call histvert(histvaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
+
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  call histdef(histuaveid, 'u', 'vent u moyen ', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(histvaveid, 'v', 'vent v moyen', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+
+  !
+  !  Geopotentiel
+  !
+  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histaveid, tracers(iq)%name,
+  ! .                            tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  call histdef(histaveid, 'masse', 'masse moyenne', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(histaveid)
+  call histend(histuaveid)
+  call histend(histvaveid)
+#else
+  write(lunout,*)'initdynav_loc: Needs IOIPSL to function'
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine initdynav_loc
Index: LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F	(revision 5214)
+++ 	(revision )
@@ -1,294 +1,0 @@
-!
-! $Id$
-!
-      subroutine initfluxsto_p
-     .  (infile,tstep,t_ops,t_wrt,
-     .                    fileid,filevid,filedid)
-
-#ifdef CPP_IOIPSL
-! This routine needs IOIPSL
-       USE IOIPSL
-#endif
-       USE parallel_lmdz
-       use Write_field
-       use misc_mod
-       USE comconst_mod, ONLY: pi
-       USE comvert_mod, ONLY: nivsigs
-       USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-       
-      implicit none
-
-C
-C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-C   au format IOIPSL
-C
-C   Appels succesifs des routines: histbeg
-C                                  histhori
-C                                  histver
-C                                  histdef
-C                                  histend
-C
-C   Entree:
-C
-C      infile: nom du fichier histoire a creer
-C      day0,anne0: date de reference
-C      tstep: duree du pas de temps en seconde
-C      t_ops: frequence de l'operation pour IOIPSL
-C      t_wrt: frequence d'ecriture sur le fichier
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C      filevid:ID du fichier netcdf pour la grille v
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C   Arguments
-C
-      character*(*) infile
-      real tstep, t_ops, t_wrt
-      integer fileid, filevid,filedid
-
-#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
-      if (mpi_rank==0) then
-         nivd(1) = 1
-         call histvert(filedid, 'sig_s', 'Niveaux sigma',
-     .        'sigma_level',
-     .        1, nivd, dvertiid)
-      endif
-C
-C  Appels a histdef pour la definition des variables a sauvegarder
-        
-        CALL histdef(fileid, "phis", "Surface geop. height", "-",
-     .                iip1,jjn,thoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-         CALL histdef(fileid, "aire", "Grid area", "-",
-     .                iip1,jjn,thoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-        
-        if (mpi_rank==0) then
-        
-        CALL histdef(filedid, "dtvr", "tps dyn", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-        
-         CALL histdef(filedid, "istdyn", "tps stock", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-         
-         CALL histdef(filedid, "istphy", "tps stock phy", "s",
-     .                1,1,dhoriid, 1,1,1, -99, 32,
-     .                "once", t_ops, t_wrt)
-
-        endif
-C
-C Masse 
-C
-      call histdef(fileid, 'masse', 'Masse', 'kg',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Pbaru 
-C
-      call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
-     .             iip1, jjn, uhoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Pbarv 
-C
-      if (pole_sud) jjn=jj_nb-1
-      
-      call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
-     .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  w 
-C
-      if (pole_sud) jjn=jj_nb
-      call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Temperature potentielle
-C
-      call histdef(fileid, 'teta', 'temperature potentielle', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-
-C
-C Geopotentiel 
-C
-      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Fin
-C
-      call histend(fileid)
-      call histend(filevid)
-      if (mpi_rank==0) call histend(filedid)
-      if (ok_sync) then
-        call histsync(fileid)
-        call histsync(filevid)
-        if (mpi_rank==0) call histsync(filedid)
-      endif
-        
-#else
-      write(lunout,*)'initfluxsto_p: Needs IOIPSL to function'
-#endif
-! #endif of #ifdef CPP_IOIPSL
-      return
-      end
Index: LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F90	(revision 5246)
@@ -0,0 +1,294 @@
+!
+! $Id$
+!
+subroutine initfluxsto_p &
+        (infile,tstep,t_ops,t_wrt, &
+        fileid,filevid,filedid)
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL
+   USE IOIPSL
+#endif
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: nivsigs
+   USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !  filevid:ID du fichier netcdf pour la grille v
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  character(len=*) :: infile
+  real :: tstep, t_ops, t_wrt
+  integer :: fileid, filevid,filedid
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  real :: nivd(1)
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+  integer :: ii,jj
+  integer :: zan, idayref
+  logical :: ok_sync
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynu_domain_id
+  INTEGER :: dynv_domain_id
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  str='q  '
+  ctrac = 'traceur   '
+  ok_sync = .true.
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+    do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynu_domain_id)
+
+  call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+        1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, &
+        fileid,dynu_domain_id)
+  !
+  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+
+
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynv_domain_id)
+
+  call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+        1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, &
+        filevid,dynv_domain_id)
+
+  rl(1,1) = 1.
+
+  if (mpi_rank==0) then
+
+    call histbeg('defstoke.nc', 1, rl, 1, rl, &
+          1, 1, 1, 1, &
+          tau0, zjulian, tstep, dhoriid, filedid)
+
+  endif
+  !
+  !  Appel a histhori pour rajouter les autres grilles horizontales
+  !
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), &
+        'scalar','Grille points scalaires', thoriid)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! Pour le fichier V
+  call histvert(filevid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! pour le fichier def
+  if (mpi_rank==0) then
+     nivd(1) = 1
+     call histvert(filedid, 'sig_s', 'Niveaux sigma', &
+           'sigma_level', &
+           1, nivd, dvertiid)
+  endif
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+          iip1,jjn,thoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(fileid, "aire", "Grid area", "-", &
+           iip1,jjn,thoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    if (mpi_rank==0) then
+
+    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
+          1,1,dhoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istdyn", "tps stock", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    endif
+  !
+  ! Masse
+  !
+  call histdef(fileid, 'masse', 'Masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbaru
+  !
+  call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
+        iip1, jjn, uhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Pbarv
+  !
+  if (pole_sud) jjn=jj_nb-1
+
+  call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
+        iip1, jjn, vhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  w
+  !
+  if (pole_sud) jjn=jj_nb
+  call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature potentielle
+  !
+  call histdef(fileid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+
+  !
+  ! Geopotentiel
+  !
+  call histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(fileid)
+  call histend(filevid)
+  if (mpi_rank==0) call histend(filedid)
+  if (ok_sync) then
+    call histsync(fileid)
+    call histsync(filevid)
+    if (mpi_rank==0) call histsync(filedid)
+  endif
+
+#else
+  write(lunout,*)'initfluxsto_p: Needs IOIPSL to function'
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+  return
+end subroutine initfluxsto_p
Index: LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,287 +1,0 @@
-!
-! $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_lmdz
-       use Write_field
-       use misc_mod
-       use com_io_dyn_mod, only : histid,histvid,histuid,               &
-     &                        dynhist_file,dynhistv_file,dynhistu_file
-       USE comconst_mod, ONLY: pi
-       USE comvert_mod, ONLY: presnivs
-       USE temps_mod, ONLY: itau_dyn
-       
-       implicit none
-
-C
-C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-C   au format IOIPSL
-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 "comgeom.h"
-      include "description.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,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',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
-
-      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',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
-      jjn=jj_nb
-      call histdef(histuid, 'u', 'vent u',
-     .             'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Vents V
-C
-      if (pole_sud) jjn=jj_nb-1
-      call histdef(histvid, 'v', 'vent v',
-     .             'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-C
-C  Temperature
-C
-      jjn=jj_nb
-      call histdef(histid, 'temp', 'temperature', 'K',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Temperature potentielle
-C
-      call histdef(histid, 'theta', 'temperature potentielle', 'K',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-
-
-C
-C  Geopotentiel
-C
-      call histdef(histid, 'phi', 'geopotentiel', '-',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Traceurs
-C
-!        DO iq=1,nqtot
-!          call histdef(histid, tracers(iq)%name, 
-!     .             tracers(iq)%longName, '-', 
-!     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-!     .             32, 'inst(X)', t_ops, t_wrt)
-!        enddo
-C
-C  Masse
-C
-      call histdef(histid, 'masse', 'masse', 'kg',
-     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Pression au sol
-C
-      call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa',
-     .             iip1, jjn, thoriid, 1, 1, 1, -99,
-     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Geopotentiel au sol
-C
-!      call histdef(histid, 'phis', 'geopotentiel au sol', '-',
-!     .             iip1, jjn, thoriid, 1, 1, 1, -99,
-!     .             32, 'inst(X)', t_ops, t_wrt)
-C
-C  Fin
-C
-      call histend(histid)
-      call histend(histuid)
-      call histend(histvid)
-#else
-      write(lunout,*)'inithist_loc: Needs IOIPSL to function'
-#endif
-! #endif of #ifdef CPP_IOIPSL
-      end
Index: LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F90	(revision 5246)
@@ -0,0 +1,287 @@
+!
+! $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_lmdz
+   use Write_field
+   use misc_mod
+   use com_io_dyn_mod, only : histid,histvid,histuid,               &
+         dynhist_file,dynhistv_file,dynhistu_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+
+   implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !  nq: nombre de traceurs
+  !
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  integer :: day0, anne0
+  real :: tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynhist_domain_id
+  INTEGER :: dynhistv_domain_id
+  INTEGER :: dynhistu_domain_id
+
+  if (adjust) return
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',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)
+
+
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',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
+
+  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',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)
+
+
+  ! -------------------------------------------------------------
+  !  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')
+
+  !
+  ! -------------------------------------------------------------
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  ! -------------------------------------------------------------
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  call histdef(histuid, 'u', 'vent u', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(histvid, 'v', 'vent v', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  call histdef(histid, 'temp', 'temperature', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+
+  !
+  !  Geopotentiel
+  !
+  call histdef(histid, 'phi', 'geopotentiel', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histid, tracers(iq)%name,
+  ! .             tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  call histdef(histid, 'masse', 'masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histdef(histid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(histid)
+  call histend(histuid)
+  call histend(histvid)
+#else
+  write(lunout,*)'inithist_loc: Needs IOIPSL to function'
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine inithist_loc
Index: LMDZ6/trunk/libf/dyn3dmem/integrd_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/integrd_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,451 +1,0 @@
-!
-! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-      SUBROUTINE integrd_loc
-     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
-     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
-      USE parallel_lmdz
-      USE control_mod
-      USE mod_filtreg_p
-      USE write_field_loc
-      USE write_field
-      USE integrd_mod
-      USE comconst_mod, ONLY: pi
-      USE logic_mod, ONLY: leapf
-      USE comvert_mod, ONLY: ap, bp
-      USE temps_mod, ONLY: dt
-      
-      IMPLICIT NONE
-
-
-c=======================================================================
-c
-c   Auteur:  P. Le Van
-c   -------
-c
-c   objet:
-c   ------
-c
-c   Incrementation des tendances dynamiques
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
-
-      REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
-      REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
-      REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
-      REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
-      REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
-      REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
-      REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
-      ! values at previous time step
-      REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
-      REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
-      REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
-      ! the tendencies to add
-      REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
-      REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
-      REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
-      REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
-!      REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
-
-c   Local:
-c   ------
-
-      REAL vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
-      REAL hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
-      REAL massescr( ijb_u:ije_u,llm )
-!      REAL finvmasse(ijb_u:ije_u,llm)
-      REAL tpn,tps,tppn(iim),tpps(iim)
-      REAL qpn,qps,qppn(iim),qpps(iim)
-
-      INTEGER  l,ij,iq,i,j
-
-      REAL SSUM
-      EXTERNAL SSUM
-      INTEGER ijb,ije,jjb,jje
-      LOGICAL :: checksum
-      LOGICAL,SAVE :: checksum_all=.TRUE.
-      INTEGER :: stop_it
-      INTEGER :: ierr
-
-      !write(*,*) 'integrd 88: entree, nq=',nq
-c-----------------------------------------------------------------------
-
-c$OMP BARRIER     
-      if (pole_nord) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO  l = 1,llm
-          DO  ij = 1,iip1
-           ucov(    ij    , l) = 0.
-           uscr(     ij      ) = 0.
-           ENDDO
-        ENDDO
-c$OMP END DO NOWAIT        
-      ENDIF
-
-      if (pole_sud) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-        DO  l = 1,llm
-          DO  ij = 1,iip1
-           ucov( ij +ip1jm, l) = 0.
-           uscr( ij +ip1jm   ) = 0.
-          ENDDO
-        ENDDO
-c$OMP END DO NOWAIT      
-      ENDIF
-
-c    ............    integration  de       ps         ..............
-
-c      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
-
-      ijb=ij_begin
-      ije=ij_end
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-      DO  l = 1,llm
-        massescr(ijb:ije,l)=masse(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT 
-
-c$OMP DO SCHEDULE(STATIC)
-      DO 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
-         write(lunout,*) "integrd: ps = ", ps(stop_it)
-         write(lunout,*) " at node ij =", stop_it
-         ! since ij=j+(i-1)*jjp1 , we have
-          j=modulo(stop_it,jjp1)
-          i=1+(stop_it-j)/jjp1
-          write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
-     &                    " lat = ",rlatu(j)*180./pi, " deg"
-         call abort_gcm("integrd_loc", "negative surface pressure", 1)
-      ENDIF
-
-c$OMP END MASTER
-c$OMP BARRIER
-        !write(*,*) 'integrd 170'
-      IF (.NOT. Checksum_all) THEN
-        call WriteField_v('int_vcov',vcov)
-        call WriteField_u('int_ucov',ucov)
-        call WriteField_u('int_teta',teta)
-        call WriteField_u('int_ps0',ps0)
-        call WriteField_u('int_masse',masse)
-        call WriteField_u('int_phis',phis)
-        call WriteField_v('int_vcovm1',vcovm1)
-        call WriteField_u('int_ucovm1',ucovm1)
-        call WriteField_u('int_tetam1',tetam1)
-        call WriteField_u('int_psm1',psm1)
-        call WriteField_u('int_massem1',massem1)
-
-        call WriteField_v('int_dv',dv)
-        call WriteField_u('int_du',du)
-        call WriteField_u('int_dteta',dteta)
-        call WriteField_u('int_dp',dp)
-!        call WriteField_u('int_finvmaold',finvmaold)
-        do j=1,nq
-          call WriteField_u('int_q'//trim(int2str(j)),
-     .                q(:,:,j))
-          call WriteField_u('int_dq'//trim(int2str(j)),
-     .                dq(:,:,j))
-        enddo
-        call abort_gcm("integrd_loc", "", 1)
-      ENDIF
-    
-       
-c
-        !write(*,*) 'integrd 200'
-C$OMP MASTER
-      if (pole_nord) THEN
-      
-        DO  ij    = 1, iim
-         tppn(ij) = aire(   ij   ) * ps(  ij    )
-        ENDDO
-         tpn      = SSUM(iim,tppn,1)/apoln
-        DO ij   = 1, iip1
-         ps(   ij   )  = tpn
-        ENDDO
-      
-      ENDIF
-      
-      if (pole_sud) THEN
-      
-        DO  ij    = 1, iim
-         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
-        ENDDO
-         tps      = SSUM(iim,tpps,1)/apols
-        DO ij   = 1, iip1
-         ps(ij+ip1jm)  = tps
-        ENDDO
-      
-      ENDIF
-c$OMP END MASTER
-c$OMP BARRIER
-      !write(*,*) 'integrd 217'  
-c
-c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
-c
-
-      CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
-
-c$OMP BARRIER
-      CALL massdair_loc (     p  , masse         )
-
-! Ehouarn : we don't use/need finvmaold and finvmasse,
-!           so might as well not compute them
-!c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
-!      ijb=ij_begin
-!      ije=ij_end
-!      
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-!      DO  l = 1,llm
-!        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
-!      ENDDO
-!c$OMP END DO NOWAIT
-
-!      jjb=jj_begin
-!      jje=jj_end
-!      CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
-!     &                -2, 2, .TRUE., 1  )
-c
-
-c    ............   integration  de  ucov, vcov,  h     ..............
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-      DO 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
-        !write(*,*) 'integrd 291'
-      IF (pole_nord) THEN
-       
-        DO  ij   = 1, iim
-          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
-        ENDDO
-          tpn      = SSUM(iim,tppn,1)/apoln
-
-        DO ij   = 1, iip1
-          teta(   ij   ,l)  = tpn
-        ENDDO
-      
-      ENDIF
-      
-      IF (pole_sud) THEN
-       
-        DO  ij   = 1, iim
-          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
-        ENDDO
-          tps      = SSUM(iim,tpps,1)/apols
-
-        DO ij   = 1, iip1
-          teta(ij+ip1jm,l)  = tps
-        ENDDO
-      
-      ENDIF
-c
-
-      IF(leapf)  THEN
-c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
-c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
-c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
-        ijb=ij_begin
-        ije=ij_end
-        ucovm1(ijb:ije,l)=uscr(ijb:ije)
-        tetam1(ijb:ije,l)=hscr(ijb:ije)
-        if (pole_sud) ije=ij_end-iip1
-        vcovm1(ijb:ije,l)=vscr(ijb:ije)
-      
-      END IF
-
-  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 check_isotopes(q,ijb,ije,'integrd 342')
-
-        !write(*,*) 'integrd 341'
-        CALL qminimum_loc( q, nq, deltap )
-        !write(*,*) 'integrd 343'
-
-        call check_isotopes(q,ijb,ije,'integrd 346')
-c
-c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
-c
-c$OMP BARRIER
-      IF (pole_nord) THEN 
-      
-        DO iq = 1, nq
-        
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-  
-             DO ij = 1, iim
-               qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
-             ENDDO
-               qpn  =  SSUM(iim,qppn,1)/apoln
-      
-             DO ij = 1, iip1
-               q(   ij   ,l,iq)  = qpn
-             ENDDO    
-  
-          ENDDO
-c$OMP END DO NOWAIT
-
-        ENDDO
-      
-      ENDIF
-
-      IF (pole_sud) THEN 
-      
-        DO iq = 1, nq
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-  
-             DO ij = 1, iim
-               qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
-             ENDDO
-               qps  =  SSUM(iim,qpps,1)/apols 
-  
-             DO ij = 1, iip1
-               q(ij+ip1jm,l,iq)  = qps
-             ENDDO    
-  
-          ENDDO
-c$OMP END DO NOWAIT
-
-        ENDDO
-      
-      ENDIF
-
-      call check_isotopes(q,ijb,ije,'integrd 409')
-      
-! Ehouarn: forget about finvmaold
-!c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
-
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-!      DO l = 1, llm      
-!        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)        
-!      ENDDO
-!c$OMP END DO NOWAIT
-
-      endif ! of if (planet_type.eq."earth")
-
-c
-c
-c     .....   FIN  de l'integration  de   q    .......
-
-15    continue
-          !write(*,*) 'integrd 410'
-
-c$OMP DO SCHEDULE(STATIC)
-      DO ij=ijb,ije  
-        ps0(ij)=ps(ij)
-      ENDDO
-c$OMP END DO NOWAIT 
-
-c    .................................................................
-
-
-      IF( leapf )  THEN
-c       CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
-c       CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
-c$OMP DO SCHEDULE(STATIC)
-      DO ij=ijb,ije  
-        psm1(ij)=pscr(ij)
-      ENDDO
-c$OMP END DO NOWAIT 
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-            massem1(ijb:ije,l)=massescr(ijb:ije,l)
-          ENDDO
-c$OMP END DO NOWAIT          
-      END IF
-c$OMP BARRIER
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/integrd_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/integrd_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/integrd_loc.f90	(revision 5246)
@@ -0,0 +1,451 @@
+!
+! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+SUBROUTINE integrd_loc &
+        (  nq,vcovm1,ucovm1,tetam1,psm1,massem1, &
+        dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
+  USE parallel_lmdz
+  USE control_mod
+  USE mod_filtreg_p
+  USE write_field_loc
+  USE write_field
+  USE integrd_mod
+  USE comconst_mod, ONLY: pi
+  USE logic_mod, ONLY: leapf
+  USE comvert_mod, ONLY: ap, bp
+  USE temps_mod, ONLY: dt
+
+  IMPLICIT NONE
+
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   objet:
+  !   ------
+  !
+  !   Incrementation des tendances dynamiques
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
+
+  REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
+  REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
+  REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
+  REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
+  ! ! values at previous time step
+  REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
+  REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
+  REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
+  ! ! the tendencies to add
+  REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
+  REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
+  REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
+   ! REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
+
+  !   Local:
+  !   ------
+
+  REAL :: vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
+  REAL :: hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
+  REAL :: massescr( ijb_u:ije_u,llm )
+   ! REAL finvmasse(ijb_u:ije_u,llm)
+  REAL :: tpn,tps,tppn(iim),tpps(iim)
+  REAL :: qpn,qps,qppn(iim),qpps(iim)
+
+  INTEGER :: l,ij,iq,i,j
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  LOGICAL :: checksum
+  LOGICAL,SAVE :: checksum_all=.TRUE.
+  INTEGER :: stop_it
+  INTEGER :: ierr
+
+  ! !write(*,*) 'integrd 88: entree, nq=',nq
+  !-----------------------------------------------------------------------
+
+!$OMP BARRIER
+  if (pole_nord) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  l = 1,llm
+      DO  ij = 1,iip1
+       ucov(    ij    , l) = 0.
+       uscr(     ij      ) = 0.
+       ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  if (pole_sud) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  l = 1,llm
+      DO  ij = 1,iip1
+       ucov( ij +ip1jm, l) = 0.
+       uscr( ij +ip1jm   ) = 0.
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  !    ............    integration  de       ps         ..............
+
+   ! CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l = 1,llm
+    massescr(ijb:ije,l)=masse(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC)
+  DO ij = ijb,ije
+   pscr (ij)    = ps0(ij)
+   ps (ij)      = psm1(ij) + dt * dp(ij)
+
+  END DO
+
+!$OMP END DO
+!$OMP BARRIER
+  ! --> ici synchro OPENMP pour ps
+
+  checksum=.TRUE.
+  stop_it=0
+
+!$OMP MASTER
+  !c$OMP DO SCHEDULE(STATIC)
+  DO ij = ijb,ije
+     IF( ps(ij).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
+     write(lunout,*) "integrd: ps = ", ps(stop_it)
+     write(lunout,*) " at node ij =", stop_it
+     ! ! since ij=j+(i-1)*jjp1 , we have
+      j=modulo(stop_it,jjp1)
+      i=1+(stop_it-j)/jjp1
+      write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg", &
+            " lat = ",rlatu(j)*180./pi, " deg"
+     call abort_gcm("integrd_loc", "negative surface pressure", 1)
+  ENDIF
+
+!$OMP END MASTER
+!$OMP BARRIER
+    ! !write(*,*) 'integrd 170'
+  IF (.NOT. Checksum_all) THEN
+    call WriteField_v('int_vcov',vcov)
+    call WriteField_u('int_ucov',ucov)
+    call WriteField_u('int_teta',teta)
+    call WriteField_u('int_ps0',ps0)
+    call WriteField_u('int_masse',masse)
+    call WriteField_u('int_phis',phis)
+    call WriteField_v('int_vcovm1',vcovm1)
+    call WriteField_u('int_ucovm1',ucovm1)
+    call WriteField_u('int_tetam1',tetam1)
+    call WriteField_u('int_psm1',psm1)
+    call WriteField_u('int_massem1',massem1)
+
+    call WriteField_v('int_dv',dv)
+    call WriteField_u('int_du',du)
+    call WriteField_u('int_dteta',dteta)
+    call WriteField_u('int_dp',dp)
+     ! call WriteField_u('int_finvmaold',finvmaold)
+    do j=1,nq
+      call WriteField_u('int_q'//trim(int2str(j)), &
+            q(:,:,j))
+      call WriteField_u('int_dq'//trim(int2str(j)), &
+            dq(:,:,j))
+    enddo
+    call abort_gcm("integrd_loc", "", 1)
+  ENDIF
+
+
+  !
+  !   !write(*,*) 'integrd 200'
+!$OMP MASTER
+  if (pole_nord) THEN
+
+    DO  ij    = 1, iim
+     tppn(ij) = aire(   ij   ) * ps(  ij    )
+    ENDDO
+     tpn      = SSUM(iim,tppn,1)/apoln
+    DO ij   = 1, iip1
+     ps(   ij   )  = tpn
+    ENDDO
+
+  ENDIF
+
+  if (pole_sud) THEN
+
+    DO  ij    = 1, iim
+     tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+    ENDDO
+     tps      = SSUM(iim,tpps,1)/apols
+    DO ij   = 1, iip1
+     ps(ij+ip1jm)  = tps
+    ENDDO
+
+  ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  ! !write(*,*) 'integrd 217'
+  !
+  !  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+  !
+
+  CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
+
+!$OMP BARRIER
+  CALL massdair_loc (     p  , masse         )
+
+  ! Ehouarn : we don't use/need finvmaold and finvmasse,
+        ! so might as well not compute them
+  !c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+   ! ijb=ij_begin
+   ! ije=ij_end
+  !
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !  DO  l = 1,llm
+  !    finvmasse(ijb:ije,l)=masse(ijb:ije,l)
+  !  ENDDO
+  !c$OMP END DO NOWAIT
+
+  !  jjb=jj_begin
+  !  jje=jj_end
+  !  CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
+  ! &                -2, 2, .TRUE., 1  )
+  !
+
+  !    ............   integration  de  ucov, vcov,  h     ..............
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+  uscr( ij )   =  ucov( ij,l )
+  ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+  END DO
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb,ije
+  vscr( ij )   =  vcov( ij,l )
+  vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+  END DO
+
+  ijb=ij_begin
+  ije=ij_end
+
+  DO ij = ijb,ije
+  hscr( ij )    =  teta(ij,l)
+  teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) &
+        + dt * dteta(ij,l) / masse(ij,l)
+  END DO
+
+  !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+  !
+  !
+  !   !write(*,*) 'integrd 291'
+  IF (pole_nord) THEN
+
+    DO  ij   = 1, iim
+      tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+    ENDDO
+      tpn      = SSUM(iim,tppn,1)/apoln
+
+    DO ij   = 1, iip1
+      teta(   ij   ,l)  = tpn
+    ENDDO
+
+  ENDIF
+
+  IF (pole_sud) THEN
+
+    DO  ij   = 1, iim
+      tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+    ENDDO
+      tps      = SSUM(iim,tpps,1)/apols
+
+    DO ij   = 1, iip1
+      teta(ij+ip1jm,l)  = tps
+    ENDDO
+
+  ENDIF
+  !
+
+  IF(leapf)  THEN
+      ! CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+      ! CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+      ! CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+    ijb=ij_begin
+    ije=ij_end
+    ucovm1(ijb:ije,l)=uscr(ijb:ije)
+    tetam1(ijb:ije,l)=hscr(ijb:ije)
+    if (pole_sud) ije=ij_end-iip1
+    vcovm1(ijb:ije,l)=vscr(ijb:ije)
+
+  END IF
+
+  END DO
+!$OMP END DO NOWAIT
+
+  !
+  !   .......  integration de   q   ......
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+     if (planet_type.eq."earth") then
+  ! Earth-specific treatment of first 2 tracers (water)
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+       DO ij = ijb, ije
+        deltap(ij,l) =  p(ij,l) - p(ij,l+1)
+       ENDDO
+      ENDDO
+
+!$OMP END DO NOWAIT
+!$OMP BARRIER
+
+    call check_isotopes(q,ijb,ije,'integrd 342')
+
+    ! !write(*,*) 'integrd 341'
+    CALL qminimum_loc( q, nq, deltap )
+    ! !write(*,*) 'integrd 343'
+
+    call check_isotopes(q,ijb,ije,'integrd 346')
+  !
+  !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+  !
+!$OMP BARRIER
+  IF (pole_nord) THEN
+
+    DO iq = 1, nq
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+
+         DO ij = 1, iim
+           qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+         ENDDO
+           qpn  =  SSUM(iim,qppn,1)/apoln
+
+         DO ij = 1, iip1
+           q(   ij   ,l,iq)  = qpn
+         ENDDO
+
+      ENDDO
+!$OMP END DO NOWAIT
+
+    ENDDO
+
+  ENDIF
+
+  IF (pole_sud) THEN
+
+    DO iq = 1, nq
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+
+         DO ij = 1, iim
+           qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+         ENDDO
+           qps  =  SSUM(iim,qpps,1)/apols
+
+         DO ij = 1, iip1
+           q(ij+ip1jm,l,iq)  = qps
+         ENDDO
+
+      ENDDO
+!$OMP END DO NOWAIT
+
+    ENDDO
+
+  ENDIF
+
+  call check_isotopes(q,ijb,ije,'integrd 409')
+
+  ! Ehouarn: forget about finvmaold
+  !c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   ! DO l = 1, llm
+   !   finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
+   ! ENDDO
+  !c$OMP END DO NOWAIT
+
+  endif ! of if (planet_type.eq."earth")
+
+  !
+  !
+  ! .....   FIN  de l'integration  de   q    .......
+
+15   continue
+      ! !write(*,*) 'integrd 410'
+
+!$OMP DO SCHEDULE(STATIC)
+  DO ij=ijb,ije
+    ps0(ij)=ps(ij)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !    .................................................................
+
+
+  IF( leapf )  THEN
+    ! CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+    ! CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+!$OMP DO SCHEDULE(STATIC)
+  DO ij=ijb,ije
+    psm1(ij)=pscr(ij)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+        massem1(ijb:ije,l)=massescr(ijb:ije,l)
+      ENDDO
+!$OMP END DO NOWAIT
+  END IF
+!$OMP BARRIER
+  RETURN
+END SUBROUTINE integrd_loc
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,65 +1,0 @@
-      SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam,
-     *                        unsapolnga, unsapolsga, teta, divgra )
-
-c  P. Le Van
-c
-c   ************************************************************
-c
-c      ....   calcul de  (div( grad ))   de   teta  .....
-c   ************************************************************
-c    klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    ............     variables  en arguments    ..........
-c
-      INTEGER klevel
-      REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
-      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 )
-      REAL unsaigam(ip1jmp1)
-      REAL unsapolnga, unsapolsga
-c
-c    ...........    variables  locales    .................
-c
-      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
-c    ......................................................
-
-      INTEGER :: ijb,ije
-      INTEGER :: l      
-c
-c
-c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
-c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
-c   ...  unsairegam =  1. /  aire ** (- gamdissip )
-c
-
-c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
-      
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud ) ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,klevel      
-        divgra(ijb:ije,l)=teta(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-c
-      CALL   grad_loc ( klevel, divgra, ghx, ghy )
-c
-      CALL  diverg_gam_loc ( klevel, cuvsga, cvusga,  unsaigam  ,
-     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
-
-c
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.f90	(revision 5246)
@@ -0,0 +1,65 @@
+SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam, &
+        unsapolnga, unsapolsga, teta, divgra )
+
+  !  P. Le Van
+  !
+  !   ************************************************************
+  !
+  !  ....   calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  !    klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    ............     variables  en arguments    ..........
+  !
+  INTEGER :: klevel
+  REAL :: teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
+  REAL :: cuvsga(ip1jm) , cvusga( ip1jmp1 )
+  REAL :: unsaigam(ip1jmp1)
+  REAL :: unsapolnga, unsapolsga
+  !
+  !    ...........    variables  locales    .................
+  !
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !    ......................................................
+
+  INTEGER :: ijb,ije
+  INTEGER :: l
+  !
+  !
+  !   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+  !   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+  !   ...  unsairegam =  1. /  aire ** (- gamdissip )
+  !
+
+  !  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud ) ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,klevel
+    divgra(ijb:ije,l)=teta(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+  CALL   grad_loc ( klevel, divgra, ghx, ghy )
+  !
+  CALL  diverg_gam_loc ( klevel, cuvsga, cvusga,  unsaigam  , &
+        unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+  !
+
+  RETURN
+END SUBROUTINE laplacien_gam_loc
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,58 +1,0 @@
-      SUBROUTINE laplacien_loc ( klevel, teta, divgra )
-c
-c     P. Le Van
-c
-c   ************************************************************
-c    ....     calcul de  (div( grad ))   de   teta  .....
-c   ************************************************************
-c     klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    .........      variables  en arguments   ..............
-c
-      INTEGER klevel
-      REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
-      INTEGER :: l
-c
-c    ............     variables  locales      ..............
-c
-      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
-c    .......................................................
-
-      
-      INTEGER :: ijb,ije,jjb,jje
-c
-c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
-
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud ) ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,klevel      
-        divgra(ijb:ije,l)=teta(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-      
-      jjb=jj_begin-1
-      jje=jj_end+1
-      if (pole_nord) jjb=jj_begin
-      if (pole_sud ) jje=jj_end
-      
-      CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, 
-     &                klevel,  2, 1, .TRUE., 1 )
-      CALL   grad_loc ( klevel,divgra,   ghx , ghy              )
-      CALL  divergf_loc ( klevel, ghx , ghy  , divgra           )
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.f90	(revision 5246)
@@ -0,0 +1,58 @@
+SUBROUTINE laplacien_loc ( klevel, teta, divgra )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !    ....     calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    .........      variables  en arguments   ..............
+  !
+  INTEGER :: klevel
+  REAL :: teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
+  INTEGER :: l
+  !
+  !    ............     variables  locales      ..............
+  !
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !    .......................................................
+
+
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud ) ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,klevel
+    divgra(ijb:ije,l)=teta(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud ) jje=jj_end
+
+  CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, &
+        klevel,  2, 1, .TRUE., 1 )
+  CALL   grad_loc ( klevel,divgra,   ghx , ghy              )
+  CALL  divergf_loc ( klevel, ghx , ghy  , divgra           )
+
+  RETURN
+END SUBROUTINE laplacien_loc
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,47 +1,0 @@
-      SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
-c
-c    P. Le Van
-c
-c   ************************************************************
-c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
-c   ************************************************************
-c
-c     klevel et rotin  sont des arguments  d'entree pour le s-prog
-c      rotout           est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c 
-c   ..........    variables  en  arguments     .............
-c
-      INTEGER klevel
-      REAL rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
-c
-c   ..........    variables   locales       ................
-c
-      REAL ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel)
-c   ........................................................
-c
-c
-      INTEGER :: ijb,ije,jjb,jje
-      
-      jjb=jj_begin-1
-      jje=jj_end+1
-      
-      if (pole_nord) jjb=jj_begin
-      if (pole_sud) jje=jj_end-1
-      
-      CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm,
-     &                  klevel,2, 1, .FALSE., 1)
-
-      CALL   nxgrad_loc ( klevel, rotin,   ghx ,  ghy            )
-      CALL   rotatf_loc  ( klevel, ghx  ,   ghy , rotout         )
-c
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.f90	(revision 5246)
@@ -0,0 +1,47 @@
+SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
+  !
+  !    P. Le Van
+  !
+  !   ************************************************************
+  !    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+  !   ************************************************************
+  !
+  ! klevel et rotin  sont des arguments  d'entree pour le s-prog
+  !  rotout           est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !   ..........    variables  en  arguments     .............
+  !
+  INTEGER :: klevel
+  REAL :: rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+  !
+  !   ..........    variables   locales       ................
+  !
+  REAL :: ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel)
+  !   ........................................................
+  !
+  !
+  INTEGER :: ijb,ije,jjb,jje
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+
+  CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm, &
+        klevel,2, 1, .FALSE., 1)
+
+  CALL   nxgrad_loc ( klevel, rotin,   ghx ,  ghy            )
+  CALL   rotatf_loc  ( klevel, ghx  ,   ghy , rotout         )
+  !
+  RETURN
+END SUBROUTINE laplacien_rot_loc
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,48 +1,0 @@
-      SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
-c
-c     P. Le Van
-c
-c   ************************************************************
-c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
-c   ************************************************************
-c     klevel et teta  sont des arguments  d'entree pour le s-prog
-c      divgra     est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-
-c
-c    .............   variables  en  arguments    ...........
-c
-      INTEGER klevel
-      REAL rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
-c
-c   ............     variables   locales     ...............
-c
-      INTEGER l, ij
-      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
-c   ........................................................
-c
-      INTEGER :: ijb,ije
-      
-c
-
-      CALL   nxgrad_gam_loc ( klevel, rotin,   ghx ,   ghy  )
-      CALL   rotat_nfil_loc ( klevel, ghx  ,   ghy , rotout )
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l = 1, klevel
-        DO ij = ijb, ije
-         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.f90	(revision 5246)
@@ -0,0 +1,48 @@
+SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+
+  !
+  !    .............   variables  en  arguments    ...........
+  !
+  INTEGER :: klevel
+  REAL :: rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+  !
+  !   ............     variables   locales     ...............
+  !
+  INTEGER :: l, ij
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !   ........................................................
+  !
+  INTEGER :: ijb,ije
+
+  !
+
+  CALL   nxgrad_gam_loc ( klevel, rotin,   ghx ,   ghy  )
+  CALL   rotat_nfil_loc ( klevel, ghx  ,   ghy , rotout )
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+     rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE laplacien_rotgam_loc
Index: LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,1887 +1,0 @@
-! 
-! $Id$
-!
-c
-c
-#define DEBUG_IO
-#undef DEBUG_IO
-
-
-      SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0,
-     &                        masse0,phis0,q0,time_0)
-
-       USE misc_mod
-       USE parallel_lmdz
-       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_mod
-       USE call_dissip_mod, ONLY : call_dissip
-       USE call_calfis_mod, ONLY : call_calfis
-       USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq
-     & ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw
-     & ,pbaru,pbarv,du,dv,dteta,phi,dp,w
-     & ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip
-
-       use exner_hyb_loc_m, only: exner_hyb_loc
-       use exner_milieu_loc_m, only: exner_milieu_loc
-       USE comconst_mod, ONLY: cpp, dtvr, ihf
-       USE comvert_mod, ONLY: ap, bp, pressure_exner
-       USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys,
-     &                      statcl,conser,apdiss,purmats,ok_strato
-       USE temps_mod, ONLY: itaufin,jD_ref,jH_ref,day_ini,
-     &                        day_ref,start_time,dt
-       USE mod_xios_dyn3dmem, ONLY : dyn3d_ctx_handle
-       USE lmdz_xios, ONLY: xios_update_calendar, 
-     &                      xios_set_current_context, 
-     &                      using_xios
-       
-      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 "comdissnew.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-      include "academic.h"
-      
-      REAL,INTENT(IN) :: time_0 ! not used
-
-c   dynamical variables:
-      REAL,INTENT(IN) :: ucov0(ijb_u:ije_u,llm)    ! zonal covariant wind
-      REAL,INTENT(IN) :: vcov0(ijb_v:ije_v,llm)    ! meridional covariant wind
-      REAL,INTENT(IN) :: teta0(ijb_u:ije_u,llm)    ! potential temperature
-      REAL,INTENT(IN) :: q0(ijb_u:ije_u,llm,nqtot) ! advected tracers
-      REAL,INTENT(IN) :: ps0(ijb_u:ije_u)          ! surface pressure (Pa)
-      REAL,INTENT(IN) :: masse0(ijb_u:ije_u,llm)   ! air mass
-      REAL,INTENT(IN) :: phis0(ijb_u:ije_u)        ! geopotentiat at the surface
-
-      real zqmin,zqmax
-
-!      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,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 :: physic
-      LOGICAL first,callinigrads
-
-      data callinigrads/.true./
-      character*10 string10
-
-!      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(len=*),parameter :: modname="leapfrog_loc"
-      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
-      INTEGER :: iapptrac
-      INTEGER :: AdjustCount
-!      INTEGER :: var_time
-      LOGICAL :: ok_start_timer=.FALSE.
-      LOGICAL, SAVE :: firstcall=.TRUE.
-      TYPE(distrib),SAVE :: new_dist
-
-      call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
-      
-c$OMP MASTER
-      ItCount=0
-c$OMP END MASTER      
-      true_itau=0
-      FirstCaldyn=.TRUE.
-      FirstPhysic=.TRUE.
-      iapptrac=0
-      AdjustCount = 0
-      lafin=.false.
-      
-      if (nday>=0) then
-         itaufin   = nday*day_step
-      else
-         itaufin   = -nday
-      endif
-
-      itaufinp1 = itaufin +1
-
-      call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
-
-      itau = 0
-      physic=.true.
-      if (iflag_phys==0.or.iflag_phys==2) physic=.false.
-      CALL init_nan
-      CALL leapfrog_allocate
-      ucov=ucov0
-      vcov=vcov0
-      teta=teta0
-      ps=ps0
-      masse=masse0
-      phis=phis0
-      q=q0
-
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
-      
-!      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
-!$OMP MASTER
-      if (firstcall) then
-!      
-!      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(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))
-      endif
-!$OMP END MASTER      
-!$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
-      if (pressure_exner) then
-      CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
-      else 
-        CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
-      endif
-c-----------------------------------------------------------------------
-c   Debut de l'integration temporelle:
-c   ----------------------------------
-c et du parallelisme !!
-
-   1  CONTINUE ! Matsuno Forward step begins here
-
-c   date: (NB: date remains unchanged for Backward step)
-c   -----
-
-      jD_cur = jD_ref + day_ini - day_ref +                             &
-     &          (itau+1)/day_step
-      jH_cur = jH_ref + start_time +                                    &
-     &         mod(itau+1,day_step)/float(day_step) 
-      if (jH_cur > 1.0 ) then
-        jD_cur = jD_cur +1.
-        jH_cur = jH_cur -1.
-      endif
-
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
-
-#ifdef CPP_IOIPSL
-      if (ok_guide) then
-        call guide_main(itau,ucov,vcov,teta,q,masse,ps)
-!$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
-         
-! Ehouarn: finvmaold is actually not used       
-!         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  
-
-
-! Ehouarn: finvmaold not used
-!          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)
-
-
-         call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
-
-   2  CONTINUE ! Matsuno backward or leapfrog step begins here
-
-
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
-
-c$OMP MASTER
-      ItCount=ItCount+1
-      if (MOD(ItCount,1)==1) then
-        debug=.true.
-      else
-        debug=.false.
-      endif
-c$OMP END MASTER
-c-----------------------------------------------------------------------
-
-c   date: (NB: only leapfrog step requires recomputing date)
-c   -----
-
-      IF (leapf) THEN
-        jD_cur = jD_ref + day_ini - day_ref +
-     &          (itau+1)/day_step
-        jH_cur = jH_ref + start_time +
-     &         mod(itau+1,day_step)/float(day_step) 
-        if (jH_cur > 1.0 ) then
-          jD_cur = jD_cur +1.
-          jH_cur = jH_cur -1.
-        endif
-      ENDIF
-
-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
-      ! Purely Matsuno time stepping
-         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
-         IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) 
-     s        apdiss = .TRUE.
-         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward 
-     s          .and. physic                        ) apphys = .TRUE.
-      ELSE
-      ! Leapfrog/Matsuno time stepping 
-         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
-         IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward )
-     s        apdiss = .TRUE.
-         IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
-      END IF
-
-! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
-!          supress dissipation step
-      if (llm.eq.1) then
-        apdiss=.false.
-      endif
-
-cym    ---> Pour le moment      
-cym      apphys = .FALSE.
-      statcl = .FALSE.
-!     conser = .FALSE. ! ie: no output of control variables to stdout in //
-      
-      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.
-      ENDIF      
-c$OMP END MASTER      
-
-
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
-
-!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
-
-        if (prt_level > 9) 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       
-     
-      
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
-      
-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 iq=1,nqtot
-          call WriteField_u('q'//trim(int2str(iq)),
-     .                q(:,:,iq))
-        enddo
-      endif
-
-      
-      True_itau=True_itau+1
-
-c$OMP MASTER
-      IF (prt_level>9) THEN
-        WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
-      ENDIF
-
-
-      call start_timer(timer_caldyn)
-
-      ! compute geopotential phi()
-      CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
-        
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
-      
-      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
-      if (mpi_rank==0.AND.conser) THEN
-         WRITE(lunout,*) 'leapfrog_loc, Time step: ',itau,' Day:',time
-      ENDIF
-      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   -------------------------------------------------------------
-
-      call check_isotopes(q,ijb_u,ije_u,
-     &           'leapfrog 686: avant caladvtrac')
-      
-      IF( forward. OR . leapf )  THEN
-! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
-        !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
-         CALL caladvtrac_loc(q,pbaru,pbarv,
-     *        p, masse, dq,  teta,
-     .        flxw,pk, iapptrac)
-
-! call creation of mass flux 
-         IF (offline .AND. .NOT. adjust) THEN
-            CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi)
-         ENDIF
-
-         !write(*,*) 'leapfrog 719'
-         call check_isotopes(q,ijb_u,ije_u,
-     &           'leapfrog 698: apres caladvtrac')
-
-!      do j=1,nqtot
-!        call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
-!      enddo
-
-! Ehouarn: Storage of mass flux for off-line tracers... not implemented...
-
-      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")
-
-       !write(*,*) 'leapfrog 720' 
-       call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
-
-       ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot?? 
-       CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
-     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
-!     $              finvmaold                                    )
-
-       !write(*,*) 'leapfrog 724'       
-       call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
- 
-!       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    
-
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
-
-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,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,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,
-!      $               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 )
-
-       call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
-        !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
-
-      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
-c$OMP MASTER
-         if (FirstPhysic) then
-           ok_start_timer=.TRUE.
-           FirstPhysic=.false.
-         endif
-c$OMP END MASTER
-
-
-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
-!LF       teta(ijb:ije,:)=teta(ijb:ije,:)
-!LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-       do l=1,llm
-       teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr*
-     &        (teta(ijb:ije,l)-tetarappel(ijb:ije,l))*
-     &                 (knewt_g+knewt_t(l)*clat4(ijb:ije))        
-       enddo
-!$OMP END DO
-
-!$OMP MASTER
-       if (planet_type.eq."giant") then
-         ! add an intrinsic heat flux at the base of the atmosphere
-         teta(ijb:ije,1) = teta(ijb:ije,1)
-     &        + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
-       endif
-!$OMP END MASTER
-!$OMP BARRIER
-
-
-       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)     
-c$OMP BARRIER
-       call friction_loc(ucov,vcov,dtvr)
-!$OMP BARRIER
-
-        ! Sponge layer (if any)
-        IF (ok_strato) THEN
-          CALL top_bound_loc(vcov,ucov,teta,masse,dtvr)
-!$OMP BARRIER
-        ENDIF ! of IF (ok_strato) 
-      ENDIF ! of IF(iflag_phys.EQ.2)
-
-
-        CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
-c$OMP BARRIER
-        if (pressure_exner) then
-        CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
-        else 
-          CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
-        endif
-c$OMP BARRIER
-        CALL massdair_loc(p,masse)
-c$OMP BARRIER
-
-cc$OMP END PARALLEL
-        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
-
-c-----------------------------------------------------------------------
-c   dissipation horizontale et verticale  des petites echelles:
-c   ----------------------------------------------------------
-      !write(*,*) 'leapfrog 1163: apdiss=',apdiss
-      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 ! of IF(apdiss)
-
-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
-
-       call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
- 
-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
-         call barrier
-         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  
-         CALL barrier
-         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
-c$OMP END MASTER
-
-         if (ok_guide) then
-           ! set ok_guide to false to avoid extra output
-           ! in following forward step
-           ok_guide=.false.
-         endif
-
-#ifdef INCA
-         IF (ANY(type_trac == ['inca','inco'])) THEN
-            CALL finalize_inca
-!     switching back to LMDZDYN context
-!$OMP MASTER
-            IF (ok_dyn_xios) THEN
-               CALL xios_set_current_context(dyn3d_ctx_handle)
-            ENDIF
-!$OMP END MASTER
-         ENDIF
-#endif
-#ifdef REPROBUS
-         if (type_trac == 'repr') CALL finalize_reprobus
-#endif
-
-c$OMP MASTER
-         call finalize_parallel
-c$OMP END MASTER
-c$OMP BARRIER
-         RETURN
-      ENDIF
-      
-      call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
-
-      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
-c$OMP END MASTER
-
-#ifdef INCA
-              IF (ANY(type_trac == ['inca','inco'])) THEN
-                 CALL finalize_inca
-!     switching back to LMDZDYN context
-!$OMP MASTER
-                 IF (ok_dyn_xios) THEN
-                    CALL xios_set_current_context(dyn3d_ctx_handle)
-                 ENDIF
-!$OMP END MASTER
-              ENDIF
-#endif
-#ifdef REPROBUS
-              if (type_trac == 'repr') CALL finalize_reprobus
-#endif
-
-c$OMP MASTER
-              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
-
-              ! Ehouarn: re-compute geopotential for outputs
-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_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
-
-            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
-
-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,pk,phi,q,
-     &                              masse,ps,phis)
-             endif
-#endif
-             
-              IF (ok_dyn_xios) THEN
-c$OMP MASTER
-                 CALL xios_update_calendar(itau)
-c$OMP END MASTER
-c$OMP BARRIER
-                 CALL writedyn_xios(vcov,
-     &                 ucov,teta,pk,phi,q,masse,ps,phis)
-              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")
-                if (ok_guide) then
-                  ! set ok_guide to false to avoid extra output
-                  ! in following forward step
-                  ok_guide=.false.
-                endif
-
-!              CLOSE(99)
-            ENDIF ! of IF (itau.EQ.itaufin)
-
-            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
-
-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)
-
-
-        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
-
-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
-c$OMP END MASTER
-
-#ifdef INCA
-                 IF (ANY(type_trac == ['inca','inco'])) THEN
-                    CALL finalize_inca
-!     switching back to LMDZDYN context
-!$OMP MASTER
-                    IF (ok_dyn_xios) THEN
-                       CALL xios_set_current_context(dyn3d_ctx_handle)
-                    ENDIF
-!$OMP END MASTER
-                 ENDIF
-
-#endif
-#ifdef REPROBUS
-                 if (type_trac == 'repr') CALL finalize_reprobus
-#endif
-
-c$OMP MASTER
-                 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
-
-              
-              call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
-
-              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
-              ! Ehouarn: re-compute geopotential for outputs
-c$OMP BARRIER
-c$OMP MASTER
-              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
-c$OMP END MASTER
-c$OMP BARRIER
-               
-               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_loc(itau,vcov,ucov,teta,pk,phi,q,
-     &                              masse,ps,phis)
-              endif ! of if (ok_dyn_ins)
-#endif
-
-              IF (ok_dyn_xios) THEN
-c$OMP MASTER
-                 CALL xios_update_calendar(itau)
-c$OMP END MASTER
-c$OMP BARRIER
-                 CALL writedyn_xios(vcov,
-     &                 ucov,teta,pk,phi,q,masse,ps,phis)
-              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")
-                if (ok_guide) then
-                  ! set ok_guide to false to avoid extra output
-                  ! in following forward step
-                  ok_guide=.false.
-                endif
-
-              ENDIF ! of IF(itau.EQ.itaufin)
-
-              forward = .TRUE.
-              GO TO  1
-
-            ENDIF ! of IF (forward)
-
-
-            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
-
-      END IF ! of IF(.not.purmats)
-c$OMP MASTER
-      call fin_getparam
-c$OMP END MASTER
-
-#ifdef INCA
-      IF (ANY(type_trac == ['inca','inco'])) THEN
-         CALL finalize_inca
-!     switching back to LMDZDYN context
-!$OMP MASTER
-         IF (ok_dyn_xios) THEN
-            CALL xios_set_current_context(dyn3d_ctx_handle)
-         ENDIF
-!$OMP END MASTER
-      ENDIF
-
-#endif
-#ifdef REPROBUS
-      if (type_trac == 'repr') CALL finalize_reprobus
-#endif
-
-c$OMP MASTER
-      call finalize_parallel
-c$OMP END MASTER
-      abort_message = 'Simulation finished'
-      call abort_gcm(modname,abort_message,0)
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F90	(revision 5246)
@@ -0,0 +1,1887 @@
+!
+! $Id$
+!
+!
+!
+#define DEBUG_IO
+#undef DEBUG_IO
+
+
+SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0, &
+        masse0,phis0,q0,time_0)
+
+   USE misc_mod
+   USE parallel_lmdz
+   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_mod
+   USE call_dissip_mod, ONLY : call_dissip
+   USE call_calfis_mod, ONLY : call_calfis
+   USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq &
+         ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw &
+         ,pbaru,pbarv,du,dv,dteta,phi,dp,w &
+         ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip
+
+   use exner_hyb_loc_m, only: exner_hyb_loc
+   use exner_milieu_loc_m, only: exner_milieu_loc
+   USE comconst_mod, ONLY: cpp, dtvr, ihf
+   USE comvert_mod, ONLY: ap, bp, pressure_exner
+   USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys, &
+         statcl,conser,apdiss,purmats,ok_strato
+   USE temps_mod, ONLY: itaufin,jD_ref,jH_ref,day_ini, &
+         day_ref,start_time,dt
+   USE mod_xios_dyn3dmem, ONLY : dyn3d_ctx_handle
+   USE lmdz_xios, ONLY: xios_update_calendar, &
+         xios_set_current_context, &
+         using_xios
+
+  IMPLICIT NONE
+
+   ! ......   Version  du 10/01/98    ..........
+
+   !        avec  coordonnees  verticales hybrides
+  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   GCM LMD nouvelle grille
+  !
+  !=======================================================================
+  !
+  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+  !  et possibilite d'appeler une fonction f(y)  a derivee tangente
+  !  hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+  !  ... Possibilite de choisir le shema pour l'advection de
+  !    q  , en modifiant iadv dans traceur.def  (10/02) .
+  !
+  !  Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+  !  Pour Van-Leer iadv=10
+  !
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissnew.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  include "academic.h"
+
+  REAL,INTENT(IN) :: time_0 ! not used
+
+  !   dynamical variables:
+  REAL,INTENT(IN) :: ucov0(ijb_u:ije_u,llm)    ! zonal covariant wind
+  REAL,INTENT(IN) :: vcov0(ijb_v:ije_v,llm)    ! meridional covariant wind
+  REAL,INTENT(IN) :: teta0(ijb_u:ije_u,llm)    ! potential temperature
+  REAL,INTENT(IN) :: q0(ijb_u:ije_u,llm,nqtot) ! advected tracers
+  REAL,INTENT(IN) :: ps0(ijb_u:ije_u)          ! surface pressure (Pa)
+  REAL,INTENT(IN) :: masse0(ijb_u:ije_u,llm)   ! air mass
+  REAL,INTENT(IN) :: phis0(ijb_u:ije_u)        ! geopotentiat at the surface
+
+  real :: zqmin,zqmax
+
+   ! 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
+
+  ! variables dynamiques intermediaire pour le transport
+   ! REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
+
+  !   variables dynamiques au pas -1
+   ! REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
+  !      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
+   ! REAL,SAVE,ALLOCATABLE :: massem1(:,:)
+
+  !   tendances dynamiques
+   ! REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
+   ! REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
+   ! REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
+
+  !   tendances de la dissipation
+   ! REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
+   ! REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
+
+  !   tendances physiques
+  REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
+  REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
+  REAL,SAVE,ALLOCATABLE :: dpfi(:)
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
+
+  !   variables pour le fichier histoire
+  REAL :: dtav      ! intervalle de temps elementaire
+
+  REAL :: tppn(iim),tpps(iim),tpn,tps
+  !
+  INTEGER :: itau,itaufinp1,iav
+   ! INTEGER  iday ! jour julien
+  REAL :: time
+
+  REAL :: SSUM
+   ! REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
+
+  !ym      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 :: physic
+  LOGICAL :: first,callinigrads
+
+  data callinigrads/.true./
+  character(len=10) :: string10
+
+   ! REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
+
+  !+jld variables test conservation energie
+   ! REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
+  ! Tendance de la temp. potentiel d (theta)/ d t due a la
+  ! tansformation d'energie cinetique en energie thermique
+  ! 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(len=15) :: ztit
+  !!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+   ! SAVE      ip_ebil_dyn
+   ! DATA      ip_ebil_dyn/0/
+  !-jld
+
+  character(len=80) :: dynhist_file, dynhistave_file
+  character(len=*),parameter :: modname="leapfrog_loc"
+  character(len=80) :: abort_message
+
+
+  logical,PARAMETER :: dissip_conservative=.TRUE.
+
+  INTEGER :: testita
+  PARAMETER (testita = 9)
+
+  logical , parameter :: flag_verif = .false.
+
+  ! 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
+  INTEGER :: iapptrac
+  INTEGER :: AdjustCount
+   ! INTEGER :: var_time
+  LOGICAL :: ok_start_timer=.FALSE.
+  LOGICAL, SAVE :: firstcall=.TRUE.
+  TYPE(distrib),SAVE :: new_dist
+
+  call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
+
+!$OMP MASTER
+  ItCount=0
+!$OMP END MASTER
+  true_itau=0
+  FirstCaldyn=.TRUE.
+  FirstPhysic=.TRUE.
+  iapptrac=0
+  AdjustCount = 0
+  lafin=.false.
+
+  if (nday>=0) then
+     itaufin   = nday*day_step
+  else
+     itaufin   = -nday
+  endif
+
+  itaufinp1 = itaufin +1
+
+  call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
+
+  itau = 0
+  physic=.true.
+  if (iflag_phys==0.or.iflag_phys==2) physic=.false.
+  CALL init_nan
+  CALL leapfrog_allocate
+  ucov=ucov0
+  vcov=vcov0
+  teta=teta0
+  ps=ps0
+  masse=masse0
+  phis=phis0
+  q=q0
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
+
+   ! 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
+
+  ! Allocate variables depending on dynamic variable nqtot
+!$OMP MASTER
+  if (firstcall) then
+  !
+  !  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(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))
+  endif
+!$OMP END MASTER
+!$OMP BARRIER
+
+             ! CALL dynredem1_loc("restart.nc",0.0,
+  ! &                           vcov,ucov,teta,q,masse,ps)
+
+
+  !-----------------------------------------------------------------------
+  !   On initialise la pression et la fonction d'Exner :
+  !   --------------------------------------------------
+
+!$OMP MASTER
+  dq(:,:,:)=0.
+  CALL pression ( ijnb_u, ap, bp, ps, p       )
+!$OMP END MASTER
+  if (pressure_exner) then
+  CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
+  else
+    CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+  endif
+  !-----------------------------------------------------------------------
+  !   Debut de l'integration temporelle:
+  !   ----------------------------------
+  ! et du parallelisme !!
+
+   1   CONTINUE ! Matsuno Forward step begins here
+
+  !   date: (NB: date remains unchanged for Backward step)
+  !   -----
+
+  jD_cur = jD_ref + day_ini - day_ref +                             &
+        (itau+1)/day_step
+  jH_cur = jH_ref + start_time +                                    &
+        mod(itau+1,day_step)/float(day_step)
+  if (jH_cur > 1.0 ) then
+    jD_cur = jD_cur +1.
+    jH_cur = jH_cur -1.
+  endif
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
+
+#ifdef CPP_IOIPSL
+  if (ok_guide) then
+    call guide_main(itau,ucov,vcov,teta,q,masse,ps)
+!$OMP BARRIER
+  endif
+#endif
+
+
+  !
+  ! IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+  !   CALL  test_period ( ucov,vcov,teta,q,p,phis )
+  !   PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+  ! ENDIF
+  !
+  !ym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+  !ym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+   if (FirstCaldyn) then
+!$OMP MASTER
+     ucovm1=ucov
+     vcovm1=vcov
+     tetam1= teta
+     massem1= masse
+     psm1= ps
+
+  ! Ehouarn: finvmaold is actually not used
+      ! finvmaold = masse
+!$OMP END MASTER
+!$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
+
+!$OMP MASTER
+     psm1     (ijb:ije) = ps    (ijb:ije)
+!$OMP END MASTER
+
+!$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
+!$OMP ENDDO
+
+
+  ! Ehouarn: finvmaold not used
+       ! 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
+
+  !   ...    P.Le Van .26/04/94  ....
+
+  !ym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+  !ym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+  !ym  ne sert a rien
+  !ym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+
+
+     call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
+
+   2   CONTINUE ! Matsuno backward or leapfrog step begins here
+
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
+
+!$OMP MASTER
+  ItCount=ItCount+1
+  if (MOD(ItCount,1)==1) then
+    debug=.true.
+  else
+    debug=.false.
+  endif
+!$OMP END MASTER
+  !-----------------------------------------------------------------------
+
+  !   date: (NB: only leapfrog step requires recomputing date)
+  !   -----
+
+  IF (leapf) THEN
+    jD_cur = jD_ref + day_ini - day_ref + &
+          (itau+1)/day_step
+    jH_cur = jH_ref + start_time + &
+          mod(itau+1,day_step)/float(day_step)
+    if (jH_cur > 1.0 ) then
+      jD_cur = jD_cur +1.
+      jH_cur = jH_cur -1.
+    endif
+  ENDIF
+
+  !   gestion des appels de la physique et des dissipations:
+  !   ------------------------------------------------------
+  !
+  !   ...    P.Le Van  ( 6/02/95 )  ....
+
+  apphys = .FALSE.
+  statcl = .FALSE.
+  conser = .FALSE.
+  apdiss = .FALSE.
+
+  IF( purmats ) THEN
+  ! ! Purely Matsuno time stepping
+     IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+     IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) &
+           apdiss = .TRUE.
+     IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward &
+           .and. physic                        ) apphys = .TRUE.
+  ELSE
+  ! ! Leapfrog/Matsuno time stepping
+     IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+     IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) &
+           apdiss = .TRUE.
+     IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
+  END IF
+
+  ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
+       ! supress dissipation step
+  if (llm.eq.1) then
+    apdiss=.false.
+  endif
+
+  !ym    ---> Pour le moment
+  !ym      apphys = .FALSE.
+  statcl = .FALSE.
+  ! conser = .FALSE. ! ie: no output of control variables to stdout in //
+
+  if (firstCaldyn) then
+!$OMP MASTER
+      call Set_Distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      firstCaldyn=.FALSE.
+  !ym          call InitTime
+!$OMP MASTER
+      call Init_timer
+!$OMP END MASTER
+  endif
+
+!$OMP MASTER
+  IF (ok_start_timer) THEN
+    CALL InitTime
+    ok_start_timer=.FALSE.
+  ENDIF
+!$OMP END MASTER
+
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
+
+  !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
+!$OMP MASTER
+       call allgather_timer_average
+
+    if (prt_level > 9) 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
+
+!$OMP MASTER
+    if (mpi_rank==0) call WriteBands
+!$OMP END MASTER
+
+
+  endif
+  endif
+
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
+
+  !-----------------------------------------------------------------------
+  !   calcul des tendances dynamiques:
+  !   --------------------------------
+!$OMP BARRIER
+!$OMP MASTER
+   call VTb(VThallo)
+!$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)
+
+    ! do j=1,nqtot
+    !   call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
+  ! *                       TestRequest)
+  !    enddo
+
+   call SendRequest(TestRequest)
+!$OMP BARRIER
+   call WaitRequest(TestRequest)
+
+!$OMP MASTER
+   call VTe(VThallo)
+!$OMP END MASTER
+!$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 iq=1,nqtot
+      call WriteField_u('q'//trim(int2str(iq)), &
+            q(:,:,iq))
+    enddo
+  endif
+
+
+  True_itau=True_itau+1
+
+!$OMP MASTER
+  IF (prt_level>9) THEN
+    WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
+  ENDIF
+
+
+  call start_timer(timer_caldyn)
+
+  ! ! compute geopotential phi()
+  CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
+
+  call VTb(VTcaldyn)
+!$OMP END MASTER
+   ! var_time=time+iday-day_ini
+
+!$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")
+
+!$OMP MASTER
+  if (mpi_rank==0.AND.conser) THEN
+     WRITE(lunout,*) 'leapfrog_loc, Time step: ',itau,' Day:',time
+  ENDIF
+  call VTe(VTcaldyn)
+!$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
+  !-----------------------------------------------------------------------
+  !   calcul des tendances advection des traceurs (dont l'humidite)
+  !   -------------------------------------------------------------
+
+  call check_isotopes(q,ijb_u,ije_u, &
+        'leapfrog 686: avant caladvtrac')
+
+  IF( forward.OR. leapf )  THEN
+  ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
+    ! !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
+     CALL caladvtrac_loc(q,pbaru,pbarv, &
+           p, masse, dq,  teta, &
+           flxw,pk, iapptrac)
+
+  ! call creation of mass flux
+     IF (offline .AND. .NOT. adjust) THEN
+        CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi)
+     ENDIF
+
+     ! !write(*,*) 'leapfrog 719'
+     call check_isotopes(q,ijb_u,ije_u, &
+           'leapfrog 698: apres caladvtrac')
+
+   ! do j=1,nqtot
+   !   call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
+   ! enddo
+
+  ! Ehouarn: Storage of mass flux for off-line tracers... not implemented...
+
+  ENDIF ! of IF( forward.OR. leapf )
+
+
+  !-----------------------------------------------------------------------
+  !   integrations dynamique et traceurs:
+  !   ----------------------------------
+
+!$OMP MASTER
+   call VTb(VTintegre)
+!$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
+!$OMP BARRIER
+    ! CALL FTRACE_REGION_BEGIN("integrd")
+
+   ! !write(*,*) 'leapfrog 720'
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
+
+   ! ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
+   CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 , &
+         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
+  ! $              finvmaold                                    )
+
+  !  !write(*,*) 'leapfrog 724'
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
+
+    ! CALL FTRACE_REGION_END("integrd")
+!$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
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
+
+   ! do j=1,nqtot
+   !   call WriteField_p('q'//trim(int2str(j)),
+  ! .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+  !    call WriteField_p('dq'//trim(int2str(j)),
+  ! .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
+  !  enddo
+
+
+!$OMP MASTER
+   call VTe(VTintegre)
+!$OMP END MASTER
+  ! .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+  !
+  !-----------------------------------------------------------------------
+  !   calcul des tendances physiques:
+  !   -------------------------------
+  !    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+  !
+   IF( purmats )  THEN
+      IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+   ELSE
+      IF( itau+1.EQ. itaufin )              lafin = .TRUE.
+   ENDIF
+
+  !c$OMP END PARALLEL
+
+  !
+  !
+   IF( apphys )  THEN
+
+     CALL call_calfis(itau,lafin,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,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,
+  !  $               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
+!$OMP MASTER
+     if (FirstPhysic) then
+       ok_start_timer=.TRUE.
+       FirstPhysic=.false.
+     endif
+!$OMP END MASTER
+   ENDIF ! of IF( apphys )
+
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
+    ! !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
+
+  IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+!$OMP MASTER
+     if (FirstPhysic) then
+       ok_start_timer=.TRUE.
+       FirstPhysic=.false.
+     endif
+!$OMP END MASTER
+
+
+  !   Calcul academique de la physique = Rappel Newtonien + fritcion
+  !   --------------------------------------------------------------
+  !ym       teta(:,:)=teta(:,:)
+  !ym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+   ijb=ij_begin
+   ije=ij_end
+  !LF       teta(ijb:ije,:)=teta(ijb:ije,:)
+  !LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+   teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr* &
+         (teta(ijb:ije,l)-tetarappel(ijb:ije,l))* &
+         (knewt_g+knewt_t(l)*clat4(ijb:ije))
+   enddo
+!$OMP END DO
+
+!$OMP MASTER
+   if (planet_type.eq."giant") then
+     ! ! add an intrinsic heat flux at the base of the atmosphere
+     teta(ijb:ije,1) = teta(ijb:ije,1) &
+           + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
+   endif
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+   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)
+!$OMP BARRIER
+   call WaitRequest(Request_Physic)
+!$OMP BARRIER
+   call friction_loc(ucov,vcov,dtvr)
+!$OMP BARRIER
+
+    ! ! Sponge layer (if any)
+    IF (ok_strato) THEN
+      CALL top_bound_loc(vcov,ucov,teta,masse,dtvr)
+!$OMP BARRIER
+    ENDIF ! of IF (ok_strato)
+  ENDIF ! of IF(iflag_phys.EQ.2)
+
+
+    CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
+!$OMP BARRIER
+    if (pressure_exner) then
+    CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
+    else
+      CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+    endif
+!$OMP BARRIER
+    CALL massdair_loc(p,masse)
+!$OMP BARRIER
+
+  !c$OMP END PARALLEL
+    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
+
+  !-----------------------------------------------------------------------
+  !   dissipation horizontale et verticale  des petites echelles:
+  !   ----------------------------------------------------------
+  ! !write(*,*) 'leapfrog 1163: apdiss=',apdiss
+  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 ! of IF(apdiss)
+
+  !c$OMP END PARALLEL
+
+  ! ajout debug
+           ! IF( lafin ) then
+           !   abort_message = 'Simulation finished'
+           !   call abort_gcm(modname,abort_message,0)
+           ! ENDIF
+
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
+
+  !   ********************************************************************
+  !   ********************************************************************
+  !   .... fin de l'integration dynamique  et physique pour le pas itau ..
+  !   ********************************************************************
+  !   ********************************************************************
+
+  !   preparation du pas d'integration suivant  ......
+  !ym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+  !ym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+!$OMP MASTER
+  call stop_timer(timer_caldyn)
+!$OMP END MASTER
+  IF (itau==itaumax) then
+!$OMP MASTER
+     call allgather_timer_average
+     call barrier
+     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
+     CALL barrier
+     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
+!$OMP END MASTER
+     CALL dynredem1_loc("restart.nc",0.0, &
+           vcov,ucov,teta,q,masse,ps)
+!$OMP MASTER
+     call fin_getparam
+!$OMP END MASTER
+
+     if (ok_guide) then
+       ! ! set ok_guide to false to avoid extra output
+       ! ! in following forward step
+       ok_guide=.false.
+     endif
+
+#ifdef INCA
+     IF (ANY(type_trac == ['inca','inco'])) THEN
+        CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+        IF (ok_dyn_xios) THEN
+           CALL xios_set_current_context(dyn3d_ctx_handle)
+        ENDIF
+!$OMP END MASTER
+     ENDIF
+#endif
+#ifdef REPROBUS
+     if (type_trac == 'repr') CALL finalize_reprobus
+#endif
+
+!$OMP MASTER
+     call finalize_parallel
+!$OMP END MASTER
+!$OMP BARRIER
+     RETURN
+  ENDIF
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
+
+  IF ( .NOT.purmats ) THEN
+    ! ........................................................
+    ! ..............  schema matsuno + leapfrog  ..............
+    ! ........................................................
+
+        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
+
+
+!$OMP MASTER
+          call fin_getparam
+!$OMP END MASTER
+
+#ifdef INCA
+          IF (ANY(type_trac == ['inca','inco'])) THEN
+             CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+             IF (ok_dyn_xios) THEN
+                CALL xios_set_current_context(dyn3d_ctx_handle)
+             ENDIF
+!$OMP END MASTER
+          ENDIF
+#endif
+#ifdef REPROBUS
+          if (type_trac == 'repr') CALL finalize_reprobus
+#endif
+
+!$OMP MASTER
+          call finalize_parallel
+!$OMP END MASTER
+          abort_message = 'Simulation finished'
+          call abort_gcm(modname,abort_message,0)
+          RETURN
+        ENDIF
+  !-----------------------------------------------------------------------
+  !   ecriture du fichier histoire moyenne:
+  !   -------------------------------------
+
+        IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+!$OMP BARRIER
+           IF(itau.EQ.itaufin) THEN
+              iav=1
+           ELSE
+              iav=0
+           ENDIF
+
+          ! ! Ehouarn: re-compute geopotential for outputs
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+#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
+
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
+
+  !-----------------------------------------------------------------------
+  !   ecriture de la bande histoire:
+  !   ------------------------------
+
+        IF( MOD(itau,iecri).EQ.0) THEN
+         ! ! Ehouarn: output only during LF or Backward Matsuno
+         if (leapf.or.(.not.leapf.and.(.not.forward))) then
+
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+#ifdef CPP_IOIPSL
+         if (ok_dyn_ins) then
+             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
+                   masse,ps,phis)
+         endif
+#endif
+
+          IF (ok_dyn_xios) THEN
+!$OMP MASTER
+             CALL xios_update_calendar(itau)
+!$OMP END MASTER
+!$OMP BARRIER
+             CALL writedyn_xios(vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+
+      endif                 ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
+
+
+       ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+
+        IF(itau.EQ.itaufin) THEN
+
+!$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")
+            if (ok_guide) then
+              ! ! set ok_guide to false to avoid extra output
+              ! ! in following forward step
+              ok_guide=.false.
+            endif
+
+           ! CLOSE(99)
+        ENDIF ! of IF (itau.EQ.itaufin)
+
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
+
+  !-----------------------------------------------------------------------
+  !   gestion de l'integration temporelle:
+  !   ------------------------------------
+
+        IF( MOD(itau,iperiod).EQ.0 )    THEN
+                GO TO 1
+        ELSE IF ( MOD(itau-1,iperiod).EQ. 0 ) THEN
+
+               IF( forward )  THEN
+   ! fin du pas forward et debut du pas backward
+
+                  forward = .FALSE.
+                    leapf = .FALSE.
+                       GO TO 2
+
+               ELSE
+   ! fin du pas backward et debut du premier pas leapfrog
+
+                    leapf =  .TRUE.
+                    dt  =  2.*dtvr
+                    GO TO 2
+               END IF
+        ELSE
+
+   ! ......   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)
+
+
+    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
+
+    ! ........................................................
+    ! ..............       schema  matsuno        ...............
+    ! ........................................................
+        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
+!$OMP MASTER
+             call fin_getparam
+!$OMP END MASTER
+
+#ifdef INCA
+             IF (ANY(type_trac == ['inca','inco'])) THEN
+                CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+                IF (ok_dyn_xios) THEN
+                   CALL xios_set_current_context(dyn3d_ctx_handle)
+                ENDIF
+!$OMP END MASTER
+             ENDIF
+
+#endif
+#ifdef REPROBUS
+             if (type_trac == 'repr') CALL finalize_reprobus
+#endif
+
+!$OMP MASTER
+             call finalize_parallel
+!$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
+
+
+          call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
+
+          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
+          ! ! Ehouarn: re-compute geopotential for outputs
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+           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
+
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+#ifdef CPP_IOIPSL
+          if (ok_dyn_ins) then
+             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
+                   masse,ps,phis)
+          endif ! of if (ok_dyn_ins)
+#endif
+
+          IF (ok_dyn_xios) THEN
+!$OMP MASTER
+             CALL xios_update_calendar(itau)
+!$OMP END MASTER
+!$OMP BARRIER
+             CALL writedyn_xios(vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          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")
+            if (ok_guide) then
+              ! ! set ok_guide to false to avoid extra output
+              ! ! in following forward step
+              ok_guide=.false.
+            endif
+
+          ENDIF ! of IF(itau.EQ.itaufin)
+
+          forward = .TRUE.
+          GO TO  1
+
+        ENDIF ! of IF (forward)
+
+
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
+
+  END IF ! of IF(.not.purmats)
+!$OMP MASTER
+  call fin_getparam
+!$OMP END MASTER
+
+#ifdef INCA
+  IF (ANY(type_trac == ['inca','inco'])) THEN
+     CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+     IF (ok_dyn_xios) THEN
+        CALL xios_set_current_context(dyn3d_ctx_handle)
+     ENDIF
+!$OMP END MASTER
+  ENDIF
+
+#endif
+#ifdef REPROBUS
+  if (type_trac == 'repr') CALL finalize_reprobus
+#endif
+
+!$OMP MASTER
+  call finalize_parallel
+!$OMP END MASTER
+  abort_message = 'Simulation finished'
+  call abort_gcm(modname,abort_message,0)
+  RETURN
+END SUBROUTINE leapfrog_loc
Index: LMDZ6/trunk/libf/dyn3dmem/massdair_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/massdair_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,119 +1,0 @@
-      SUBROUTINE massdair_loc( p, masse )
-      USE parallel_lmdz
-c
-c *********************************************************************
-c       ....  Calcule la masse d'air  dans chaque maille   ....
-c *********************************************************************
-c
-c    Auteurs : P. Le Van , Fr. Hourdin  .
-c   ..........
-c
-c  ..    p                      est  un argum. d'entree pour le s-pg ...
-c  ..  masse                    est un  argum.de sortie pour le s-pg ...
-c     
-c  ....  p est defini aux interfaces des llm couches   .....
-c
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c  .....   arguments  ....
-c
-      REAL p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm)
-
-c   ....  Variables locales  .....
-
-      INTEGER l,ij
-      INTEGER ijb,ije
-      REAL massemoyn, massemoys
-
-      REAL SSUM
-      EXTERNAL SSUM
-c
-c
-c   Methode pour calculer massebx et masseby .
-c   ----------------------------------------
-c
-c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
-c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
-c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
-c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
-c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
-c
-c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
-c
-c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
-c
-c
-c
-c   alpha4 .         . alpha1    . alpha4
-c    (i,j)             (i,j)       (i+1,j)
-c
-c             P .        U .          . P
-c           (i,j)       (i,j)         (i+1,j)
-c
-c   alpha3 .         . alpha2    .alpha3 
-c    (i,j)              (i,j)     (i+1,j)
-c
-c             V .        Z .          . V
-c           (i,j)
-c
-c   alpha4 .         . alpha1    .alpha4
-c   (i,j+1)            (i,j+1)   (i+1,j+1) 
-c
-c             P .        U .          . P
-c          (i,j+1)                    (i+1,j+1)
-c
-c
-c
-c                       On  a :
-c
-c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
-c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-c     localise  au point  ... U (i,j) ...
-c
-c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
-c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-c     localise  au point  ... V (i,j) ...
-c
-c
-c=======================================================================
-
-      
-
-      
-      ijb=ij_begin-iip1
-      ije=ij_end+2*iip1
-      
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO   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: LMDZ6/trunk/libf/dyn3dmem/massdair_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/massdair_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/massdair_loc.f90	(revision 5246)
@@ -0,0 +1,119 @@
+SUBROUTINE massdair_loc( p, masse )
+  USE parallel_lmdz
+  !
+  ! *********************************************************************
+  !   ....  Calcule la masse d'air  dans chaque maille   ....
+  ! *********************************************************************
+  !
+  !    Auteurs : P. Le Van , Fr. Hourdin  .
+  !   ..........
+  !
+  !  ..    p                      est  un argum. d'entree pour le s-pg ...
+  !  ..  masse                    est un  argum.de sortie pour le s-pg ...
+  !
+  !  ....  p est defini aux interfaces des llm couches   .....
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !  .....   arguments  ....
+  !
+  REAL :: p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm)
+
+  !   ....  Variables locales  .....
+
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  REAL :: massemoyn, massemoys
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  !
+  !   Methode pour calculer massebx et masseby .
+  !   ----------------------------------------
+  !
+  !    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+  !   alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+  !   alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+  !   alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+  !   alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+  !
+  !    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+  !
+  !    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+  !
+  !
+  !
+  !   alpha4 .         . alpha1    . alpha4
+  !    (i,j)             (i,j)       (i+1,j)
+  !
+  !         P .        U .          . P
+  !       (i,j)       (i,j)         (i+1,j)
+  !
+  !   alpha3 .         . alpha2    .alpha3
+  !    (i,j)              (i,j)     (i+1,j)
+  !
+  !         V .        Z .          . V
+  !       (i,j)
+  !
+  !   alpha4 .         . alpha1    .alpha4
+  !   (i,j+1)            (i,j+1)   (i+1,j+1)
+  !
+  !         P .        U .          . P
+  !      (i,j+1)                    (i+1,j+1)
+  !
+  !
+  !
+  !                   On  a :
+  !
+  !    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+  !               masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+  ! localise  au point  ... U (i,j) ...
+  !
+  !    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+  !               masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
+  ! localise  au point  ... V (i,j) ...
+  !
+  !
+  !=======================================================================
+
+
+
+
+  ijb=ij_begin-iip1
+  ije=ij_end+2*iip1
+
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1 , llm
+  !
+    DO    ij     = ijb, ije
+     masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+    ENDDO
+  !
+    DO   ij = ijb, ije,iip1
+     masse(ij+ iim,l) = masse(ij,l)
+    ENDDO
+  !
+  !   DO    ij     = 1,  iim
+  !    masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+  !    masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm)
+  !   ENDDO
+  !    massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+  !    massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+  !   DO    ij     = 1, iip1
+  !    masse(   ij   ,l )    = massemoyn
+  !    masse(ij+ip1jm,l )    = massemoys
+  !   ENDDO
+
+  END DO
+!$OMP END DO NOWAIT
+  !
+  RETURN
+END SUBROUTINE massdair_loc
Index: LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F	(revision 5214)
+++ 	(revision )
@@ -1,443 +1,0 @@
-      MODULE mod_filtreg_p
-      
-      CONTAINS
-      
-      SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, 
-     &     ifiltre, iaire, griscal ,iter)
-      USE parallel_lmdz, only : OMP_CHUNK
-      USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft,
-     &                              filtre_v_fft, filtre_inv_fft
-      USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
-      
-      USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus,
-     &                       matricevn, matricevs
-      
-      IMPLICIT NONE
-      
-c=======================================================================
-c
-c   Auteur: P. Le Van        07/10/97
-c   ------
-c
-c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
-c                     pour l'operateur  Filtre    .
-c   ------
-c
-c   Arguments:
-c   ----------
-c
-c      
-c      ibeg..iend            lattitude a filtrer
-c      nlat                  nombre de latitudes du champ
-c      nbniv                 nombre de niveaux verticaux a filtrer
-c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
-c                            en sortie : champ filtre
-c      ifiltre               +1  Transformee directe
-c                            -1  Transformee inverse
-c                            +2  Filtre directe
-c                            -2  Filtre inverse
-c
-c      iaire                 1   si champ intensif
-c                            2   si champ extensif (pondere par les aires)
-c
-c      iter                  1   filtre simple
-c
-c=======================================================================
-c
-c
-c                      Variable Intensive
-c                ifiltre = 1     filtre directe
-c                ifiltre =-1     filtre inverse
-c
-c                      Variable Extensive
-c                ifiltre = 2     filtre directe
-c                ifiltre =-2     filtre inverse
-c
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "coefils.h"
-c
-      INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
-      INTEGER,INTENT(IN) :: iaire
-      LOGICAL,INTENT(IN) :: griscal
-      REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
-      
-      INTEGER i,j,l,k
-      INTEGER iim2,immjm
-      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
-      INTEGER    hemisph
-      REAL :: champ_fft(iip1,jjb:jje,nbniv)
-!      REAL :: champ_in(iip1,jjb:jje,nbniv)
-      
-      LOGICAL,SAVE     :: first=.TRUE.
-c$OMP THREADPRIVATE(first) 
-
-      REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
-      INTEGER :: ll_nb, nbniv_loc
-      REAL, SAVE :: sdd12(iim,4)
-c$OMP THREADPRIVATE(sdd12) 
-
-      INTEGER, PARAMETER :: type_sddu=1
-      INTEGER, PARAMETER :: type_sddv=2
-      INTEGER, PARAMETER :: type_unsddu=3
-      INTEGER, PARAMETER :: type_unsddv=4
-
-      INTEGER :: sdd1_type, sdd2_type
-      CHARACTER (LEN=132) :: abort_message
-
-      IF (first) THEN
-         sdd12(1:iim,type_sddu) = sddu(1:iim)
-         sdd12(1:iim,type_sddv) = sddv(1:iim)
-         sdd12(1:iim,type_unsddu) = unsddu(1:iim)
-         sdd12(1:iim,type_unsddv) = unsddv(1:iim)
-
-         CALL Init_timer
-         first=.FALSE.
-      ENDIF
-
-c$OMP MASTER      
-      CALL start_timer
-c$OMP END MASTER
-
-c-------------------------------------------------------c
-
-      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
-     &  CALL abort_gcm("mod_filtreg_p",'Pas de transformee 
-     &simple dans cette version',1)
-      
-      IF( iter.EQ. 2 )  THEN
-         PRINT *,' Pas d iteration du filtre dans cette version !'
-     &        , ' Utiliser old_filtreg et repasser !'
-         CALL abort_gcm("mod_filtreg_p","stopped",1)
-      ENDIF
-
-      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
-         PRINT *,' Cette routine ne calcule le filtre inverse que '
-     &        , ' sur la grille des scalaires !'
-         CALL abort_gcm("mod_filtreg_p","stopped",1)
-      ENDIF
-
-      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
-         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
-     &        , ' corriger et repasser !'
-         CALL abort_gcm("mod_filtreg_p","stopped",1)
-      ENDIF
-c
-
-      iim2   = iim * iim
-      immjm  = iim * jjm
-c
-c
-      IF( griscal )   THEN
-         IF( nlat. NE. jjp1 )  THEN
-            CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjp1",1)
-         ELSE
-c     
-            IF( iaire.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
-            CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjm",1)
-         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
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matrinvn(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matrinvn(1:iim,1:iim,j),
-     &                    champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE IF ( griscal )     THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matriceun(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matriceun(1:iim,1:iim,j),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE 
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matricevn(1,1,j), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matricevn(1:iim,1:iim,j),           
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ENDIF
-               
-            ELSE
-               
-               IF( ifiltre.EQ.-2 )   THEN
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matrinvs(1,1,j-jfiltsu+1), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE IF ( griscal )     THEN
-                  
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matriceus(1,1,j-jfiltsu+1), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matriceus(1:iim,1:iim,j-jfiltsu+1),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ELSE 
-                  
-                  DO j = jdfil,jffil
-#ifdef BLAS
-                     CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
-     &                    matricevs(1,1,j-jfiltsv+1), iim, 
-     &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, 
-     &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
-#else
-                     champ_fft(1:iim,j,1:nbniv_loc)=
-     &                    matmul(matricevs(1:iim,1:iim,j-jfiltsv+1),
-     &                           champ_loc(1:iim,j,1:nbniv_loc))
-#endif
-                  ENDDO
-                  
-               ENDIF
-               
-            ENDIF
-!     c     
-            IF( ifiltre.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,ll_nb))
-     &                       * sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT
-               
-            ELSE
-               
-               ll_nb = 0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-               DO l = 1, nbniv
-                  ll_nb = ll_nb + 1
-                  DO j = jdfil,jffil
-                     DO i = 1, iim
-                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
-     &                       - champ_fft(i,j,ll_nb))
-     &                       * sdd12(i,sdd2_type)
-                     ENDDO
-                  ENDDO
-               ENDDO
-c$OMP END DO NOWAIT
-               
-            ENDIF
-            
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l = 1, nbniv
-               DO j = jdfil,jffil
-                  ! add redundant longitude
-                  champ( iip1,j,l ) = champ( 1,j,l )
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-            
-ccccccccccccccccccccccccccccccccccccccccccccc
-c Utilisation du filtre FFT
-ccccccccccccccccccccccccccccccccccccccccccccc
-        
-         ELSE
-       
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l=1,nbniv
-               DO j=jdfil,jffil
-                  DO  i = 1, iim
-                     champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
-                     champ_fft( i,j,l) = champ(i,j,l)
-                  ENDDO
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT
-
-            IF (jdfil<=jffil) THEN
-               IF( ifiltre. 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 )
-                  ! add redundant longitude
-                  champ( iip1,j,l ) = champ( 1,j,l )
-               ENDDO
-            ENDDO
-c$OMP END DO NOWAIT          	
-         ENDIF 
-c Fin de la zone de filtrage
-
-	
-      ENDDO
-
-!      DO j=1,nlat
-!     
-!          PRINT *,"check FFT ----> Delta(",j,")=",
-!     &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
-!     &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) 
-!      ENDDO
-      
-!          PRINT *,"check FFT ----> Delta(",j,")=",
-!     &            sum(champ-champ_fft)/sum(champ)
-!      
-      
-c
- 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
-     &     filtrer, sur la grille des scalaires'/)
- 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
-     &     ltrer, sur la grille de V ou de Z'/)
-c$OMP MASTER      
-      CALL stop_timer
-c$OMP END MASTER
-      RETURN
-      END SUBROUTINE filtreg_p
-      END MODULE mod_filtreg_p
-
Index: LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F90	(revision 5246)
@@ -0,0 +1,443 @@
+MODULE mod_filtreg_p
+
+CONTAINS
+
+  SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, &
+          ifiltre, iaire, griscal ,iter)
+    USE parallel_lmdz, only : OMP_CHUNK
+    USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft, &
+          filtre_v_fft, filtre_inv_fft
+    USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
+
+    USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus, &
+          matricevn, matricevs
+
+    IMPLICIT NONE
+
+    !=======================================================================
+    !
+    !   Auteur: P. Le Van        07/10/97
+    !   ------
+    !
+    !   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+    !                 pour l'operateur  Filtre    .
+    !   ------
+    !
+    !   Arguments:
+    !   ----------
+    !
+    !
+    !  ibeg..iend            lattitude a filtrer
+    !  nlat                  nombre de latitudes du champ
+    !  nbniv                 nombre de niveaux verticaux a filtrer
+    !  champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+    !                        en sortie : champ filtre
+    !  ifiltre               +1  Transformee directe
+    !                        -1  Transformee inverse
+    !                        +2  Filtre directe
+    !                        -2  Filtre inverse
+    !
+    !  iaire                 1   si champ intensif
+    !                        2   si champ extensif (pondere par les aires)
+    !
+    !  iter                  1   filtre simple
+    !
+    !=======================================================================
+    !
+    !
+    !                  Variable Intensive
+    !            ifiltre = 1     filtre directe
+    !            ifiltre =-1     filtre inverse
+    !
+    !                  Variable Extensive
+    !            ifiltre = 2     filtre directe
+    !            ifiltre =-2     filtre inverse
+    !
+    !
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "coefils.h"
+    !
+    INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
+    INTEGER,INTENT(IN) :: iaire
+    LOGICAL,INTENT(IN) :: griscal
+    REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
+
+    INTEGER :: i,j,l,k
+    INTEGER :: iim2,immjm
+    INTEGER :: jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+    INTEGER :: hemisph
+    REAL :: champ_fft(iip1,jjb:jje,nbniv)
+     ! REAL :: champ_in(iip1,jjb:jje,nbniv)
+
+    LOGICAL,SAVE     :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+    REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
+    INTEGER :: ll_nb, nbniv_loc
+    REAL, SAVE :: sdd12(iim,4)
+!$OMP THREADPRIVATE(sdd12)
+
+    INTEGER, PARAMETER :: type_sddu=1
+    INTEGER, PARAMETER :: type_sddv=2
+    INTEGER, PARAMETER :: type_unsddu=3
+    INTEGER, PARAMETER :: type_unsddv=4
+
+    INTEGER :: sdd1_type, sdd2_type
+    CHARACTER (LEN=132) :: abort_message
+
+    IF (first) THEN
+       sdd12(1:iim,type_sddu) = sddu(1:iim)
+       sdd12(1:iim,type_sddv) = sddv(1:iim)
+       sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+       sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+
+       CALL Init_timer
+       first=.FALSE.
+    ENDIF
+
+!$OMP MASTER
+    CALL start_timer
+!$OMP END MASTER
+
+    !-------------------------------------------------------c
+
+    IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) &
+          CALL abort_gcm("mod_filtreg_p",'Pas de transformee&
+          &simple dans cette version',1)
+
+    IF( iter.EQ. 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'&
+             &        , ' Utiliser old_filtreg et repasser !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+
+    IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ' &
+             , ' sur la grille des scalaires !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+
+    IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
+             , ' corriger et repasser !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+    !
+
+    iim2   = iim * iim
+    immjm  = iim * jjm
+    !
+    !
+    IF( griscal )   THEN
+       IF( nlat.NE. jjp1 )  THEN
+          CALL abort_gcm("mod_filtreg_p"," nlat.NE. jjp1",1)
+       ELSE
+    !
+          IF( iaire.EQ.1 )  THEN
+             sdd1_type = type_sddv
+             sdd2_type = type_unsddv
+          ELSE
+             sdd1_type = type_unsddv
+             sdd2_type = type_sddv
+          ENDIF
+    !
+          jdfil1 = 2
+          jffil1 = jfiltnu
+          jdfil2 = jfiltsu
+          jffil2 = jjm
+       ENDIF
+    ELSE
+       IF( nlat.NE.jjm )  THEN
+          CALL abort_gcm("mod_filtreg_p"," nlat.NE. jjm",1)
+       ELSE
+    !
+          IF( iaire.EQ.1 )  THEN
+             sdd1_type = type_sddu
+             sdd2_type = type_unsddu
+          ELSE
+             sdd1_type = type_unsddu
+             sdd2_type = type_sddu
+          ENDIF
+    !
+          jdfil1 = 1
+          jffil1 = jfiltnv
+          jdfil2 = jfiltsv
+          jffil2 = jjm
+       ENDIF
+    ENDIF
+    !
+    DO hemisph = 1, 2
+    !
+       IF ( hemisph.EQ.1 )  THEN
+    !ym
+          jdfil = max(jdfil1,ibeg)
+          jffil = min(jffil1,iend)
+       ELSE
+    !ym
+          jdfil = max(jdfil2,ibeg)
+          jffil = min(jffil2,iend)
+       ENDIF
+
+
+    !ccccccccccccccccccccccccccccccccccccccccccc
+    ! Utilisation du filtre classique
+    !ccccccccccccccccccccccccccccccccccccccccccc
+
+       IF (.NOT. use_filtre_fft) THEN
+
+    ! !---------------------------------!
+    ! ! Agregation des niveau verticaux !
+    ! ! uniquement necessaire pour une  !
+    ! ! execution OpenMP                !
+    ! !---------------------------------!
+          ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, nbniv
+             ll_nb = ll_nb+1
+             DO j = jdfil,jffil
+                DO i = 1, iim
+                   champ_loc(i,j,ll_nb) = &
+                         champ(i,j,l) * sdd12(i,sdd1_type)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+
+          nbniv_loc = ll_nb
+
+          IF( hemisph.EQ.1 )      THEN
+
+             IF( ifiltre.EQ.-2 )   THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matrinvn(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matrinvn(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE IF ( griscal )     THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matriceun(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matriceun(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matricevn(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matricevn(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ENDIF
+
+          ELSE
+
+             IF( ifiltre.EQ.-2 )   THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matrinvs(1,1,j-jfiltsu+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE IF ( griscal )     THEN
+
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matriceus(1,1,j-jfiltsu+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matriceus(1:iim,1:iim,j-jfiltsu+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ELSE
+
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matricevs(1,1,j-jfiltsv+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matricevs(1:iim,1:iim,j-jfiltsv+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+
+             ENDIF
+
+          ENDIF
+    ! c
+          IF( ifiltre.EQ.2 )  THEN
+
+    ! !-------------------------------------!
+    ! ! DÃ©s-agregation des niveau verticaux !
+    ! ! uniquement necessaire pour une      !
+    ! ! execution OpenMP                    !
+    ! !-------------------------------------!
+             ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l = 1, nbniv
+                ll_nb = ll_nb + 1
+                DO j = jdfil,jffil
+                   DO i = 1, iim
+                      champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                            + champ_fft(i,j,ll_nb)) &
+                            * sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+
+          ELSE
+
+             ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l = 1, nbniv
+                ll_nb = ll_nb + 1
+                DO j = jdfil,jffil
+                   DO i = 1, iim
+                      champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                            - champ_fft(i,j,ll_nb)) &
+                            * sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+
+          ENDIF
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, nbniv
+             DO j = jdfil,jffil
+                ! ! add redundant longitude
+                champ( iip1,j,l ) = champ( 1,j,l )
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+
+    !cccccccccccccccccccccccccccccccccccccccccccc
+    ! Utilisation du filtre FFT
+    !cccccccccccccccccccccccccccccccccccccccccccc
+
+       ELSE
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,nbniv
+             DO j=jdfil,jffil
+                DO  i = 1, iim
+                   champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
+                   champ_fft( i,j,l) = champ(i,j,l)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+
+          IF (jdfil<=jffil) THEN
+             IF( ifiltre.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
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l=1,nbniv
+                DO j=jdfil,jffil
+                   DO  i = 1, iim
+                      champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) &
+                            *sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT	
+          ELSE
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l=1,nbniv
+                DO j=jdfil,jffil
+                   DO  i = 1, iim
+                      champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) &
+                            *sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+          ENDIF
+    !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,nbniv
+             DO j=jdfil,jffil
+           ! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
+           !      ! add redundant longitude
+                champ( iip1,j,l ) = champ( 1,j,l )
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT          	
+       ENDIF
+    ! Fin de la zone de filtrage
+
+
+    ENDDO
+
+     ! DO j=1,nlat
+    !
+    !      PRINT *,"check FFT ----> Delta(",j,")=",
+    ! &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
+    ! &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:))
+    !  ENDDO
+
+    !      PRINT *,"check FFT ----> Delta(",j,")=",
+    ! &            sum(champ-champ_fft)/sum(champ)
+    !
+
+    !
+ 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'/)
+!$OMP MASTER
+    CALL stop_timer
+!$OMP END MASTER
+    RETURN
+  END SUBROUTINE filtreg_p
+END MODULE mod_filtreg_p
+
Index: LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,69 +1,0 @@
-      SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y )
-c
-c  P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel )
-      REAL x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      integer ismin,ismax
-      external ismin,ismax
-      INTEGER :: ijb,ije
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.f90	(revision 5246)
@@ -0,0 +1,69 @@
+SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y )
+  !
+  !  P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  integer :: ismin,ismax
+  external ismin,ismax
+  INTEGER :: ijb,ije
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+  DO  ij = ijb+1, ije
+  y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO  ij = ijb, ije, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if(pole_nord) ijb=ij_begin+iip1
+  if(pole_sud) ije=ij_end-iip1
+
+  DO  ij = ijb,ije
+  x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+  END DO
+
+  if (pole_nord) then
+    DO  ij = 1,iip1
+     x(    ij    ,l ) = 0.
+    ENDDO
+  endif
+
+  if (pole_sud) then
+    DO  ij = 1,iip1
+     x( ij +ip1jm,l ) = 0.
+    ENDDO
+  endif
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE nxgrad_gam_loc
Index: LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,68 +1,0 @@
-      SUBROUTINE nxgrad_loc (klevel, rot, x, y )
-c
-c     P. Le Van
-c
-c   ********************************************************************
-c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
-c   ********************************************************************
-c       rot          est un argument  d'entree pour le s-prog
-c       x  et y    sont des arguments de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel )
-      REAL y(ijb_v:ije_v,klevel )
-      INTEGER   l,ij
-      INTEGER :: ijb,ije
-c
-c
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO 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: LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.f90	(revision 5246)
@@ -0,0 +1,68 @@
+SUBROUTINE nxgrad_loc (klevel, rot, x, y )
+  !
+  ! P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel )
+  REAL :: y(ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO  ij = ijb+1, ije
+  y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO  ij = ijb, ije, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+
+  if (pole_nord)  ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO  ij = ijb,ije
+  x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+  END DO
+
+  if (pole_nord) then
+    DO ij = 1,iip1
+      x(    ij    ,l ) = 0.
+    ENDDO
+  endif
+
+  if (pole_sud) then
+    DO ij = 1,iip1
+      x( ij +ip1jm,l ) = 0.
+    ENDDO
+  endif
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE nxgrad_loc
Index: LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,143 +1,0 @@
-       SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
-c
-c      P.Le Van .
-c   ***********************************************************
-c                                 lr
-c      calcul de  ( nxgrad (rot) )   du vect. v  ....
-c
-c       xcov et ycov  etant les compos. covariantes de  v
-c   ***********************************************************
-c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
-c      grx   et  gry     sont des arguments de sortie pour le s-prog
-c
-c
-      USE write_Field_p
-      USE parallel_lmdz
-      USE times
-      USE mod_hallo
-      USE mod_filtreg_p
-      USE nxgraro2_mod
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comdissipn.h"
-c
-c    ......  variables en arguments  .......
-c
-      INTEGER klevel
-      REAL xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
-      REAL  grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
-c
-c    ......   variables locales     ........
-c
-      REAL  signe, nugradrs
-      INTEGER l,ij,iter,lr
-      Type(Request),SAVE :: Request_dissip
-!$OMP THREADPRIVATE(Request_dissip)
-c    ........................................................
-c
-      INTEGER :: ijb,ije,jjb,jje
-      
-c
-c
-      signe    = (-1.)**lr
-      nugradrs = signe * crot
-c
-c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
-c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
- 
-      ijb=ij_begin
-      ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO    l = 1, klevel
-        grx(ijb:ije,l)=xcov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
-
-c$OMP BARRIER
-       call Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO    l = 1, klevel
-        gry(ijb:ije,l)=ycov(ijb:ije,l)
-      ENDDO
-c$OMP END DO NOWAIT
- 
-c
-      CALL     rotatf_loc ( klevel, grx, gry, rot )
-c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
-
-c$OMP BARRIER
-       call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-      
-      CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
-c       call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
-c
-c    .....   Iteration de l'operateur laplacien_rotgam  .....
-c
-      DO  iter = 1, lr -2
-c$OMP BARRIER
-       call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-	CALL laplacien_rotgam_loc( klevel, rot, rot )
-      ENDDO
-      
-c       call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
-      
-c
-c
-      jjb=jj_begin
-      jje=jj_end
-      if (pole_sud) jje=jj_end-1
-       
-      CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm,
-     &                klevel, 2,1, .FALSE.,1)
-c$OMP BARRIER
-       call Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
-       call SendRequest(Request_dissip)
-c$OMP BARRIER
-       call WaitRequest(Request_dissip)
-c$OMP BARRIER
-
-      CALL nxgrad_loc ( klevel, rot, grx, gry )
-
-c
-      ijb=ij_begin
-      ije=ij_end
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-      DO    l = 1, klevel
-        
-         if(pole_sud) ije=ij_end-iip1
-         DO  ij = ijb, ije
-          gry_out( ij,l ) = gry( ij,l ) * nugradrs
-         ENDDO
-        
-         if(pole_sud) ije=ij_end
-         DO  ij = ijb, ije
-          grx_out( ij,l ) = grx( ij,l ) * nugradrs
-         ENDDO
-     
-      ENDDO
-c$OMP END DO NOWAIT
-c
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.f90	(revision 5246)
@@ -0,0 +1,143 @@
+ SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
+  !
+  !  P.Le Van .
+  !   ***********************************************************
+  !                             lr
+  !  calcul de  ( nxgrad (rot) )   du vect. v  ....
+  !
+  !   xcov et ycov  etant les compos. covariantes de  v
+  !   ***********************************************************
+  ! xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+  !  grx   et  gry     sont des arguments de sortie pour le s-prog
+  !
+  !
+  USE write_Field_p
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE mod_filtreg_p
+  USE nxgraro2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comdissipn.h"
+  !
+  !    ......  variables en arguments  .......
+  !
+  INTEGER :: klevel
+  REAL :: xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+  REAL :: grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
+  !
+  !    ......   variables locales     ........
+  !
+  REAL :: signe, nugradrs
+  INTEGER :: l,ij,iter,lr
+  Type(Request),SAVE :: Request_dissip
+!$OMP THREADPRIVATE(Request_dissip)
+  !    ........................................................
+  !
+  INTEGER :: ijb,ije,jjb,jje
+
+  !
+  !
+  signe    = (-1.)**lr
+  nugradrs = signe * crot
+  !
+  !  CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+  !  CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+    grx(ijb:ije,l)=xcov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP BARRIER
+   call Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+    gry(ijb:ije,l)=ycov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !
+  CALL     rotatf_loc ( klevel, grx, gry, rot )
+   ! call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+
+!$OMP BARRIER
+   call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
+    ! call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
+  !
+  !    .....   Iteration de l'operateur laplacien_rotgam  .....
+  !
+  DO  iter = 1, lr -2
+!$OMP BARRIER
+   call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+    CALL laplacien_rotgam_loc( klevel, rot, rot )
+  ENDDO
+
+    ! call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
+
+  !
+  !
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm, &
+        klevel, 2,1, .FALSE.,1)
+!$OMP BARRIER
+   call Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+
+  CALL nxgrad_loc ( klevel, rot, grx, gry )
+
+  !
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+
+     if(pole_sud) ije=ij_end-iip1
+     DO  ij = ijb, ije
+      gry_out( ij,l ) = gry( ij,l ) * nugradrs
+     ENDDO
+
+     if(pole_sud) ije=ij_end
+     DO  ij = ijb, ije
+      grx_out( ij,l ) = grx( ij,l ) * nugradrs
+     ENDDO
+
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+  RETURN
+END SUBROUTINE nxgraro2_loc
Index: LMDZ6/trunk/libf/dyn3dmem/pression_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/pression_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,42 +1,0 @@
-      SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
-      USE parallel_lmdz, ONLY: ij_begin, ij_end, ijb_u, ije_u,
-     &                         pole_nord, pole_sud, omp_chunk
-c
-
-c      Auteurs : P. Le Van , Fr.Hourdin  .
-
-c  ************************************************************************
-c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
-c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
-c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
-c  ************************************************************************
-c
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-c
-      INTEGER,INTENT(IN) :: ngrid ! not used
-      INTEGER l,ij
- 
-      REAL,INTENT(IN) :: ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
-      REAL,INTENT(OUT) :: p( ijb_u:ije_u,llmp1 ) 
-      
-      INTEGER ijb,ije
-
-      
-      ijb=ij_begin-iip1
-      ije=ij_end+2*iip1
-      
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-      DO    l    = 1, llmp1
-        DO  ij   = ijb, ije
-         p(ij,l) = ap(l) + bp(l) * ps(ij)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT   
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/pression_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/pression_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/pression_loc.f90	(revision 5246)
@@ -0,0 +1,42 @@
+SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
+  USE parallel_lmdz, ONLY: ij_begin, ij_end, ijb_u, ije_u, &
+        pole_nord, pole_sud, omp_chunk
+  !
+
+  !  Auteurs : P. Le Van , Fr.Hourdin  .
+
+  !  ************************************************************************
+  ! Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+  ! sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm)
+  ! couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .
+  !  ************************************************************************
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  !
+  INTEGER,INTENT(IN) :: ngrid ! not used
+  INTEGER :: l,ij
+
+  REAL,INTENT(IN) :: ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
+  REAL,INTENT(OUT) :: p( ijb_u:ije_u,llmp1 )
+
+  INTEGER :: ijb,ije
+
+
+  ijb=ij_begin-iip1
+  ije=ij_end+2*iip1
+
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l    = 1, llmp1
+    DO  ij   = ijb, ije
+     p(ij,l) = ap(l) + bp(l) * ps(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE pression_loc
Index: LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,292 +1,0 @@
-!
-!     $Id$
-!
-      SUBROUTINE qminimum_loc( q,nqtot,deltap )
-      USE parallel_lmdz
-      USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase,
-     &                    isoCheck, min_qParent
-      USE strings_mod, ONLY: strIdx
-      IMPLICIT none
-c
-c  -- Objet : Traiter les valeurs trop petites (meme negatives)
-c             pour l'eau vapeur et l'eau liquide
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "iniprint.h"
-c
-      INTEGER nqtot ! CRisi: on remplace nq par nqtot
-      REAL q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
-c
-      LOGICAL, SAVE :: first=.TRUE.
-      INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
-c$OMP THREADPRIVATE(iq_vap, iq_liq, first)
-      REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
-      REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
-c
-c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
-c            parametres seuil_vap, seuil_liq soient pareilles a celles 
-c            qui  sont utilisees dans la routine    ADDFI       )
-c     .................................................................
-c
-cDC iq_val and iq_liq are usable for q only, NOT for q_follow
-c   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
-c   water at hardcoded indices 1/2 in these variables
-      INTEGER i, k, iq
-      REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
-
-      real zx_defau_diag(ijb_u:ije_u,llm,2) 
-      real q_follow(ijb_u:ije_u,llm,2) 
-c
-      REAL SSUM
-      EXTERNAL SSUM
-c
-      INTEGER imprim
-      SAVE imprim
-      DATA imprim /0/
-c$OMP THREADPRIVATE(imprim)
-      INTEGER ijb,ije
-      INTEGER Index_pump(ij_end-ij_begin+1)
-      INTEGER nb_pump
-      INTEGER ixt
-      INTEGER iso_verif_noNaN_nostop
-
-c$OMP BARRIER
-
-      !write(lunout,*) 'qminimum 52: entree'
-      IF(first) THEN
-         iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
-         iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
-         first = .FALSE.
-      END IF
-c
-c Quand l'eau liquide est trop petite (ou negative), on prend
-c l'eau vapeur de la meme couche et la convertit en eau liquide
-c (sans changer la temperature !)
-c
-
-      call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
-
-      ijb=ij_begin
-      ije=ij_end
-
-      DO k = 1, llm
-c$OMP DO SCHEDULE(STATIC)
-        DO i = ijb, ije
-          zx_defau_diag(i,k,1)=0.0
-          zx_defau_diag(i,k,2)=0.0
-          q_follow(i,k,1)=q(i,k,iq_vap)
-          q_follow(i,k,2)=q(i,k,iq_liq)
-        ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-      !write(lunout,*) 'qminimum 57'
-      DO k = 1, llm
-c$OMP DO SCHEDULE(STATIC)       
-        DO i = ijb, ije
-          if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
-
-            if (niso > 0) zx_defau_diag(i,k,2)=AMAX1
-     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
-
-            q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
-            q(i,k,iq_liq) = seuil_liq
-          endif
-        END DO
-c$OMP END DO NOWAIT
-      END DO
-
-c
-c Quand l'eau vapeur est trop faible (ou negative), on complete
-c le defaut en prennant de l'eau vapeur de la couche au-dessous.
-c
-      !write(lunout,*) 'qminimum 81'
-      DO k = llm, 2, -1
-ccc      zx_abc = dpres(k) / dpres(k-1)
-c$OMP DO SCHEDULE(STATIC)
-        DO i = ijb, ije
-
-          if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then
-
-            if (niso > 0) zx_defau_diag(i,k,1)
-     &           = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
-
-            q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap
-     &           -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
-            q(i,k,iq_vap)   =  seuil_vap  
-
-          endif
-        ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-c
-c Quand il s'agit de la premiere couche au-dessus du sol, on
-c doit imprimer un message d'avertissement (saturation possible).
-c
-      !write(lunout,*) 'qminimum 106'
-      nb_pump=0
-c$OMP DO SCHEDULE(STATIC)
-      DO i = ijb, ije
-         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
-         q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
-         IF (zx_pump(i) > 0.0) THEN
-            nb_pump = nb_pump+1
-            Index_pump(nb_pump)=i
-         ENDIF
-      ENDDO
-c$OMP END DO NOWAIT 
-!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
-
-      IF (imprim.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
-
-      !write(lunout,*) 'qminimum 128'
-      if (niso > 0) then
-              !write(lunout,*) 'qminimum 140'
-      ! CRisi: traiter de même les traceurs d'eau
-      ! Mais il faut les prendre à l'envers pour essayer de conserver la
-      ! masse.
-      ! 1) pompage dans le sol  
-      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
-      ! rien ici et on croise les doigts pour que ça ne soit pas trop
-      ! génant
-      ! en fait, si, c'est genant quand les isotopes doivent eux même transporter des
-      ! traceurs -> apporter aussi un peu d'isotopes... Combien?
-      ! Essayer tnat/2 = -500 permil? C'est déjà mieux que -1000
-      ! permil...
-      ! pb: que faire pour les traceurs?
-c$OMP DO SCHEDULE(STATIC)      
-      DO i = ijb, ije
-        if (zx_pump(i).gt.0.0) then
-          q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
-        endif !if (zx_pump(i).gt.0.0) then
-      enddo !DO i = ijb, ije  
-c$OMP END DO NOWAIT
-
-      ! 2) transfert de vap vers les couches plus hautes
-      !write(lunout,*) 'qminimum 158'
-      do k=2,llm
-c$OMP DO SCHEDULE(STATIC)      
-        DO i = ijb, ije
-          if (zx_defau_diag(i,k,1).gt.0.0) then             
-              ! on ajoute la vapeur en k     
-!              write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
-!     :                 i,k,q_follow(i,k-1,1)          
-              if (q_follow(i,k-1,1).lt.min_qParent) then
-                write(lunout,*) 'tmp qmin: on stoppe'
-                write(lunout,*) 'zx_pump(i)=',zx_pump(i)
-                write(lunout,*) 'q_follow(i,:,ivap)=',
-     :                   q_follow(i,:,1)
-                write(lunout,*) 'k=',k
-                call abort_gcm("qminimum","not enough vapor",1)
-              endif  
-            do ixt=1,ntiso
-!                write(lunout,*) 'qmin 168: ixt=',ixt
-!                write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
-!     :             q(i,k,iqIsoPha(ixt,iq_vap))
-!                write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
-!     :                  zx_defau_diag(i,k,1)
-!                write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
-!     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))     
-
-               q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :           +zx_defau_diag(i,k,1)
-     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
-                
-              if (isoCheck) then
-                if(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)),
-     :                   'qminimum 155').eq.1) then
-                   write(*,*) 'i,k,ixt=',i,k,ixt
-                   write(*,*) 'q_follow(i,k-1,ivap)=',
-     :                   q_follow(i,k-1,1)
-                   write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k,iqIsoPha(ixt,iq_vap))
-                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
-     :                   zx_defau_diag(i,k,1)
-                   write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
-                CALL abort_gcm("qminimum_loc","stopped",1)
-                endif
-              endif
-
-              ! et on la retranche en k-1
-               q(i,k-1,iqIsoPha(ixt,iq_vap)) =
-     :            q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,1)
-     :              *deltap(i,k)/deltap(i,k-1)
-     :              *q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              /q_follow(i,k-1,1)
-
-               if (isoCheck) then
-                if (iso_verif_noNaN_nostop(
-     :              q(i,k-1,iqIsoPha(ixt,iq_vap)),
-     :                   'qminimum 175').eq.1) then
-                   write(*,*) 'k,i,ixt=',k,i,ixt
-                   write(*,*) 'q_follow(i,k-1,ivap)=',
-     :                   q_follow(i,k-1,1)
-                   write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k,iqIsoPha(ixt,iq_vap))
-                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
-     :                   zx_defau_diag(i,k,1)
-                   write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
-     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
-                   CALL abort_gcm("qminimum_loc","stopped",1)
-                endif
-              endif 
-
-              enddo !do ixt=1,niso
-              q_follow(i,k,1)=   q_follow(i,k,1)
-     :               +zx_defau_diag(i,k,1)
-              q_follow(i,k-1,1)=   q_follow(i,k-1,1)
-     :               -zx_defau_diag(i,k,1)
-     :              *deltap(i,k)/deltap(i,k-1)
-          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
-        enddo !DO i = 1, ip1jmp1        
-c$OMP END DO NOWAIT
-        enddo !do k=2,llm
-
-        call check_isotopes(q,ijb,ije,'qminimum 168')
-        
-      
-        ! 3) transfert d'eau de la vapeur au liquide
-        !write(*,*) 'qminimum 164'
-        do k=1,llm
-c$OMP DO SCHEDULE(STATIC)
-        DO i = ijb, ije
-          if (zx_defau_diag(i,k,2).gt.0.0) then
-
-              ! on ajoute eau liquide en k en k              
-              do ixt=1,ntiso
-               q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq))
-     :              +zx_defau_diag(i,k,2)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
-              ! et on la retranche à la vapeur en k
-               q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,2)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)   
-              enddo !do ixt=1,niso
-              q_follow(i,k,2)=   q_follow(i,k,2)
-     :               +zx_defau_diag(i,k,2)
-              q_follow(i,k,1)=   q_follow(i,k,1)
-     :               -zx_defau_diag(i,k,2)
-          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
-        enddo !DO i = ijb, ije
-c$OMP END DO NOWAIT       
-       enddo !do k=2,llm  
-
-       call check_isotopes(q,ijb,ije,'qminimum 197')
-
-      endif !if (niso > 0) then
-      !write(*,*) 'qminimum 188'
-c$OMP BARRIER
-
-c
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.f90	(revision 5246)
@@ -0,0 +1,292 @@
+!
+! $Id$
+!
+SUBROUTINE qminimum_loc( q,nqtot,deltap )
+  USE parallel_lmdz
+  USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase, &
+        isoCheck, min_qParent
+  USE strings_mod, ONLY: strIdx
+  IMPLICIT none
+  !
+  !  -- Objet : Traiter les valeurs trop petites (meme negatives)
+  !         pour l'eau vapeur et l'eau liquide
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  INTEGER :: nqtot ! CRisi: on remplace nq par nqtot
+  REAL :: q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
+  !
+  LOGICAL, SAVE :: first=.TRUE.
+  INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
+!$OMP THREADPRIVATE(iq_vap, iq_liq, first)
+  REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
+  REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
+  !
+  !  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+  !        parametres seuil_vap, seuil_liq soient pareilles a celles
+  !        qui  sont utilisees dans la routine    ADDFI       )
+  ! .................................................................
+  !
+  !DC iq_val and iq_liq are usable for q only, NOT for q_follow
+  !   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
+  !   water at hardcoded indices 1/2 in these variables
+  INTEGER :: i, k, iq
+  REAL :: zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
+
+  real :: zx_defau_diag(ijb_u:ije_u,llm,2)
+  real :: q_follow(ijb_u:ije_u,llm,2)
+  !
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  INTEGER :: imprim
+  SAVE imprim
+  DATA imprim /0/
+!$OMP THREADPRIVATE(imprim)
+  INTEGER :: ijb,ije
+  INTEGER :: Index_pump(ij_end-ij_begin+1)
+  INTEGER :: nb_pump
+  INTEGER :: ixt
+  INTEGER :: iso_verif_noNaN_nostop
+
+!$OMP BARRIER
+
+  ! !write(lunout,*) 'qminimum 52: entree'
+  IF(first) THEN
+     iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
+     iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
+     first = .FALSE.
+  END IF
+  !
+  ! Quand l'eau liquide est trop petite (ou negative), on prend
+  ! l'eau vapeur de la meme couche et la convertit en eau liquide
+  ! (sans changer la temperature !)
+  !
+
+  call check_isotopes(q,ij_begin,ij_end,'qminimum 52')
+
+  ijb=ij_begin
+  ije=ij_end
+
+  DO k = 1, llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      zx_defau_diag(i,k,1)=0.0
+      zx_defau_diag(i,k,2)=0.0
+      q_follow(i,k,1)=q(i,k,iq_vap)
+      q_follow(i,k,2)=q(i,k,iq_liq)
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  ! !write(lunout,*) 'qminimum 57'
+  DO k = 1, llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+
+        if (niso > 0) zx_defau_diag(i,k,2)=AMAX1 &
+              ( seuil_liq - q(i,k,iq_liq), 0.0 )
+
+        q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+        q(i,k,iq_liq) = seuil_liq
+      endif
+    END DO
+!$OMP END DO NOWAIT
+  END DO
+
+  !
+  ! Quand l'eau vapeur est trop faible (ou negative), on complete
+  ! le defaut en prennant de l'eau vapeur de la couche au-dessous.
+  !
+  ! !write(lunout,*) 'qminimum 81'
+  DO k = llm, 2, -1
+  !cc      zx_abc = dpres(k) / dpres(k-1)
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+
+      if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then
+
+        if (niso > 0) zx_defau_diag(i,k,1) &
+              = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
+
+        q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap &
+              -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
+        q(i,k,iq_vap)   =  seuil_vap
+
+      endif
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  !
+  ! Quand il s'agit de la premiere couche au-dessus du sol, on
+  ! doit imprimer un message d'avertissement (saturation possible).
+  !
+  ! !write(lunout,*) 'qminimum 106'
+  nb_pump=0
+!$OMP DO SCHEDULE(STATIC)
+  DO i = ijb, ije
+     zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
+     q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
+     IF (zx_pump(i) > 0.0) THEN
+        nb_pump = nb_pump+1
+        Index_pump(nb_pump)=i
+     ENDIF
+  ENDDO
+!$OMP END DO NOWAIT
+   ! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+
+  IF (imprim.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
+
+  ! !write(lunout,*) 'qminimum 128'
+  if (niso > 0) then
+          ! !write(lunout,*) 'qminimum 140'
+  ! ! CRisi: traiter de même les traceurs d'eau
+  ! ! Mais il faut les prendre à l'envers pour essayer de conserver la
+  ! ! masse.
+  ! ! 1) pompage dans le sol
+  ! ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
+  ! ! rien ici et on croise les doigts pour que ça ne soit pas trop
+  ! ! génant
+  ! ! en fait, si, c'est genant quand les isotopes doivent eux même transporter des
+  ! ! traceurs -> apporter aussi un peu d'isotopes... Combien?
+  ! ! Essayer tnat/2 = -500 permil? C'est déjà mieux que -1000
+  ! ! permil...
+  ! ! pb: que faire pour les traceurs?
+!$OMP DO SCHEDULE(STATIC)
+  DO i = ijb, ije
+    if (zx_pump(i).gt.0.0) then
+      q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
+    endif !if (zx_pump(i).gt.0.0) then
+  enddo !DO i = ijb, ije
+!$OMP END DO NOWAIT
+
+  ! ! 2) transfert de vap vers les couches plus hautes
+  ! !write(lunout,*) 'qminimum 158'
+  do k=2,llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (zx_defau_diag(i,k,1).gt.0.0) then
+          ! ! on ajoute la vapeur en k
+          !  write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
+  ! :                 i,k,q_follow(i,k-1,1)
+          if (q_follow(i,k-1,1).lt.min_qParent) then
+            write(lunout,*) 'tmp qmin: on stoppe'
+            write(lunout,*) 'zx_pump(i)=',zx_pump(i)
+            write(lunout,*) 'q_follow(i,:,ivap)=', &
+                  q_follow(i,:,1)
+            write(lunout,*) 'k=',k
+            call abort_gcm("qminimum","not enough vapor",1)
+          endif
+        do ixt=1,ntiso
+             ! write(lunout,*) 'qmin 168: ixt=',ixt
+             ! write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
+  ! :             q(i,k,iqIsoPha(ixt,iq_vap))
+  !            write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
+  ! :                  zx_defau_diag(i,k,1)
+  !            write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
+  ! :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
+
+           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
+                 +zx_defau_diag(i,k,1) &
+                 *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
+
+          if (isoCheck) then
+            if(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)), &
+                  'qminimum 155').eq.1) then
+               write(*,*) 'i,k,ixt=',i,k,ixt
+               write(*,*) 'q_follow(i,k-1,ivap)=', &
+                     q_follow(i,k-1,1)
+               write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k,iqIsoPha(ixt,iq_vap))
+               write(*,*) 'zx_defau_diag(i,k,ivap)=', &
+                     zx_defau_diag(i,k,1)
+               write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k-1,iqIsoPha(ixt,iq_vap))
+            CALL abort_gcm("qminimum_loc","stopped",1)
+            endif
+          endif
+
+          ! ! et on la retranche en k-1
+           q(i,k-1,iqIsoPha(ixt,iq_vap)) = &
+                 q(i,k-1,iqIsoPha(ixt,iq_vap)) &
+                 -zx_defau_diag(i,k,1) &
+                 *deltap(i,k)/deltap(i,k-1) &
+                 *q(i,k-1,iqIsoPha(ixt,iq_vap)) &
+                 /q_follow(i,k-1,1)
+
+           if (isoCheck) then
+            if (iso_verif_noNaN_nostop( &
+                  q(i,k-1,iqIsoPha(ixt,iq_vap)), &
+                  'qminimum 175').eq.1) then
+               write(*,*) 'k,i,ixt=',k,i,ixt
+               write(*,*) 'q_follow(i,k-1,ivap)=', &
+                     q_follow(i,k-1,1)
+               write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k,iqIsoPha(ixt,iq_vap))
+               write(*,*) 'zx_defau_diag(i,k,ivap)=', &
+                     zx_defau_diag(i,k,1)
+               write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k-1,iqIsoPha(ixt,iq_vap))
+               CALL abort_gcm("qminimum_loc","stopped",1)
+            endif
+          endif
+
+          enddo !do ixt=1,niso
+          q_follow(i,k,1)=   q_follow(i,k,1) &
+                +zx_defau_diag(i,k,1)
+          q_follow(i,k-1,1)=   q_follow(i,k-1,1) &
+                -zx_defau_diag(i,k,1) &
+                *deltap(i,k)/deltap(i,k-1)
+      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+    enddo !DO i = 1, ip1jmp1
+!$OMP END DO NOWAIT
+    enddo !do k=2,llm
+
+    call check_isotopes(q,ijb,ije,'qminimum 168')
+
+
+    ! ! 3) transfert d'eau de la vapeur au liquide
+    ! !write(*,*) 'qminimum 164'
+    do k=1,llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (zx_defau_diag(i,k,2).gt.0.0) then
+
+          ! ! on ajoute eau liquide en k en k
+          do ixt=1,ntiso
+           q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq)) &
+                 +zx_defau_diag(i,k,2) &
+                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+          ! ! et on la retranche à la vapeur en k
+           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
+                 -zx_defau_diag(i,k,2) &
+                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+          enddo !do ixt=1,niso
+          q_follow(i,k,2)=   q_follow(i,k,2) &
+                +zx_defau_diag(i,k,2)
+          q_follow(i,k,1)=   q_follow(i,k,1) &
+                -zx_defau_diag(i,k,2)
+      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+    enddo !DO i = ijb, ije
+!$OMP END DO NOWAIT
+   enddo !do k=2,llm
+
+   call check_isotopes(q,ijb,ije,'qminimum 197')
+
+  endif !if (niso > 0) then
+  ! !write(*,*) 'qminimum 188'
+!$OMP BARRIER
+
+  !
+  RETURN
+END SUBROUTINE qminimum_loc
Index: LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,52 +1,0 @@
-      SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
-c
-c    Auteur :   P.Le Van 
-c**************************************************************
-c.          Calcule le rotationnel  non filtre   ,
-c      a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel )
-      REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-      INTEGER :: ijb,ije
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      DO  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: LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.f90	(revision 5246)
@@ -0,0 +1,52 @@
+SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
+  !
+  !    Auteur :   P.Le Van
+  !**************************************************************
+  !.          Calcule le rotationnel  non filtre   ,
+  !  a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE rotat_nfil_loc
Index: LMDZ6/trunk/libf/dyn3dmem/rotat_p.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/rotat_p.F	(revision 5214)
+++ 	(revision )
@@ -1,63 +1,0 @@
-      SUBROUTINE rotat_p (klevel, x, y, rot )
-c
-c     Auteur : P.Le Van 
-c**************************************************************
-c.  calcule le rotationnel
-c     a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ip1jm,klevel )
-      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-      INTEGER :: ijb,ije
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-      
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO  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: LMDZ6/trunk/libf/dyn3dmem/rotat_p.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/rotat_p.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/rotat_p.f90	(revision 5246)
@@ -0,0 +1,63 @@
+SUBROUTINE rotat_p (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  !cc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+      DO ij = ijb, ije
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+  !
+  RETURN
+END SUBROUTINE rotat_p
Index: LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,69 +1,0 @@
-      SUBROUTINE rotatf_loc (klevel, x, y, rot )
-c
-c     Auteur : P.Le Van 
-c**************************************************************
-c.  calcule le rotationnel
-c     a tous les niveaux d'1 vecteur de comp. x et y ..
-c       x  et  y etant des composantes  covariantes  ...
-c********************************************************************
-c   klevel, x  et y   sont des arguments d'entree pour le s-prog
-c        rot          est  un argument  de sortie pour le s-prog
-c
-      USE parallel_lmdz
-      USE mod_filtreg_p
-      IMPLICIT NONE
-c
-      INCLUDE "dimensions.h"
-      INCLUDE "paramet.h"
-      INCLUDE "comgeom.h"
-c
-c   .....  variables en arguments  ......
-c
-      INTEGER klevel
-      REAL rot( ijb_v:ije_v,klevel )
-      REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
-c
-c  ...   variables  locales  ...
-c
-      INTEGER  l, ij
-      INTEGER :: ijb,ije,jjb,jje
-c
-c
-      ijb=ij_begin
-      ije=ij_end
-      if(pole_sud) ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO  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: LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.f90	(revision 5246)
@@ -0,0 +1,69 @@
+SUBROUTINE rotatf_loc (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+    CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm, &
+          klevel, 2, 2, .FALSE., 1 )
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+      DO ij = ijb, ije
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+  !
+  RETURN
+END SUBROUTINE rotatf_loc
Index: LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,189 +1,0 @@
-!
-! $Id $
-!
-      SUBROUTINE sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
-
-c=======================================================================
-c
-c   Author:    Thomas Dubos      original: 26/01/2010
-c   -------
-c
-c   Subject:
-c   ------
-c   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
-c
-c   Method:
-c   --------
-c
-c   Interface:
-c   ----------
-c
-c      Input:
-c      ------
-c
-c      Output:
-c      -------
-c
-c=======================================================================
-      USE parallel_lmdz
-      USE comconst_mod, ONLY: cpp, omeg, rad
-      USE comvert_mod, ONLY: ap, bp, preff
-
-      IMPLICIT NONE
-c-----------------------------------------------------------------------
-c   Declararations:
-c   ---------------
-
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-c   variables dynamiques
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) ! vents covariants
-      REAL teta(ijb_u:ije_u,llm)                 ! temperature potentielle
-      REAL ps(ijb_u:ije_u)                       ! pression  au sol
-      REAL masse(ijb_u:ije_u,llm)                ! masse d'air
-      REAL phis(ijb_u:ije_u)                     ! geopotentiel au sol
-
-c   Local:
-c   ------
-
-      real,allocatable :: ucov_glo(:,:)
-      real,allocatable :: vcov_glo(:,:)
-      real,allocatable :: teta_glo(:,:)
-      real,allocatable :: masse_glo(:,:)
-      real,allocatable :: ps_glo(:)
-
-!      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
-!      REAL pks(ip1jmp1)                      ! exner au  sol
-!      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
-!      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
-!      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
-
-      real,allocatable :: p(:,:)
-      real,allocatable :: pks(:)
-      real,allocatable :: pk(:,:)
-      real,allocatable :: pkf(:,:)
-      real,allocatable :: alpha(:,:),beta(:,:)
-
-      REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
-      INTEGER i,j,ij
-
-      REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
-      REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
-      REAL, PARAMETER    :: gh0  = 9.80616 * 8e3 
-      INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
-c NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
-c      omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
-
-
-       ! allocate (global) arrays
-       allocate(vcov_glo(ip1jm,llm))
-       allocate(ucov_glo(ip1jmp1,llm))
-       allocate(teta_glo(ip1jmp1,llm))
-       allocate(ps_glo(ip1jmp1))
-       allocate(masse_glo(ip1jmp1,llm))
-
-       allocate(p(ip1jmp1,llmp1))
-       allocate(pks(ip1jmp1))
-       allocate(pk(ip1jmp1,llm))
-       allocate(pkf(ip1jmp1,llm))
-       allocate(alpha(ip1jmp1,llm))
-       allocate(beta(ip1jmp1,llm))
- 
-      IF(0==0) THEN
-!c Williamson et al. (1991) : onde de Rossby-Haurwitz
-         teta_glo(:,:) = preff/rho/cpp
-!c geopotentiel (pression de surface)
-         do j=1,jjp1
-            costh2 = cos(rlatu(j))**2
-            Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
-            Ath = .25*(K**2)*(costh2**(R0-1))*Ath
-            Ath = .5*K*(2*omeg+K)*costh2 + Ath 
-            Bth = (R1*R1+1)-R1*R1*costh2
-            Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
-            Cth = R1*costh2 - R2
-            Cth = .25*K*K*(costh2**R0)*Cth
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               lon = rlonv(i)
-               dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
-               ps_glo(ij) = rho*(gh0 + (rad**2)*dps)
-            enddo
-         enddo
-!         write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
-c vitesse zonale ucov
-         do j=1,jjp1
-            costh  = cos(rlatu(j))
-            costh2 = costh**2
-            Ath = rad*K*costh
-            Bth = R0*(1-costh2)-costh2
-            Bth = rad*K*Bth*(costh**(R0-1))
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               lon = rlonu(i)
-               ucov_glo(ij,1) = (Ath + Bth*cos(R0*lon))
-            enddo
-         enddo
-!         write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
-         ucov_glo(:,1)=ucov_glo(:,1)*cu
-c vitesse meridienne vcov
-         do j=1,jjm
-            sinth  = sin(rlatv(j))
-            costh  = cos(rlatv(j))
-            Ath = -rad*K*R0*sinth*(costh**(R0-1))
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               lon = rlonv(i)
-               vcov_glo(ij,1) = Ath*sin(R0*lon)
-            enddo
-         enddo
-         write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
-         vcov_glo(:,1)=vcov_glo(:,1)*cv
-        
-c         ucov_glo=0
-c         vcov_glo=0
-      ELSE
-c test non-tournant, onde se propageant en latitude
-         do j=1,jjp1
-            do i=1,iip1
-               ij=(j-1)*iip1+i
-               ps_glo(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2))
-            enddo
-         enddo
-         
-c     rho = preff/(cpp*teta)
-         teta_glo(:,:) = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
-         ucov_glo(:,:)=0.
-         vcov_glo(:,:)=0.
-      END IF      
-      
-      CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
-      CALL massdair(p,masse_glo)
-
-      ! copy data from global array to local array:
-      teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
-      ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
-      vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
-      masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
-      ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
-
-      ! cleanup
-      deallocate(teta_glo)
-      deallocate(ucov_glo)
-      deallocate(vcov_glo)
-      deallocate(masse_glo)
-      deallocate(ps_glo)
-      deallocate(p)
-      deallocate(pks)
-      deallocate(pk)
-      deallocate(pkf)
-      deallocate(alpha)
-      deallocate(beta)
-
-      END
-c-----------------------------------------------------------------------
Index: LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.f90	(revision 5246)
@@ -0,0 +1,189 @@
+!
+! $Id $
+!
+SUBROUTINE sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
+
+  !=======================================================================
+  !
+  !   Author:    Thomas Dubos      original: 26/01/2010
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: cpp, omeg, rad
+  USE comvert_mod, ONLY: ap, bp, preff
+
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  !   variables dynamiques
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) ! vents covariants
+  REAL :: teta(ijb_u:ije_u,llm)                 ! temperature potentielle
+  REAL :: ps(ijb_u:ije_u)                       ! pression  au sol
+  REAL :: masse(ijb_u:ije_u,llm)                ! masse d'air
+  REAL :: phis(ijb_u:ije_u)                     ! geopotentiel au sol
+
+  !   Local:
+  !   ------
+
+  real,allocatable :: ucov_glo(:,:)
+  real,allocatable :: vcov_glo(:,:)
+  real,allocatable :: teta_glo(:,:)
+  real,allocatable :: masse_glo(:,:)
+  real,allocatable :: ps_glo(:)
+
+   ! REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+   ! REAL pks(ip1jmp1)                      ! exner au  sol
+   ! REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+   ! REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+   ! REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+
+  real,allocatable :: p(:,:)
+  real,allocatable :: pks(:)
+  real,allocatable :: pk(:,:)
+  real,allocatable :: pkf(:,:)
+  real,allocatable :: alpha(:,:),beta(:,:)
+
+  REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
+  INTEGER :: i,j,ij
+
+  REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
+  REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
+  REAL, PARAMETER    :: gh0  = 9.80616 * 8e3
+  INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
+  ! NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
+   ! omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
+
+
+   ! ! allocate (global) arrays
+   allocate(vcov_glo(ip1jm,llm))
+   allocate(ucov_glo(ip1jmp1,llm))
+   allocate(teta_glo(ip1jmp1,llm))
+   allocate(ps_glo(ip1jmp1))
+   allocate(masse_glo(ip1jmp1,llm))
+
+   allocate(p(ip1jmp1,llmp1))
+   allocate(pks(ip1jmp1))
+   allocate(pk(ip1jmp1,llm))
+   allocate(pkf(ip1jmp1,llm))
+   allocate(alpha(ip1jmp1,llm))
+   allocate(beta(ip1jmp1,llm))
+
+  IF(0==0) THEN
+  !c Williamson et al. (1991) : onde de Rossby-Haurwitz
+     teta_glo(:,:) = preff/rho/cpp
+  !c geopotentiel (pression de surface)
+     do j=1,jjp1
+        costh2 = cos(rlatu(j))**2
+        Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
+        Ath = .25*(K**2)*(costh2**(R0-1))*Ath
+        Ath = .5*K*(2*omeg+K)*costh2 + Ath
+        Bth = (R1*R1+1)-R1*R1*costh2
+        Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
+        Cth = R1*costh2 - R2
+        Cth = .25*K*K*(costh2**R0)*Cth
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonv(i)
+           dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
+           ps_glo(ij) = rho*(gh0 + (rad**2)*dps)
+        enddo
+     enddo
+      ! write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
+  ! vitesse zonale ucov
+     do j=1,jjp1
+        costh  = cos(rlatu(j))
+        costh2 = costh**2
+        Ath = rad*K*costh
+        Bth = R0*(1-costh2)-costh2
+        Bth = rad*K*Bth*(costh**(R0-1))
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonu(i)
+           ucov_glo(ij,1) = (Ath + Bth*cos(R0*lon))
+        enddo
+     enddo
+      ! write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
+     ucov_glo(:,1)=ucov_glo(:,1)*cu
+  ! vitesse meridienne vcov
+     do j=1,jjm
+        sinth  = sin(rlatv(j))
+        costh  = cos(rlatv(j))
+        Ath = -rad*K*R0*sinth*(costh**(R0-1))
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonv(i)
+           vcov_glo(ij,1) = Ath*sin(R0*lon)
+        enddo
+     enddo
+     write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
+     vcov_glo(:,1)=vcov_glo(:,1)*cv
+
+      ! ucov_glo=0
+      ! vcov_glo=0
+  ELSE
+  ! test non-tournant, onde se propageant en latitude
+     do j=1,jjp1
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           ps_glo(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2))
+        enddo
+     enddo
+
+  ! rho = preff/(cpp*teta)
+     teta_glo(:,:) = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
+     ucov_glo(:,:)=0.
+     vcov_glo(:,:)=0.
+  END IF
+
+  CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
+  CALL massdair(p,masse_glo)
+
+  ! ! copy data from global array to local array:
+  teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
+  ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
+  vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
+  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
+  ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
+
+  ! ! cleanup
+  deallocate(teta_glo)
+  deallocate(ucov_glo)
+  deallocate(vcov_glo)
+  deallocate(masse_glo)
+  deallocate(ps_glo)
+  deallocate(p)
+  deallocate(pks)
+  deallocate(pk)
+  deallocate(pkf)
+  deallocate(alpha)
+  deallocate(beta)
+
+END SUBROUTINE sw_case_williamson91_6_loc
+!-----------------------------------------------------------------------
Index: LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,256 +1,0 @@
-!
-! $Id: $
-!
-      SUBROUTINE top_bound_loc(vcov,ucov,teta,masse,dt)
-      USE parallel_lmdz
-      USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound,
-     &                        tau_top_bound
-      USE comvert_mod, ONLY: presnivs, preff, scaleheight
-
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom2.h"
-
-
-c ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
-C     F. LOTT DEC. 2006
-c                                 (  10/12/06  )
-
-c=======================================================================
-c
-c   Auteur:  F. LOTT  
-c   -------
-c
-c   Objet:
-c   ------
-c
-c   Dissipation linéaire (ex top_bound de la physique)
-c
-c=======================================================================
-
-! top_bound sponge layer model:
-! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
-! where Am is the zonal average of the field (or zero), and lambda the inverse
-! of the characteristic quenching/relaxation time scale
-! Thus, assuming Am to be time-independent, field at time t+dt is given by:
-! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
-! Moreover lambda can be a function of model level (see below), and relaxation
-! can be toward the average zonal field or just zero (see below).
-
-! NB: top_bound sponge is only called from leapfrog if ok_strato=.true.
-
-! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
-!    iflag_top_bound=0 for no sponge
-!    iflag_top_bound=1 for sponge over 4 topmost layers
-!    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
-!    mode_top_bound=0: no relaxation
-!    mode_top_bound=1: u and v relax towards 0
-!    mode_top_bound=2: u and v relax towards their zonal mean
-!    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
-!    tau_top_bound : inverse of charactericstic relaxation time scale at
-!                       the topmost layer (Hz)
-
-
-      INCLUDE "comdissipn.h"
-      INCLUDE "iniprint.h"
-
-c   Arguments:
-c   ----------
-
-      real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
-      real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
-      real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
-      real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere 
-      real,intent(in) :: dt ! time step (s) of sponge model
-
-!      REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
-!      REAL dh(iip1,jjb_u:jje_u,llm)
-
-c   Local:
-c   ------
-      REAL massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm)
-      REAL zm
-      REAL uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm)
-      REAL tzon(jjb_u:jje_u,llm)
-      
-      integer i
-      REAL,SAVE :: rdamp(llm)
-      real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
-      LOGICAL,SAVE :: first=.true.
-      INTEGER j,l,jjb,jje
-
-
-      if (iflag_top_bound == 0) return
-
-      if (first) then
-c$OMP BARRIER
-c$OMP MASTER
-         if (iflag_top_bound == 1) then
-! sponge quenching over the topmost 4 atmospheric layers
-             lambda(:)=0.
-             lambda(llm)=tau_top_bound
-             lambda(llm-1)=tau_top_bound/2.
-             lambda(llm-2)=tau_top_bound/4.
-             lambda(llm-3)=tau_top_bound/8.
-         else if (iflag_top_bound == 2) then
-! sponge quenching over topmost layers down to pressures which are
-! higher than 100 times the topmost layer pressure
-             lambda(:)=tau_top_bound
-     s       *max(presnivs(llm)/presnivs(:)-0.01,0.)
-         endif
-
-! quenching coefficient rdamp(:)
-!         rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
-         rdamp(:)=1.-exp(-lambda(:)*dt)
-
-         write(lunout,*)'TOP_BOUND mode',mode_top_bound
-         write(lunout,*)'Sponge layer coefficients'
-         write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
-         do l=1,llm
-           if (rdamp(l).ne.0.) then
-             write(lunout,'(6(1pe12.4,1x))')
-     &        presnivs(l),log(preff/presnivs(l))*scaleheight,
-     &           1./lambda(l),lambda(l)
-           endif
-         enddo
-         first=.false.
-c$OMP END MASTER
-c$OMP BARRIER
-      endif ! of if (first)
-
-
-      CALL massbar_loc(masse,massebx,masseby)
-
-      ! compute zonal average of vcov (or set it to zero)
-      if (mode_top_bound.ge.2) then
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_sud) jje=jj_end-1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          zm=0.
-          vzon(j,l)=0
-          do i=1,iim
-! NB: we can work using vcov zonal mean rather than v since the
-! cv coefficient (which relates the two) only varies with latitudes 
-            vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
-            zm=zm+masseby(i,j,l)
-          enddo
-          vzon(j,l)=vzon(j,l)/zm
-        enddo
-       enddo
-c$OMP END DO NOWAIT   
-      else
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-         vzon(:,l)=0.
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.2)
-
-      ! compute zonal average of u (or set it to zero)
-      if (mode_top_bound.ge.2) then
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          uzon(j,l)=0.
-          zm=0.
-          do i=1,iim
-            uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
-            zm=zm+massebx(i,j,l)
-          enddo
-          uzon(j,l)=uzon(j,l)/zm
-        enddo
-       enddo
-c$OMP END DO NOWAIT
-      else
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-         uzon(:,l)=0.
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.2)
-
-      ! compute zonal average of potential temperature, if necessary
-      if (mode_top_bound.ge.3) then
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-       do l=1,llm
-        do j=jjb,jje
-          zm=0.
-          tzon(j,l)=0.
-          do i=1,iim
-            tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
-            zm=zm+masse(i,j,l)
-          enddo
-          tzon(j,l)=tzon(j,l)/zm
-        enddo
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.3)
-
-      if (mode_top_bound.ge.1) then
-       ! Apply sponge quenching on vcov:
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_sud) jje=jj_end-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          do i=1,iip1
-            vcov(i,j,l)=vcov(i,j,l)
-     &                  -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
-          enddo
-        enddo
-       enddo
-c$OMP END DO NOWAIT
-
-       ! Apply sponge quenching on ucov:
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          do i=1,iip1
-            ucov(i,j,l)=ucov(i,j,l)
-     &                  -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
-          enddo
-       enddo
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bound.ge.1)
-
-      if (mode_top_bound.ge.3) then   
-       ! Apply sponge quenching on teta:
-       jjb=jj_begin
-       jje=jj_end
-       IF (pole_nord) jjb=jj_begin+1
-       IF (pole_sud)  jje=jj_end-1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-       do l=1,llm
-        do j=jjb,jje
-          do i=1,iip1
-            teta(i,j,l)=teta(i,j,l)
-     &                  -rdamp(l)*(teta(i,j,l)-tzon(j,l))
-          enddo
-       enddo
-       enddo
-c$OMP END DO NOWAIT
-      endif ! of if (mode_top_bond.ge.3)
-
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.f90	(revision 5246)
@@ -0,0 +1,256 @@
+!
+! $Id: $
+!
+SUBROUTINE top_bound_loc(vcov,ucov,teta,masse,dt)
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound, &
+        tau_top_bound
+  USE comvert_mod, ONLY: presnivs, preff, scaleheight
+
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+
+  ! ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
+  ! F. LOTT DEC. 2006
+  !                             (  10/12/06  )
+
+  !=======================================================================
+  !
+  !   Auteur:  F. LOTT
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Dissipation linéaire (ex top_bound de la physique)
+  !
+  !=======================================================================
+
+  ! top_bound sponge layer model:
+  ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
+  ! where Am is the zonal average of the field (or zero), and lambda the inverse
+  ! of the characteristic quenching/relaxation time scale
+  ! Thus, assuming Am to be time-independent, field at time t+dt is given by:
+  ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
+  ! Moreover lambda can be a function of model level (see below), and relaxation
+  ! can be toward the average zonal field or just zero (see below).
+
+  ! NB: top_bound sponge is only called from leapfrog if ok_strato=.true.
+
+  ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
+  !    iflag_top_bound=0 for no sponge
+  !    iflag_top_bound=1 for sponge over 4 topmost layers
+  !    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
+  !    mode_top_bound=0: no relaxation
+  !    mode_top_bound=1: u and v relax towards 0
+  !    mode_top_bound=2: u and v relax towards their zonal mean
+  !    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
+  !    tau_top_bound : inverse of charactericstic relaxation time scale at
+  !                   the topmost layer (Hz)
+
+
+  INCLUDE "comdissipn.h"
+  INCLUDE "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
+  real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
+  real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
+  real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere
+  real,intent(in) :: dt ! time step (s) of sponge model
+
+   ! REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
+   ! REAL dh(iip1,jjb_u:jje_u,llm)
+
+  !   Local:
+  !   ------
+  REAL :: massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm)
+  REAL :: zm
+  REAL :: uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm)
+  REAL :: tzon(jjb_u:jje_u,llm)
+
+  integer :: i
+  REAL,SAVE :: rdamp(llm)
+  real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
+  LOGICAL,SAVE :: first=.true.
+  INTEGER :: j,l,jjb,jje
+
+
+  if (iflag_top_bound == 0) return
+
+  if (first) then
+!$OMP BARRIER
+!$OMP MASTER
+     if (iflag_top_bound == 1) then
+  ! sponge quenching over the topmost 4 atmospheric layers
+         lambda(:)=0.
+         lambda(llm)=tau_top_bound
+         lambda(llm-1)=tau_top_bound/2.
+         lambda(llm-2)=tau_top_bound/4.
+         lambda(llm-3)=tau_top_bound/8.
+     else if (iflag_top_bound == 2) then
+  ! sponge quenching over topmost layers down to pressures which are
+  ! higher than 100 times the topmost layer pressure
+         lambda(:)=tau_top_bound &
+               *max(presnivs(llm)/presnivs(:)-0.01,0.)
+     endif
+
+  ! quenching coefficient rdamp(:)
+      ! rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
+     rdamp(:)=1.-exp(-lambda(:)*dt)
+
+     write(lunout,*)'TOP_BOUND mode',mode_top_bound
+     write(lunout,*)'Sponge layer coefficients'
+     write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
+     do l=1,llm
+       if (rdamp(l).ne.0.) then
+         write(lunout,'(6(1pe12.4,1x))') &
+               presnivs(l),log(preff/presnivs(l))*scaleheight, &
+               1./lambda(l),lambda(l)
+       endif
+     enddo
+     first=.false.
+!$OMP END MASTER
+!$OMP BARRIER
+  endif ! of if (first)
+
+
+  CALL massbar_loc(masse,massebx,masseby)
+
+  ! ! compute zonal average of vcov (or set it to zero)
+  if (mode_top_bound.ge.2) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      zm=0.
+      vzon(j,l)=0
+      do i=1,iim
+  ! NB: we can work using vcov zonal mean rather than v since the
+  ! cv coefficient (which relates the two) only varies with latitudes
+        vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
+        zm=zm+masseby(i,j,l)
+      enddo
+      vzon(j,l)=vzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+     vzon(:,l)=0.
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.2)
+
+  ! ! compute zonal average of u (or set it to zero)
+  if (mode_top_bound.ge.2) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      uzon(j,l)=0.
+      zm=0.
+      do i=1,iim
+        uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
+        zm=zm+massebx(i,j,l)
+      enddo
+      uzon(j,l)=uzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+     uzon(:,l)=0.
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.2)
+
+  ! ! compute zonal average of potential temperature, if necessary
+  if (mode_top_bound.ge.3) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      zm=0.
+      tzon(j,l)=0.
+      do i=1,iim
+        tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
+        zm=zm+masse(i,j,l)
+      enddo
+      tzon(j,l)=tzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.3)
+
+  if (mode_top_bound.ge.1) then
+   ! ! Apply sponge quenching on vcov:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        vcov(i,j,l)=vcov(i,j,l) &
+              -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
+      enddo
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+
+   ! ! Apply sponge quenching on ucov:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        ucov(i,j,l)=ucov(i,j,l) &
+              -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+      enddo
+   enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.1)
+
+  if (mode_top_bound.ge.3) then
+   ! ! Apply sponge quenching on teta:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        teta(i,j,l)=teta(i,j,l) &
+              -rdamp(l)*(teta(i,j,l)-tzon(j,l))
+      enddo
+   enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bond.ge.3)
+
+END SUBROUTINE top_bound_loc
Index: LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,547 +1,0 @@
-
-!     
-! $Header$
-!
-       SUBROUTINE vlspltgen_loc( q,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          Schema  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_lmdz
-      USE mod_hallo
-      USE Write_Field_loc
-      USE VAMPIR
-      ! CRisi: on rajoute variables utiles d'infotrac  
-      USE infotrac, ONLY : nqtot, tracers, isoCheck
-      USE vlspltgen_mod
-      USE comconst_mod, ONLY: cpp
-      USE logic_mod, ONLY: adv_qsat_liq
-      IMPLICIT NONE
-
-c
-      include "dimensions.h"
-      include "paramet.h"
-
-c
-c   Arguments:
-c   ----------
-      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,iq2,ifils
-      LOGICAL, SAVE :: firstcall=.TRUE.
-!$OMP THREADPRIVATE(firstcall)
-      type(request),SAVE :: MyRequest1
-!$OMP THREADPRIVATE(MyRequest1)
-      type(request),SAVE :: MyRequest2
-!$OMP THREADPRIVATE(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
-          IF (adv_qsat_liq) THEN
-             zdelta = 0.
-          ELSE
-             zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
-          ENDIF
-          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
-
-      DO iq=1,nqtot
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-         DO ij=ijb,ije
-            mw(ij,l,iq)=w(ij,l) * zzw
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-      ENDDO
-
-      DO iq=1,nqtot  
-c$OMP MASTER
-      DO ij=ijb,ije
-         mw(ij,llm+1,iq)=0.
-      ENDDO
-c$OMP END MASTER
-      ENDDO
-
-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
-
-      ! verif temporaire
-      ijb=ij_begin
-      ije=ij_end  
-      call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
-
-c$OMP BARRIER           
-      DO iq=1,nqtot
-        ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
-        IF(tracers(iq)%parent /= 'air') CYCLE
-        !write(*,*) 'vlspltgen 192: iq,iadv=',iq,tracers(iq)%iadv
-#ifdef DEBUG_IO    
-        CALL WriteField_u('zq',zq(:,:,iq))
-        CALL WriteField_u('zm',zm(:,:,iq)) 
-#endif
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10)
-#ifdef _ADV_HALO        
-! CRisi: on ajoute les nombres de fils et tableaux des fils
-! On suppose qu'on ne peut advecter les fils que par le schéma 10.  
-          call vlx_loc(zq,pente_max,zm,mu,
-     &                     ij_begin,ij_begin+2*iip1-1,iq)
-          call vlx_loc(zq,pente_max,zm,mu,
-     &               ij_end-2*iip1+1,ij_end,iq)
-#else
-          call vlx_loc(zq,pente_max,zm,mu,
-     &                     ij_begin,ij_end,iq)
-#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)
-! CRisi
-          do ifils=1,tracers(iq)%nqDescen
-            iq2=tracers(iq)%iqDescen(ifils)
-            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
-            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
-          enddo
-
-c$OMP MASTER
-          call VTe(VTHallo)
-c$OMP END MASTER
-          CASE(14)
-#ifdef _ADV_HALO           
-          call vlxqs_loc(zq,pente_max,zm,mu,
-     &                   qsat,ij_begin,ij_begin+2*iip1-1,iq)
-          call vlxqs_loc(zq,pente_max,zm,mu,
-     &                   qsat,ij_end-2*iip1+1,ij_end,iq)
-#else
-          call vlxqs_loc(zq,pente_max,zm,mu,
-     &                   qsat,ij_begin,ij_end,iq)
-#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)
-          do ifils=1,tracers(iq)%nqDescen
-            iq2=tracers(iq)%iqDescen(ifils)
-            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
-            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
-          enddo
-
-c$OMP MASTER
-          call VTe(VTHallo)
-c$OMP END MASTER 
-          CASE DEFAULT
-             CALL abort_gcm("vlspltgen_loc","schema non parallelise",1)
-        END SELECT
-      
-      enddo !DO iq=1,nqtot
-      
-      
-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
-
-      ! verif temporaire
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1  
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end  
-      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
-
-      do iq=1,nqtot
-        IF(tracers(iq)%parent /= 'air') CYCLE
-        !write(*,*) 'vlspltgen 279: iq=',iq
-
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10)
-#ifdef _ADV_HALLO
-          call vlx_loc(zq,pente_max,zm,mu,
-     &                 ij_begin+2*iip1,ij_end-2*iip1,iq)
-#endif        
-          CASE(14)
-#ifdef _ADV_HALLO
-          call vlxqs_loc(zq,pente_max,zm,mu,
-     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
-#endif    
-          CASE DEFAULT
-          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
-        END SELECT
-      
-      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
-
-      
-      IF(isoCheck) THEN
-           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
-           ijb=ij_begin-2*iip1
-           ije=ij_end+2*iip1
-           if (pole_nord) ijb=ij_begin
-           if (pole_sud)  ije=ij_end
-           call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
-      END IF
-
-      do iq = 1, nqtot
-       IF(tracers(iq)%parent /= 'air') CYCLE
-       !write(*,*) 'vlspltgen 321: iq=',iq
-#ifdef DEBUG_IO    
-       CALL WriteField_u('zq',zq(:,:,iq))
-       CALL WriteField_u('zm',zm(:,:,iq))
-#endif
-
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
-          CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
-          CASE DEFAULT
-          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
-        END SELECT
-       
-       enddo
-
-      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
-
-      do iq = 1, nqtot
-       IF(tracers(iq)%parent /= 'air') CYCLE
-      !write(*,*) 'vlspltgen 349: iq=',iq
-#ifdef DEBUG_IO    
-       CALL WriteField_u('zq',zq(:,:,iq))
-       CALL WriteField_u('zm',zm(:,:,iq))
-#endif
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10,14)
-c$OMP BARRIER        
-#ifdef _ADV_HALLO
-          call vlz_loc(zq,pente_max,zm,mw,
-     &               ij_begin,ij_begin+2*iip1-1,iq)
-          call vlz_loc(zq,pente_max,zm,mw,
-     &               ij_end-2*iip1+1,ij_end,iq)
-#else
-          call vlz_loc(zq,pente_max,zm,mw,
-     &               ij_begin,ij_end,iq)
-#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)
-          ! CRisi
-          do ifils=1,tracers(iq)%nqDescen
-            iq2=tracers(iq)%iqDescen(ifils)
-            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
-            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
-          enddo      
-c$OMP MASTER
-          call VTe(VTHallo)
-c$OMP END MASTER        
-c$OMP BARRIER
-          CASE DEFAULT
-            
-            CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
-         END SELECT
-      
-      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        
-
-
-      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
-
-c$OMP BARRIER
-      do iq=1,nqtot
-        IF(tracers(iq)%parent /= 'air') CYCLE
-      !write(*,*) 'vlspltgen 409: iq=',iq
-
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10,14)
-c$OMP BARRIER        
-
-#ifdef _ADV_HALLO
-          call vlz_loc(zq,pente_max,zm,mw,
-     &               ij_begin+2*iip1,ij_end-2*iip1,iq)
-#endif
-
-c$OMP BARRIER        
-          CASE DEFAULT
-          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
-        END SELECT
-      
-      enddo
-      !write(*,*) 'vlspltgen_loc 476'
-
-c$OMP BARRIER
-      !write(*,*) 'vlspltgen_loc 477'
-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
-
-
-      !write(*,*) 'vlspltgen_loc 494'
-      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
-
-      do iq=1,nqtot
-        IF(tracers(iq)%parent /= 'air') CYCLE
-      !write(*,*) 'vlspltgen 449: iq=',iq
-#ifdef DEBUG_IO    
-       CALL WriteField_u('zq',zq(:,:,iq))
-       CALL WriteField_u('zm',zm(:,:,iq))
-#endif
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
-          CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
-          CASE DEFAULT
-             CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
-        END SELECT
-       
-       enddo !do iq=1,nqtot
-
-      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
-
-      do iq=1,nqtot
-        IF(tracers(iq)%parent /= 'air') CYCLE
-      !write(*,*) 'vlspltgen 477: iq=',iq
-#ifdef DEBUG_IO    
-       CALL WriteField_u('zq',zq(:,:,iq))
-       CALL WriteField_u('zm',zm(:,:,iq))
-#endif
-        SELECT CASE(tracers(iq)%iadv)
-          CASE(0); CYCLE
-          CASE(10); call   vlx_loc(zq,pente_max,zm,mu,
-     &               ij_begin,ij_end,iq)
-          CASE(14); call vlxqs_loc(zq,pente_max,zm,mu,
-     &                 qsat, ij_begin,ij_end,iq)
-          CASE DEFAULT
-          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
-        END SELECT
-       
-       enddo !do iq=1,nqtot
-
-      !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
-      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
-     
-      ijb=ij_begin
-      ije=ij_end
-      !write(*,*) 'vlspltgen_loc 557'
-c$OMP BARRIER      
-
-      !write(*,*) 'vlspltgen_loc 559'  
-      DO iq=1,nqtot
-       !write(*,*) 'vlspltgen_loc 561, iq=',iq  
-#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    
-      !write(*,*) 'vlspltgen_loc 575'      
-
-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  
-      !write(*,*) 'vlspltgen_loc 583'  
-      ENDDO !DO iq=1,nqtot
-        
-      call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
-
-c$OMP BARRIER
-
-cc$OMP MASTER      
-c      call WaitSendRequest(MyRequest1) 
-c      call WaitSendRequest(MyRequest2)
-cc$OMP END MASTER
-cc$OMP BARRIER
-
-      !write(*,*) 'vlspltgen 597: sortie'  
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F90	(revision 5246)
@@ -0,0 +1,547 @@
+
+!
+! $Header$
+!
+ SUBROUTINE vlspltgen_loc( q,pente_max,masse,w,pbaru,pbarv, &
+         pdt, p,pk,teta                 )
+
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
+  !
+  !    ********************************************************************
+  !      Schema  d'advection " pseudo amont " .
+  !  + test sur humidite specifique: Q advecte< Qsat aval
+  !               (F. Codron, 10/99)
+  !    ********************************************************************
+  ! q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  ! pente_max facteur de limitation des pentes: 2 en general
+  !                                            0 pour un schema amont
+  ! pbaru,pbarv,w flux de masse en u ,v ,w
+  ! pdt pas de temps
+  !
+  ! teta temperature potentielle, p pression aux interfaces,
+  ! pk exner au milieu des couches necessaire pour calculer Qsat
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE mod_hallo
+  USE Write_Field_loc
+  USE VAMPIR
+  ! ! CRisi: on rajoute variables utiles d'infotrac
+  USE infotrac, ONLY : nqtot, tracers, isoCheck
+  USE vlspltgen_mod
+  USE comconst_mod, ONLY: cpp
+  USE logic_mod, ONLY: adv_qsat_liq
+  IMPLICIT NONE
+
+  !
+  include "dimensions.h"
+  include "paramet.h"
+
+  !
+  !   Arguments:
+  !   ----------
+  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)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  REAL :: zzpbar, zzw
+
+  REAL :: qmin,qmax
+  DATA qmin,qmax/0.,1.e33/
+
+  !--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,iq2,ifils
+  LOGICAL, SAVE :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+  type(request),SAVE :: MyRequest1
+!$OMP THREADPRIVATE(MyRequest1)
+  type(request),SAVE :: MyRequest2
+!$OMP THREADPRIVATE(MyRequest2)
+  !    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
+
+  ! Allocate variables depending on dynamic variable nqtot
+
+     IF (firstcall) THEN
+        firstcall=.FALSE.
+     END IF
+  !-- Calcul de Qsat en chaque point
+  !-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+  !   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
+
+!$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
+      IF (adv_qsat_liq) THEN
+         zdelta = 0.
+      ELSE
+         zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+      ENDIF
+      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
+!$OMP END DO NOWAIT
+   ! 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
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij = ijb,ije
+        mu(ij,l)=pbaru(ij,l) * zzpbar
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        mv(ij,l)=pbarv(ij,l) * zzpbar
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ijb=ij_begin
+  ije=ij_end
+
+  DO iq=1,nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        mw(ij,l,iq)=w(ij,l) * zzw
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+
+  DO iq=1,nqtot
+!$OMP MASTER
+  DO ij=ijb,ije
+     mw(ij,llm+1,iq)=0.
+  ENDDO
+!$OMP END MASTER
+  ENDDO
+
+   ! CALL SCOPY(ijp1llm,q,1,zq,1)
+   ! CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+   ijb=ij_begin
+   ije=ij_end
+
+  DO iq=1,nqtot
+!$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
+!$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
+
+  ! ! verif temporaire
+  ijb=ij_begin
+  ije=ij_end
+  call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
+
+!$OMP BARRIER
+  DO iq=1,nqtot
+    ! ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
+    IF(tracers(iq)%parent /= 'air') CYCLE
+    ! !write(*,*) 'vlspltgen 192: iq,iadv=',iq,tracers(iq)%iadv
+#ifdef DEBUG_IO
+    CALL WriteField_u('zq',zq(:,:,iq))
+    CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10)
+#ifdef _ADV_HALO
+  ! CRisi: on ajoute les nombres de fils et tableaux des fils
+  ! On suppose qu'on ne peut advecter les fils que par le schéma 10.
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin,ij_begin+2*iip1-1,iq)
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_end-2*iip1+1,ij_end,iq)
+#else
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin,ij_end,iq)
+#endif
+
+!$OMP MASTER
+      call VTb(VTHallo)
+!$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)
+  ! CRisi
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+        call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+        call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+      enddo
+
+!$OMP MASTER
+      call VTe(VTHallo)
+!$OMP END MASTER
+      CASE(14)
+#ifdef _ADV_HALO
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_begin,ij_begin+2*iip1-1,iq)
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_end-2*iip1+1,ij_end,iq)
+#else
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_begin,ij_end,iq)
+#endif
+
+!$OMP MASTER
+      call VTb(VTHallo)
+!$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)
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+        call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+        call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+      enddo
+
+!$OMP MASTER
+      call VTe(VTHallo)
+!$OMP END MASTER
+      CASE DEFAULT
+         CALL abort_gcm("vlspltgen_loc","schema non parallelise",1)
+    END SELECT
+
+  enddo !DO iq=1,nqtot
+
+
+!$OMP BARRIER
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+
+  call SendRequest(MyRequest1)
+
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  ! ! verif temporaire
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
+
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+    ! !write(*,*) 'vlspltgen 279: iq=',iq
+
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10)
+#ifdef _ADV_HALLO
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+      CASE(14)
+#ifdef _ADV_HALLO
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+
+  enddo
+!$OMP BARRIER
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+
+   ! call WaitRecvRequest(MyRequest1)
+   ! call WaitSendRequest(MyRequest1)
+!$OMP BARRIER
+   call WaitRequest(MyRequest1)
+
+
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+  IF(isoCheck) THEN
+       call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
+       ijb=ij_begin-2*iip1
+       ije=ij_end+2*iip1
+       if (pole_nord) ijb=ij_begin
+       if (pole_sud)  ije=ij_end
+       call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
+  END IF
+
+  do iq = 1, nqtot
+   IF(tracers(iq)%parent /= 'air') CYCLE
+   ! !write(*,*) 'vlspltgen 321: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
+      CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+
+   enddo
+
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
+
+  do iq = 1, nqtot
+   IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 349: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10,14)
+!$OMP BARRIER
+#ifdef _ADV_HALLO
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_begin,ij_begin+2*iip1-1,iq)
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_end-2*iip1+1,ij_end,iq)
+#else
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_begin,ij_end,iq)
+#endif
+!$OMP BARRIER
+
+!$OMP MASTER
+      call VTb(VTHallo)
+!$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)
+      ! ! CRisi
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+        call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
+        call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
+      enddo
+!$OMP MASTER
+      call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+      CASE DEFAULT
+
+        CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+     END SELECT
+
+  enddo
+!$OMP BARRIER
+
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+
+  call SendRequest(MyRequest2)
+
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+
+
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
+
+!$OMP BARRIER
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 409: iq=',iq
+
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10,14)
+!$OMP BARRIER
+
+#ifdef _ADV_HALLO
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+
+!$OMP BARRIER
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+
+  enddo
+  ! !write(*,*) 'vlspltgen_loc 476'
+
+!$OMP BARRIER
+  ! !write(*,*) 'vlspltgen_loc 477'
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+
+   ! call WaitRecvRequest(MyRequest2)
+   ! call WaitSendRequest(MyRequest2)
+!$OMP BARRIER
+   CALL WaitRequest(MyRequest2)
+
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+  ! !write(*,*) 'vlspltgen_loc 494'
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
+
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 449: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
+      CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
+      CASE DEFAULT
+         CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+
+   enddo !do iq=1,nqtot
+
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
+
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 477: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10); call   vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin,ij_end,iq)
+      CASE(14); call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat, ij_begin,ij_end,iq)
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+
+   enddo !do iq=1,nqtot
+
+  ! !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
+
+  ijb=ij_begin
+  ije=ij_end
+  ! !write(*,*) 'vlspltgen_loc 557'
+!$OMP BARRIER
+
+  ! !write(*,*) 'vlspltgen_loc 559'
+  DO iq=1,nqtot
+   ! !write(*,*) 'vlspltgen_loc 561, iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       DO ij=ijb,ije
+          ! print *,'zq-->',ij,l,iq,zq(ij,l,iq)
+          ! print *,'q-->',ij,l,iq,q(ij,l,iq)
+         q(ij,l,iq)=zq(ij,l,iq)
+       ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ! !write(*,*) 'vlspltgen_loc 575'
+
+!$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
+!$OMP END DO NOWAIT
+  ! !write(*,*) 'vlspltgen_loc 583'
+  ENDDO !DO iq=1,nqtot
+
+  call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
+
+!$OMP BARRIER
+
+  !c$OMP MASTER
+   ! call WaitSendRequest(MyRequest1)
+   ! call WaitSendRequest(MyRequest2)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+
+  ! !write(*,*) 'vlspltgen 597: sortie'
+  RETURN
+END SUBROUTINE vlspltgen_loc
Index: LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,864 +1,0 @@
-!
-!     $Id$
-!
-      SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
-c
-c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
-c
-c    ********************************************************************
-c     Shema  d''advection " pseudo amont " .
-c    ********************************************************************
-c
-c   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL u_m( ijb_u:ije_u,llm )
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      REAL qsat(ijb_u:ije_u,llm)
-      INTEGER iq ! CRisi
-c
-c      Local 
-c   ---------
-c
-      INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju
-      INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
-c
-      REAL new_m,zu_m,zdum(ijb_u:ije_u,llm)
-      REAL dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
-      REAL zz(ijb_u:ije_u)
-      REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
-      REAL u_mq(ijb_u:ije_u,llm)
-      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      INTEGER ifils,iq2 ! CRisi
-
-
-      REAL      SSUM
-
-
-      INTEGER ijb,ije,ijb_x,ije_x
-      
-      !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
-!     &   iq,ijb_x
-
-c   calcul de la pente a droite et a gauche de la maille
-
-c      ijb=ij_begin
-c      ije=ij_end
-
-      ijb=ijb_x
-      ije=ije_x
-        
-      if (pole_nord.and.ijb==1) ijb=ijb+iip1
-      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
-      
-      IF (pente_max.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,iq)-q(ij,l,iq)
-            ENDDO
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqu(ij)=dxqu(ij-iim)
-c              sigu(ij)=sigu(ij-iim)
-            ENDDO
-
-            DO ij=ijb,ije
-               adxqu(ij)=abs(dxqu(ij))
-            ENDDO
-
-c   calcul de la pente maximum dans la maille en valeur absolue
-
-            DO ij=ijb+1,ije
-               dxqmax(ij,l)=pente_max*
-     ,      min(adxqu(ij-1),adxqu(ij))
-c limitation subtile
-c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
-          
-
-            ENDDO
-
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqmax(ij-iim,l)=dxqmax(ij,l)
-            ENDDO
-
-            DO ij=ijb+1,ije
-#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,iq)-q(ij,l,iq)
-            ENDDO
-            DO ij=ijb+iip1-1,ije,iip1
-               dxqu(ij)=dxqu(ij-iim)
-            ENDDO
-
-            DO ij=ijb+1,ije
-               zz(ij)=dxqu(ij-1)*dxqu(ij)
-               zz(ij)=zz(ij)+zz(ij)
-               IF(zz(ij).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,iq),
-     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
-     ,                     u_m(ij,l))
-          zdum(ij,l)=0.5*zdum(ij,l)
-          u_mq(ij,l)=cvmgp(
-     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
-     ,                q(ij+1,l,iq)-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,iq)
-             u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
-          ELSE
-             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
-             u_mq(ij,l)=u_m(ij,l)*
-     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
-          ENDIF
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-#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 necessaire
-cym      IF(n0.gt.1) THEN
-cym        IF(n0.gt.0) THEN
-ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
-ccc     &       ,'contenu de la maille : ',n0
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO l=1,llm
-            IF(nl(l).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
-               !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
-
-c  traitement des mailles
-               DO iju=1,niju
-                  ij=indu(iju)
-                  j=(ij-1)/iip1+1
-                  zu_m=u_m(ij,l)
-                  u_mq(ij,l)=0.
-                  IF(zu_m.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,iq))
-                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
-     &                     *masse(ijq,l,iq) 
-                        zu_m=zu_m-masse(ijq,l,iq)
-                        i=mod(i-2+iim,iim)+1
-                        ijq=(j-1)*iip1+i
-                     ENDDO
-c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)
-     &                 +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
-                  ELSE
-                     ijq=ij+1
-                     i=ijq-(j-1)*iip1
-c   accumulation pour les mailles completements advectees
-                     do while(-zu_m.gt.masse(ijq,l,iq))
-                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
-     &                   *masse(ijq,l,iq)
-                        zu_m=zu_m+masse(ijq,l,iq)
-                        i=mod(i,iim)+1
-                        ijq=(j-1)*iip1+i
-                     ENDDO
-c   ajout de la maille non completement advectee
-                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
-     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
-                  ENDIF
-               ENDDO
-            ENDIF
-         ENDDO
-c$OMP END DO NOWAIT
-cym      ENDIF  ! n0.gt.0 
-
-
-
-c   bouclage en latitude
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        DO ij=ijb+iip1-1,ije,iip1
-           u_mq(ij,l)=u_mq(ij-iim,l)
-        ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! CRisi: appel recursif de l'advection sur les fils.
-! Il faut faire ca avant d'avoir mis a jour q et masse
-      !write(*,*) 'vlspltqs 336: iq,ijb_x,nqChildren(iq)=',
-!     &     iq,ijb_x,tracers(iq)%nqChildren
-
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          DO ij=ijb,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-            if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio
-            endif 
-          enddo   
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
-        call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
-      enddo
-! end CRisi
-
-      !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x   
-
-c   calcul des tendances
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-         DO ij=ijb+1,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
-     &      u_mq(ij-1,l)-u_mq(ij,l))
-     &      /new_m
-            masse(ij,l,iq)=new_m
-         ENDDO
-c   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
-         DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l,iq)=q(ij,l,iq)
-            masse(ij-iim,l,iq)=masse(ij,l,iq)
-         ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-      !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          DO ij=ijb+1,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
-          enddo
-          DO ij=ijb+iip1-1,ije,iip1
-            q(ij-iim,l,iq2)=q(ij,l,iq2)
-          enddo ! DO ij=ijb+iip1-1,ije,iip1
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-      !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
-
-c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
-c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
-
-
-      RETURN
-      END
-      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
-c
-c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
-c
-c    ********************************************************************
-c     Shema  d'advection " pseudo amont " .
-c    ********************************************************************
-c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
-c     qsat                est   un argument de sortie pour le s-pg ....
-c
-c
-c   --------------------------------------------------------------------
-      USE parallel_lmdz
-      USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
-     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
-      USE comconst_mod, ONLY: pi
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "iniprint.h"  
-c
-c
-c   Arguments:
-c   ----------
-      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
-      REAL masse_adv_v( ijb_v:ije_v,llm)
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      REAL qsat(ijb_u:ije_u,llm)
-      INTEGER iq ! CRisi
-c
-c      Local 
-c   ---------
-c
-      INTEGER i,ij,l
-c
-      REAL airej2,airejjm,airescb(iim),airesch(iim)
-      REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
-      REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
-      REAL qbyv(ijb_v:ije_v,llm,nqtot)
-
-      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
-c     REAL newq,oldmasse
-      Logical first
-      SAVE first
-c$OMP THREADPRIVATE(first)
-      REAL convpn,convps,convmpn,convmps
-      REAL sinlon(iip1),sinlondlon(iip1)
-      REAL coslon(iip1),coslondlon(iip1)
-      SAVE sinlon,coslon,sinlondlon,coslondlon
-      SAVE airej2,airejjm
-c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
-c$OMP THREADPRIVATE(airej2,airejjm)
-c
-c
-      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
-      INTEGER ifils,iq2 ! CRisi
-
-      REAL      SSUM
-
-      DATA first/.true./
-      INTEGER ijb,ije
-      INTEGER ijbm,ijem
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1  
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
-      ij=3525
-      l=3
-      if ((ij.ge.ijb).and.(ij.le.ije)) then
-        !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
-!     &             ij,l,iq,ijb,q(ij,l,:)
-      endif  
-
-      IF(first) THEN
-         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
-         PRINT*,'vlyqs_loc, iq=',iq
-         first=.false.
-         do i=2,iip1
-            coslon(i)=cos(rlonv(i))
-            sinlon(i)=sin(rlonv(i))
-            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
-            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
-         ENDDO
-         coslon(1)=coslon(iip1)
-         coslondlon(1)=coslondlon(iip1)
-         sinlon(1)=sinlon(iip1)
-         sinlondlon(1)=sinlondlon(iip1)
-         airej2 = SSUM( iim, aire(iip2), 1 )
-         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
-      ENDIF
-
-c
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l = 1, llm
-c
-c   --------------------------------
-c      CALCUL EN LATITUDE
-c   --------------------------------
-
-c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
-c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
-c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
-
-      if (pole_nord) then
-        DO i = 1, iim
-          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
-        ENDDO
-        qpns   = SSUM( iim,  airescb ,1 ) / airej2
-      endif
-      
-      if (pole_sud) then
-        DO i = 1, iim
-          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
-        ENDDO
-        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
-      endif
-
-
-c   calcul des pentes aux points v
-
-      ijb=ij_begin-2*iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij=ijb,ije
-         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
-         adyqv(ij)=abs(dyqv(ij))
-      ENDDO
-
-
-c   calcul des pentes aux points scalaires
-
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      
-      DO ij=ijb,ije
-         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
-         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
-         dyqmax(ij)=pente_max*dyqmax(ij)
-      ENDDO
-      
-      IF (pole_nord) THEN
-
-c   calcul des pentes aux poles
-        DO ij=1,iip1
-           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
-        ENDDO
-
-c   filtrage de la derivee        
-        dyn1=0.
-        dyn2=0.
-        DO ij=1,iim
-          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
-          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
-        ENDDO
-        DO ij=1,iip1
-          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
-        ENDDO
-
-c   calcul des pentes limites aux poles
-        fn=1.
-        DO ij=1,iim
-          IF(pente_max*adyqv(ij).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,iq)-qpsn
-        ENDDO
-
-        dys1=0.
-        dys2=0.
-
-        DO ij=1,iim
-          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
-          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
-        ENDDO
-
-        DO ij=1,iip1
-          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
-        ENDDO
-        
-c   calcul des pentes limites aux poles        
-        fs=1.
-        DO ij=1,iim
-        IF(pente_max*adyqv(ij+ip1jm-iip1).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     appn=abs(dyq(1)/dyqv(iip1+1))
-C     PRINT*,dyq(ip1jm+1)
-C     PRINT*,dyqv(ip1jm-iip1+1)
-C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
-C     DO ij=2,iim
-C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
-C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
-C     ENDDO
-C     appn=min(pente_max/appn,1.)
-C     apps=min(pente_max/apps,1.)
-C
-C
-C   cas ou on a un extremum au pole
-C
-C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
-C    &   appn=0.
-C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
-C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
-C    &   apps=0.
-C
-C   limitation des pentes aux poles
-C     DO ij=1,iip1
-C        dyq(ij)=appn*dyq(ij)
-C        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
-C     ENDDO
-C
-C   test
-C      DO ij=1,iip1
-C         dyq(iip1+ij)=0.
-C         dyq(ip1jm+ij-iip1)=0.
-C      ENDDO
-C      DO ij=1,ip1jmp1
-C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
-C      ENDDO
-C
-C changement 10 07 96
-C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
-C    &   THEN
-C        DO ij=1,iip1
-C           dyqmax(ij)=0.
-C        ENDDO
-C     ELSE
-C        DO ij=1,iip1
-C           dyqmax(ij)=pente_max*abs(dyqv(ij))
-C        ENDDO
-C     ENDIF
-C
-C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
-C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
-C    &THEN
-C        DO ij=ip1jm+1,ip1jmp1
-C           dyqmax(ij)=0.
-C        ENDDO
-C     ELSE
-C        DO ij=ip1jm+1,ip1jmp1
-C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
-C        ENDDO
-C     ENDIF
-C   fin changement 10 07 96
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
-c   calcul des pentes limitees
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-      DO ij=ijb,ije
-         IF(dyqv(ij)*dyqv(ij-iip1).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,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
-     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
-     ,      /masse(ij+iip1,l,iq)))
-         ELSE
-              qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
-     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
-         ENDIF
-          qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
-       ENDDO
-      ENDDO
-c$OMP END DO NOWAIT
-
-! CRisi: appel recursif de l'advection sur les fils.
-! Il faut faire ca avant d'avoir mis a jour q et masse
-!     write(*,*)'vlyqs 689: iq,nqChildren(iq)=',iq,
-!    &             tracers(iq)%nqChildren
-      
-      ijb=ij_begin-2*iip1
-      ije=ij_end+2*iip1
-      ijbm=ij_begin-iip1
-      ijem=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end  
-      if (pole_nord) ijbm=ij_begin
-      if (pole_sud)  ijem=ij_end
-
-      !write(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
-      !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
-      !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          ! modif des bornes: CRisi 16 nov 2020
-          ! d'abord masse avec bornes corrigees
-          DO ij=ijbm,ijem 
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
-          enddo !DO ij=ijbm,ijem 
-
-          ! ensuite Ratio avec anciennes bornes
-          DO ij=ijb,ije
-            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
-            !write(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
-            if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
-              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
-            else
-              Ratio(ij,l,iq2)=min_ratio   
-            endif
-          enddo !DO ij=ijbm,ijem
-        enddo !DO l=1,llm
-c$OMP END DO NOWAIT
-      enddo
-      do ifils=1,tracers(iq)%nqChildren
-        iq2=tracers(iq)%iqDescen(ifils)
-        !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
-        call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
-      enddo
-
-        
-! end CRisi
-
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l=1,llm
-         DO ij=ijb,ije
-            newmasse=masse(ij,l,iq)
-     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
-            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq)
-     &         -qbyv(ij-iip1,l,iq))/newmasse
-            masse(ij,l,iq)=newmasse
-         ENDDO
-c.-. ancienne version
-
-         IF (pole_nord) THEN
-
-           convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
-           convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
-           DO ij = 1,iip1
-              newmasse=masse(ij,l,iq)+convmpn*aire(ij)
-              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
-     &                 newmasse
-              masse(ij,l,iq)=newmasse
-           ENDDO
-         
-         ENDIF
-         
-         IF (pole_sud) THEN
-         
-           convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),1)/apols
-           convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
-           DO ij = ip1jm+1,ip1jmp1
-              newmasse=masse(ij,l,iq)+convmps*aire(ij)
-              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
-     &                 newmasse
-              masse(ij,l,iq)=newmasse
-           ENDDO
-         
-         ENDIF
-c.-. fin ancienne version
-
-c._. nouvelle version
-c        convpn=SSUM(iim,qbyv(1,l,iq),1)
-c        convmpn=ssum(iim,masse_adv_v(1,l),1)
-c        oldmasse=ssum(iim,masse(1,l,iq),1)
-c        newmasse=oldmasse+convmpn
-c        newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
-c        newmasse=newmasse/apoln
-c        DO ij = 1,iip1
-c           q(ij,l,iq)=newq
-c           masse(ij,l,iq)=newmasse*aire(ij)
-c        ENDDO
-c        convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
-c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
-c        oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
-c        newmasse=oldmasse+convmps
-c        newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
-c        newmasse=newmasse/apols
-c        DO ij = ip1jm+1,ip1jmp1
-c           q(ij,l,iq)=newq
-c           masse(ij,l,iq)=newmasse*aire(ij)
-c        ENDDO
-c._. fin nouvelle version
-      ENDDO
-c$OMP END DO NOWAIT
-
-! retablir les fils en rapport de melange par rapport a l'air:
-      ijb=ij_begin
-      ije=ij_end
-!      if (pole_nord) ijb=ij_begin+iip1
-!      if (pole_sud)  ije=ij_end-iip1
-  
-      do ifils=1,tracers(iq)%nqDescen
-        iq2=tracers(iq)%iqDescen(ifils)
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
-        DO l=1,llm
-          DO ij=ijb,ije
-            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)            
-          enddo
-        enddo
-c$OMP END DO NOWAIT
-      enddo
-
-
-      RETURN
-      END
Index: LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F90	(revision 5246)
@@ -0,0 +1,864 @@
+!
+! $Id$
+!
+SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d''advection " pseudo amont " .
+  !    ********************************************************************
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
+        min_qParent,min_qMass,min_ratio ! MVals et CRisi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
+  REAL :: u_m( ijb_u:ije_u,llm )
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: qsat(ijb_u:ije_u,llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l,j,i,iju,ijq,indu(ijnb_u),niju
+  INTEGER :: n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
+  !
+  REAL :: new_m,zu_m,zdum(ijb_u:ije_u,llm)
+  REAL :: dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
+  REAL :: zz(ijb_u:ije_u)
+  REAL :: adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
+  REAL :: u_mq(ijb_u:ije_u,llm)
+  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  INTEGER :: ifils,iq2 ! CRisi
+
+
+  REAL :: SSUM
+
+
+  INTEGER :: ijb,ije,ijb_x,ije_x
+
+  ! !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
+  ! &   iq,ijb_x
+
+  !   calcul de la pente a droite et a gauche de la maille
+
+  !  ijb=ij_begin
+  !  ije=ij_end
+
+  ijb=ijb_x
+  ije=ije_x
+
+  if (pole_nord.and.ijb==1) ijb=ijb+iip1
+  if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+
+  IF (pente_max.gt.-1.e-5) THEN
+  ! IF (pente_max.gt.10) THEN
+
+  !   calcul des pentes avec limitation, Van Leer scheme I:
+  !   -----------------------------------------------------
+
+  !   calcul de la pente aux points u
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        DO ij=ijb,ije-1
+           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
+        ENDDO
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqu(ij)=dxqu(ij-iim)
+           ! sigu(ij)=sigu(ij-iim)
+        ENDDO
+
+        DO ij=ijb,ije
+           adxqu(ij)=abs(dxqu(ij))
+        ENDDO
+
+  !   calcul de la pente maximum dans la maille en valeur absolue
+
+        DO ij=ijb+1,ije
+           dxqmax(ij,l)=pente_max* &
+                 min(adxqu(ij-1),adxqu(ij))
+  ! limitation subtile
+  !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+
+
+        ENDDO
+
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqmax(ij-iim,l)=dxqmax(ij,l)
+        ENDDO
+
+        DO ij=ijb+1,ije
+#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
+  !   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
+!$OMP END DO NOWAIT
+
+  ELSE ! (pente_max.lt.-1.e-5)
+
+  !   Pentes produits:
+  !   ----------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        DO ij=ijb,ije-1
+           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
+        ENDDO
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqu(ij)=dxqu(ij-iim)
+        ENDDO
+
+        DO ij=ijb+1,ije
+           zz(ij)=dxqu(ij-1)*dxqu(ij)
+           zz(ij)=zz(ij)+zz(ij)
+           IF(zz(ij).gt.0) THEN
+              dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+           ELSE
+  !   extremum local
+              dxq(ij,l)=0.
+           ENDIF
+        ENDDO
+
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDIF ! (pente_max.lt.-1.e-5)
+
+  !   bouclage de la pente en iip1:
+  !   -----------------------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb+iip1-1,ije,iip1
+        dxq(ij-iim,l)=dxq(ij,l)
+     ENDDO
+
+     DO ij=ijb,ije
+        iadvplus(ij,l)=0
+     ENDDO
+
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_nord) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      iadvplus(1:iip1,l)=0
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  if (pole_sud)  THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      iadvplus(ip1jm+1:ip1jmp1,l)=0
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  !   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+  !--pas encore modification sur Qsat
+!$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,iq), &
+            1.+u_m(ij,l)/masse(ij+1,l,iq), &
+            u_m(ij,l))
+      zdum(ij,l)=0.5*zdum(ij,l)
+      u_mq(ij,l)=cvmgp( &
+            q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), &
+            q(ij+1,l,iq)-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
+!$OMP END DO NOWAIT
+
+#else
+  !   on cumule le flux correspondant a toutes les mailles dont la masse
+  !   au travers de la paroi pENDant le pas de temps.
+  !   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije-1
+      IF (u_m(ij,l).gt.0.) THEN
+         zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
+         u_mq(ij,l)=u_m(ij,l)* &
+               min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+      ELSE
+         zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
+         u_mq(ij,l)=u_m(ij,l)* &
+               min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+      ENDIF
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+#endif
+
+
+  !   detection des points ou on advecte plus que la masse de la
+  !   maille
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije-1
+        IF(zdum(ij,l).lt.0) THEN
+           iadvplus(ij,l)=1
+           u_mq(ij,l)=0.
+        ENDIF
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb+iip1-1,ije,iip1
+      iadvplus(ij,l)=iadvplus(ij-iim,l)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+
+
+  !   traitement special pour le cas ou on advecte en longitude plus que le
+  !   contenu de la maille.
+  !   cette partie est mal vectorisee.
+
+  !   pas d'influence de la pression saturante (pour l'instant)
+
+  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+  n0=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     nl(l)=0
+     DO ij=ijb,ije
+        nl(l)=nl(l)+iadvplus(ij,l)
+     ENDDO
+     n0=n0+nl(l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !ym ATTENTION ICI en OpenMP reduction pas forcement necessaire
+  !ym      IF(n0.gt.1) THEN
+  !ym        IF(n0.gt.0) THEN
+  !cc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+  !cc     &       ,'contenu de la maille : ',n0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llm
+        IF(nl(l).gt.0) THEN
+           iju=0
+  !   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
+           ! !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
+
+  !  traitement des mailles
+           DO iju=1,niju
+              ij=indu(iju)
+              j=(ij-1)/iip1+1
+              zu_m=u_m(ij,l)
+              u_mq(ij,l)=0.
+              IF(zu_m.gt.0.) THEN
+                 ijq=ij
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(zu_m.gt.masse(ijq,l,iq))
+                    u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) &
+                          *masse(ijq,l,iq)
+                    zu_m=zu_m-masse(ijq,l,iq)
+                    i=mod(i-2+iim,iim)+1
+                    ijq=(j-1)*iip1+i
+                 ENDDO
+  !   ajout de la maille non completement advectee
+                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq) &
+                       +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+              ELSE
+                 ijq=ij+1
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(-zu_m.gt.masse(ijq,l,iq))
+                    u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
+                          *masse(ijq,l,iq)
+                    zu_m=zu_m+masse(ijq,l,iq)
+                    i=mod(i,iim)+1
+                    ijq=(j-1)*iip1+i
+                 ENDDO
+  !   ajout de la maille non completement advectee
+                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
+                       0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+              ENDIF
+           ENDDO
+        ENDIF
+     ENDDO
+!$OMP END DO NOWAIT
+  !ym      ENDIF  ! n0.gt.0
+
+
+
+  !   bouclage en latitude
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb+iip1-1,ije,iip1
+       u_mq(ij,l)=u_mq(ij-iim,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! CRisi: appel recursif de l'advection sur les fils.
+  ! Il faut faire ca avant d'avoir mis a jour q et masse
+  ! !write(*,*) 'vlspltqs 336: iq,ijb_x,nqChildren(iq)=',
+  ! &     iq,ijb_x,tracers(iq)%nqChildren
+
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+        if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
+          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+        else
+          Ratio(ij,l,iq2)=min_ratio
+        endif
+      enddo
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+  do ifils=1,tracers(iq)%nqChildren
+    iq2=tracers(iq)%iqDescen(ifils)
+    ! !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
+    call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
+  enddo
+  ! end CRisi
+
+  ! !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x
+
+  !   calcul des tendances
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb+1,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
+        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
+              u_mq(ij-1,l)-u_mq(ij,l)) &
+              /new_m
+        masse(ij,l,iq)=new_m
+     ENDDO
+  !   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
+     DO ij=ijb+iip1-1,ije,iip1
+        q(ij-iim,l,iq)=q(ij,l,iq)
+        masse(ij-iim,l,iq)=masse(ij,l,iq)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb+1,ije
+        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+      enddo
+      DO ij=ijb+iip1-1,ije,iip1
+        q(ij-iim,l,iq2)=q(ij,l,iq2)
+      enddo ! DO ij=ijb+iip1-1,ije,iip1
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+
+  ! !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
+
+  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
+
+
+  RETURN
+END SUBROUTINE vlxqs_loc
+SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+  ! qsat                est   un argument de sortie pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
+        min_qParent,min_qMass,min_ratio ! MVals et CRisi
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
+  REAL :: masse_adv_v( ijb_v:ije_v,llm)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: qsat(ijb_u:ije_u,llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i,ij,l
+  !
+  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
+  REAL :: dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
+  REAL :: adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
+  REAL :: qbyv(ijb_v:ije_v,llm,nqtot)
+
+  REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+  ! REAL newq,oldmasse
+  Logical :: first
+  SAVE first
+!$OMP THREADPRIVATE(first)
+  REAL :: convpn,convps,convmpn,convmps
+  REAL :: sinlon(iip1),sinlondlon(iip1)
+  REAL :: coslon(iip1),coslondlon(iip1)
+  SAVE sinlon,coslon,sinlondlon,coslondlon
+  SAVE airej2,airejjm
+!$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+!$OMP THREADPRIVATE(airej2,airejjm)
+  !
+  !
+  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  INTEGER :: ifils,iq2 ! CRisi
+
+  REAL :: SSUM
+
+  DATA first/.true./
+  INTEGER :: ijb,ije
+  INTEGER :: ijbm,ijem
+
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  ij=3525
+  l=3
+  if ((ij.ge.ijb).and.(ij.le.ije)) then
+    ! !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
+  ! &             ij,l,iq,ijb,q(ij,l,:)
+  endif
+
+  IF(first) THEN
+     PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+     PRINT*,'vlyqs_loc, iq=',iq
+     first=.false.
+     do i=2,iip1
+        coslon(i)=cos(rlonv(i))
+        sinlon(i)=sin(rlonv(i))
+        coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+        sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+     ENDDO
+     coslon(1)=coslon(iip1)
+     coslondlon(1)=coslondlon(iip1)
+     sinlon(1)=sinlon(iip1)
+     sinlondlon(1)=sinlondlon(iip1)
+     airej2 = SSUM( iim, aire(iip2), 1 )
+     airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
+  ENDIF
+
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+  !
+  !   --------------------------------
+  !  CALCUL EN LATITUDE
+  !   --------------------------------
+
+  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+  if (pole_nord) then
+    DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+    ENDDO
+    qpns   = SSUM( iim,  airescb ,1 ) / airej2
+  endif
+
+  if (pole_sud) then
+    DO i = 1, iim
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
+    ENDDO
+    qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+  endif
+
+
+  !   calcul des pentes aux points v
+
+  ijb=ij_begin-2*iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+     dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
+     adyqv(ij)=abs(dyqv(ij))
+  ENDDO
+
+
+  !   calcul des pentes aux points scalaires
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+     dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+     dyqmax(ij)=pente_max*dyqmax(ij)
+  ENDDO
+
+  IF (pole_nord) THEN
+
+  !   calcul des pentes aux poles
+    DO ij=1,iip1
+       dyq(ij,l)=qpns-q(ij+iip1,l,iq)
+    ENDDO
+
+  !   filtrage de la derivee
+    dyn1=0.
+    dyn2=0.
+    DO ij=1,iim
+      dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+      dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+    ENDDO
+    DO ij=1,iip1
+      dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+    ENDDO
+
+  !   calcul des pentes limites aux poles
+    fn=1.
+    DO ij=1,iim
+      IF(pente_max*adyqv(ij).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,iq)-qpsn
+    ENDDO
+
+    dys1=0.
+    dys2=0.
+
+    DO ij=1,iim
+      dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+      dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+    ENDDO
+
+    DO ij=1,iip1
+      dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+    ENDDO
+
+  !   calcul des pentes limites aux poles
+    fs=1.
+    DO ij=1,iim
+    IF(pente_max*adyqv(ij+ip1jm-iip1).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
+
+
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !  En memoire de dIFferents tests sur la
+  !  limitation des pentes aux poles.
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  ! PRINT*,dyq(1)
+  ! PRINT*,dyqv(iip1+1)
+  ! appn=abs(dyq(1)/dyqv(iip1+1))
+  ! PRINT*,dyq(ip1jm+1)
+  ! PRINT*,dyqv(ip1jm-iip1+1)
+  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+  ! DO ij=2,iim
+  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+  ! ENDDO
+  ! appn=min(pente_max/appn,1.)
+  ! apps=min(pente_max/apps,1.)
+  !
+  !
+  !   cas ou on a un extremum au pole
+  !
+  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   appn=0.
+  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &   apps=0.
+  !
+  !   limitation des pentes aux poles
+  ! DO ij=1,iip1
+  !    dyq(ij)=appn*dyq(ij)
+  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+  ! ENDDO
+  !
+  !   test
+  !  DO ij=1,iip1
+  !     dyq(iip1+ij)=0.
+  !     dyq(ip1jm+ij-iip1)=0.
+  !  ENDDO
+  !  DO ij=1,ip1jmp1
+  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+  !  ENDDO
+  !
+  ! changement 10 07 96
+  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   THEN
+  !    DO ij=1,iip1
+  !       dyqmax(ij)=0.
+  !    ENDDO
+  ! ELSE
+  !    DO ij=1,iip1
+  !       dyqmax(ij)=pente_max*abs(dyqv(ij))
+  !    ENDDO
+  ! ENDIF
+  !
+  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &THEN
+  !    DO ij=ip1jm+1,ip1jmp1
+  !       dyqmax(ij)=0.
+  !    ENDDO
+  ! ELSE
+  !    DO ij=ip1jm+1,ip1jmp1
+  !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+  !    ENDDO
+  ! ENDIF
+  !   fin changement 10 07 96
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+  !   calcul des pentes limitees
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+     IF(dyqv(ij)*dyqv(ij-iip1).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
+!$OMP END DO NOWAIT
+
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije
+     IF( masse_adv_v(ij,l).GT.0. ) THEN
+       qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  + &
+             dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l) &
+             /masse(ij+iip1,l,iq)))
+     ELSE
+          qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) * &
+                0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
+     ENDIF
+      qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! CRisi: appel recursif de l'advection sur les fils.
+  ! Il faut faire ca avant d'avoir mis a jour q et masse
+  ! write(*,*)'vlyqs 689: iq,nqChildren(iq)=',iq,
+  !    &             tracers(iq)%nqChildren
+
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  ijbm=ij_begin-iip1
+  ijem=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  if (pole_nord) ijbm=ij_begin
+  if (pole_sud)  ijem=ij_end
+
+  ! !write(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
+  ! !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
+  ! !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      ! ! modif des bornes: CRisi 16 nov 2020
+      ! ! d'abord masse avec bornes corrigees
+      DO ij=ijbm,ijem
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+      enddo !DO ij=ijbm,ijem
+
+      ! ! ensuite Ratio avec anciennes bornes
+      DO ij=ijb,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        ! !write(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
+        if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
+          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+        else
+          Ratio(ij,l,iq2)=min_ratio
+        endif
+      enddo !DO ij=ijbm,ijem
+    enddo !DO l=1,llm
+!$OMP END DO NOWAIT
+  enddo
+  do ifils=1,tracers(iq)%nqChildren
+    iq2=tracers(iq)%iqDescen(ifils)
+    ! !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
+    call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
+  enddo
+
+
+  ! end CRisi
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        newmasse=masse(ij,l,iq) &
+              +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq) &
+              -qbyv(ij-iip1,l,iq))/newmasse
+        masse(ij,l,iq)=newmasse
+     ENDDO
+  !.-. ancienne version
+
+     IF (pole_nord) THEN
+
+       convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
+       convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+       DO ij = 1,iip1
+          newmasse=masse(ij,l,iq)+convmpn*aire(ij)
+          q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/ &
+                newmasse
+          masse(ij,l,iq)=newmasse
+       ENDDO
+
+     ENDIF
+
+     IF (pole_sud) THEN
+
+       convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),1)/apols
+       convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+       DO ij = ip1jm+1,ip1jmp1
+          newmasse=masse(ij,l,iq)+convmps*aire(ij)
+          q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/ &
+                newmasse
+          masse(ij,l,iq)=newmasse
+       ENDDO
+
+     ENDIF
+  !.-. fin ancienne version
+
+  !._. nouvelle version
+     ! convpn=SSUM(iim,qbyv(1,l,iq),1)
+     ! convmpn=ssum(iim,masse_adv_v(1,l),1)
+     ! oldmasse=ssum(iim,masse(1,l,iq),1)
+     ! newmasse=oldmasse+convmpn
+     ! newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
+     ! newmasse=newmasse/apoln
+     ! DO ij = 1,iip1
+     !    q(ij,l,iq)=newq
+     !    masse(ij,l,iq)=newmasse*aire(ij)
+     ! ENDDO
+     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
+     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+     ! oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
+     ! newmasse=oldmasse+convmps
+     ! newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
+     ! newmasse=newmasse/apols
+     ! DO ij = ip1jm+1,ip1jmp1
+     !    q(ij,l,iq)=newq
+     !    masse(ij,l,iq)=newmasse*aire(ij)
+     ! ENDDO
+  !._. fin nouvelle version
+  ENDDO
+!$OMP END DO NOWAIT
+
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  ijb=ij_begin
+  ije=ij_end
+   ! if (pole_nord) ijb=ij_begin+iip1
+   ! if (pole_sud)  ije=ij_end-iip1
+
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb,ije
+        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+      enddo
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+
+
+  RETURN
+END SUBROUTINE vlyqs_loc
Index: LMDZ6/trunk/libf/dyn3dmem/wrgrads.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/wrgrads.F	(revision 5214)
+++ 	(revision )
@@ -1,127 +1,0 @@
-!
-! $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,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)=trim(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))
-           CALL abort_gcm("wrgrads","problem",1)
-         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=trim(file)//'.ctl'
-     &         ,form='formatted',status='unknown')
-      write(unit(if),'(a5,1x,a40)')
-     &       'DSET ','^'//trim(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: LMDZ6/trunk/libf/dyn3dmem/wrgrads.f90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/wrgrads.f90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/wrgrads.f90	(revision 5246)
@@ -0,0 +1,127 @@
+!
+! $Header$
+!
+subroutine wrgrads(if,nl,field,name,titlevar)
+  implicit none
+
+  !   Declarations
+  !    if indice du fichier
+  !    nl nombre de couches
+  !    field   champ
+  !    name    petit nom
+  !    titlevar   Titre
+
+  INCLUDE "gradsdef.h"
+
+  !   arguments
+  integer :: if,nl
+  real :: field(imx*jmx*lmx)
+  character(len=10) :: name,file
+  character(len=10) :: titlevar
+
+  !   local
+
+  integer :: im,jm,lm,i,j,l,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)=trim(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))
+       CALL abort_gcm("wrgrads","problem",1)
+     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
+     ! print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+  !    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+  !    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+     write(unit(if)+1,rec=irec(if)) &
+           ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) &
+           ,i=iii,iif),j=iji,ijf)
+  enddo
+  if (writectl) then
+
+  file=fichier(if)
+  !   WARNING! on reecrase le fichier .ctl a chaque ecriture
+  open(unit(if),file=trim(file)//'.ctl' &
+        ,form='formatted',status='unknown')
+  write(unit(if),'(a5,1x,a40)') &
+        'DSET ','^'//trim(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)
+     ! print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+     ! 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'
+  !
+1000   format(a5,3x,i4,i3,1x,a39)
+
+  close(unit(if))
+
+  endif ! writectl
+
+  return
+
+END SUBROUTINE wrgrads
+
Index: LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,225 +1,0 @@
-!
-! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-!
-      subroutine writedynav_loc( time, vcov, ucov,teta,ppk,phi,q,
-     .                           masse,ps,phis)
-
-#ifdef CPP_IOIPSL
-! This routine needs IOIPSL
-      USE ioipsl
-#endif
-      USE parallel_lmdz
-      USE misc_mod
-      USE infotrac, ONLY : nqtot
-      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
-      USE comconst_mod, ONLY: cpp
-      USE temps_mod, ONLY: itau_dyn
-      
-      implicit none
-
-C
-C   Ecriture du fichier histoire au format IOIPSL
-C
-C   Appels succesifs des routines: histwrite
-C
-C   Entree:
-C      histid: ID du fichier histoire
-C      time: temps de l'ecriture
-C      vcov: vents v covariants
-C      ucov: vents u covariants
-C      teta: temperature potentielle
-C      phi : geopotentiel instantane
-C      q   : traceurs
-C      masse: masse
-C      ps   :pression au sol
-C      phis : geopotentiel au sol
-C      
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C
-C   Arguments
-C
-
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
-      REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-      REAL ppk(ijb_u:ije_u,llm)                  
-      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
-      REAL phis(ijb_u:ije_u)                  
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      integer time
-
-
-#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_v:ije_v,llm)) 
-        ALLOCATE(tm(ijb_u:ije_u,llm))
-        ALLOCATE(ndex2d(ijnb_u*llm))
-        ALLOCATE(ndexu(ijnb_u*llm))
-        ALLOCATE(ndexv(ijnb_v*llm))
-        ndex2d = 0
-        ndexu = 0
-        ndexv = 0
-!$OMP END MASTER
-!$OMP BARRIER
-        first=.FALSE.
-      ENDIF
-      
-      ok_sync = .TRUE.
-      itau_w = itau_dyn + time
-
-C Passage aux composantes naturelles du vent
-      call covnat_loc(llm, ucov, vcov, unat, vnat)
-
-C
-C  Appels a histwrite pour l'ecriture des variables a sauvegarder
-C
-C  Vents U
-C
-
-!$OMP BARRIER      
-!$OMP MASTER
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-      
-      call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), 
-     .               iip1*jjn*llm, ndexu)
-!$OMP END MASTER      
-
-C
-C  Vents V
-C
-      ije=ij_end
-      if (pole_sud) jjn=jj_nb-1
-      if (pole_sud) ije=ij_end-iip1
-!$OMP BARRIER
-!$OMP MASTER      
-      call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), 
-     .               iip1*jjn*llm, ndexv)
-!$OMP END MASTER      
-
-
-C
-C  Temperature potentielle moyennee
-C
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-!$OMP MASTER      
-      call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), 
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER      
-
-C
-C  Temperature moyennee
-C
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      do ll=1,llm
-        do ii = ijb, ije
-          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-        enddo
-      enddo
-!$OMP ENDDO
-
-!$OMP MASTER      
-      call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), 
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Geopotentiel
-C
-!$OMP MASTER      
-      call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), 
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Traceurs
-C
-!!$OMP MASTER      
-!        DO iq=1,nqtot
-!          call histwrite(histaveid, tracers(iq)%longName, itau_w, &
-!     .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
-!        enddo
-!!$OMP END MASTER
-
-
-C
-C  Masse
-C
-!$OMP MASTER      
-       call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Pression au sol
-C
-!$OMP MASTER      
-
-       call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), 
-     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Geopotentiel au sol
-C
-!$OMP MASTER      
-!       call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
-!     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Fin
-C
-!$OMP MASTER      
-      if (ok_sync) then
-          call histsync(histaveid)
-          call histsync(histvaveid)
-          call histsync(histuaveid)
-      ENDIF
-!$OMP END MASTER
-#else
-      write(lunout,*)'writedynav_loc: Needs IOIPSL to function'
-#endif
-! #endif of #ifdef CPP_IOIPSL
-      end
Index: LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F90	(revision 5246)
@@ -0,0 +1,225 @@
+!
+! $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_lmdz
+  USE misc_mod
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
+
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  call covnat_loc(llm, ucov, vcov, unat, vnat)
+
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+
+  call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+
+
+  !
+  !  Temperature potentielle moyennee
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Temperature moyennee
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
+!$OMP ENDDO
+
+!$OMP MASTER
+  call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      call histwrite(histaveid, tracers(iq)%longName, itau_w, &
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+
+
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+
+   call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+      call histsync(histaveid)
+      call histsync(histvaveid)
+      call histsync(histuaveid)
+  ENDIF
+!$OMP END MASTER
+#else
+  write(lunout,*)'writedynav_loc: Needs IOIPSL to function'
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine writedynav_loc
Index: LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F	(revision 5214)
+++ 	(revision )
@@ -1,224 +1,0 @@
-!
-! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-!
-      subroutine writehist_loc( time, vcov, ucov,teta,ppk,phi,q,
-     .                          masse,ps,phis)
-
-#ifdef CPP_IOIPSL
-! This routine needs IOIPSL
-      USE ioipsl
-#endif
-      USE parallel_lmdz
-      USE misc_mod
-      USE infotrac, ONLY : nqtot
-      use com_io_dyn_mod, only : histid,histvid,histuid
-      USE comconst_mod, ONLY: cpp
-      USE temps_mod, ONLY: itau_dyn
-      
-      implicit none
-
-C
-C   Ecriture du fichier histoire au format IOIPSL
-C
-C   Appels succesifs des routines: histwrite
-C
-C   Entree:
-C      histid: ID du fichier histoire
-C      time: temps de l'ecriture
-C      vcov: vents v covariants
-C      ucov: vents u covariants
-C      teta: temperature potentielle
-C      phi : geopotentiel instantane
-C      q   : traceurs
-C      masse: masse
-C      ps   :pression au sol
-C      phis : geopotentiel au sol
-C      
-C
-C   Sortie:
-C      fileid: ID du fichier netcdf cree
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-C
-C   Arguments
-C
-
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
-      REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-      REAL ppk(ijb_u:ije_u,llm)                  
-      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
-      REAL phis(ijb_u:ije_u)                  
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      integer time
-
-
-#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_v:ije_v,llm)) 
-        ALLOCATE(tm(ijb_u:ije_u,llm))
-        ALLOCATE(ndex2d(ijnb_u*llm))
-        ALLOCATE(ndexu(ijnb_u*llm))
-        ALLOCATE(ndexv(ijnb_v*llm))
-        ndex2d = 0
-        ndexu = 0
-        ndexv = 0
-!$OMP END MASTER
-!$OMP BARRIER
-        first=.FALSE.
-      ENDIF
-      
-      ok_sync = .TRUE.
-      itau_w = itau_dyn + time
-
-C Passage aux composantes naturelles du vent
-      call covnat_loc(llm, ucov, vcov, unat, vnat)
-
-C
-C  Appels a histwrite pour l'ecriture des variables a sauvegarder
-C
-C  Vents U
-C
-
-!$OMP BARRIER      
-!$OMP MASTER
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-      
-      call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), 
-     .               iip1*jjn*llm, ndexu)
-!$OMP END MASTER      
-
-C
-C  Vents V
-C
-      ije=ij_end
-      if (pole_sud) jjn=jj_nb-1
-      if (pole_sud) ije=ij_end-iip1
-!$OMP BARRIER
-!$OMP MASTER      
-      call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), 
-     .               iip1*jjn*llm, ndexv)
-!$OMP END MASTER      
-
-
-C
-C  Temperature potentielle
-C
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-!$OMP MASTER      
-      call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), 
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER      
-
-C
-C  Temperature
-C
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      do ll=1,llm
-        do ii = ijb, ije
-          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-        enddo
-      enddo
-!$OMP ENDDO
-
-!$OMP MASTER      
-      call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), 
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Geopotentiel
-C
-!$OMP MASTER      
-      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Traceurs
-C
-!!$OMP MASTER      
-!        DO iq=1,nqtot
-!          call histwrite(histid, tracers(iq)%longName, itau_w, 
-!     .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
-!        enddo
-!!$OMP END MASTER
-
-
-C
-C  Masse
-C
-!$OMP MASTER      
-       call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:),
-     .                iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-C
-C  Pression au sol
-C
-!$OMP MASTER      
-       call histwrite(histid, 'ps', itau_w, ps(ijb:ije), 
-     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Geopotentiel au sol
-C
-!$OMP MASTER      
-!       call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
-!     .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-C
-C  Fin
-C
-!$OMP MASTER      
-      if (ok_sync) then
-        call histsync(histid)
-        call histsync(histvid)
-        call histsync(histuid)
-      endif
-!$OMP END MASTER
-#else
-      write(lunout,*)'writehist_loc: Needs IOIPSL to function'
-#endif
-! #endif of #ifdef CPP_IOIPSL
-      end
Index: LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F90
===================================================================
--- LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F90	(revision 5246)
+++ LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F90	(revision 5246)
@@ -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_lmdz
+  USE misc_mod
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histid,histvid,histuid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
+
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  call covnat_loc(llm, ucov, vcov, unat, vnat)
+
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+
+  call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+
+
+  !
+  !  Temperature potentielle
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Temperature
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
+!$OMP ENDDO
+
+!$OMP MASTER
+  call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      call histwrite(histid, tracers(iq)%longName, itau_w,
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+
+
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+   call histwrite(histid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+    call histsync(histid)
+    call histsync(histvid)
+    call histsync(histuid)
+  endif
+!$OMP END MASTER
+#else
+  write(lunout,*)'writehist_loc: Needs IOIPSL to function'
+#endif
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine writehist_loc
