Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/arth.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/arth.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/arth.F90	(revision 222)
@@ -0,0 +1,82 @@
+MODULE arth_m
+
+  IMPLICIT NONE
+
+  INTEGER, PARAMETER, private:: NPAR_ARTH=16, NPAR2_ARTH=8
+
+  INTERFACE arth
+     ! Returns an arithmetic progression, given a first term "first", an
+     ! increment and a number of terms "n".
+
+     MODULE PROCEDURE arth_r, arth_i
+     ! The difference between the procedures is the type of
+     ! arguments "first" and "increment" and of function result.
+  END INTERFACE
+
+  private arth_r, arth_i
+
+CONTAINS
+
+  pure FUNCTION arth_r(first,increment,n)
+
+    REAL, INTENT(IN) :: first,increment
+    INTEGER, INTENT(IN) :: n
+    REAL, DIMENSION(n) :: arth_r
+
+    ! Variables local to the procedure:
+
+    INTEGER :: k,k2
+    REAL :: temp
+
+    !---------------------------------------
+
+    if (n > 0) arth_r(1)=first
+    if (n <= NPAR_ARTH) then
+       do k=2,n
+          arth_r(k)=arth_r(k-1)+increment
+       end do
+    else
+       do k=2,NPAR2_ARTH
+          arth_r(k)=arth_r(k-1)+increment
+       end do
+       temp=increment*NPAR2_ARTH
+       k=NPAR2_ARTH
+       do
+          if (k >= n) exit
+          k2=k+k
+          arth_r(k+1:min(k2,n)) = temp + arth_r(1:min(k,n-k))
+          temp=temp+temp
+          k=k2
+       end do
+    end if
+  END FUNCTION arth_r
+
+  !*************************************
+
+  pure FUNCTION arth_i(first,increment,n)
+
+    INTEGER, INTENT(IN) :: first,increment,n
+    INTEGER, DIMENSION(n) :: arth_i
+    INTEGER :: k,k2,temp
+    if (n > 0) arth_i(1)=first
+    if (n <= NPAR_ARTH) then
+       do k=2,n
+          arth_i(k)=arth_i(k-1)+increment
+       end do
+    else
+       do k=2,NPAR2_ARTH
+          arth_i(k)=arth_i(k-1)+increment
+       end do
+       temp=increment*NPAR2_ARTH
+       k=NPAR2_ARTH
+       do
+          if (k >= n) exit
+          k2=k+k
+          arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k))
+          temp=temp+temp
+          k=k2
+       end do
+    end if
+  END FUNCTION arth_i
+
+END MODULE arth_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/assert_eq_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/assert_eq_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/assert_eq_m.F90	(revision 222)
@@ -0,0 +1,70 @@
+! $Id$
+MODULE assert_eq_m
+
+  implicit none
+
+  INTERFACE assert_eq
+     MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
+  END INTERFACE
+
+  private assert_eq2,assert_eq3,assert_eq4,assert_eqn
+
+CONTAINS
+
+  FUNCTION assert_eq2(n1,n2,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2
+    INTEGER  assert_eq2
+    if (n1 == n2) then
+       assert_eq2=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eq2'
+       stop 1
+    end if
+  END FUNCTION assert_eq2
+  !BL
+  FUNCTION assert_eq3(n1,n2,n3,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2,n3
+    INTEGER  assert_eq3
+    if (n1 == n2 .and. n2 == n3) then
+       assert_eq3=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eq3'
+       stop 1
+    end if
+  END FUNCTION assert_eq3
+  !BL
+  FUNCTION assert_eq4(n1,n2,n3,n4,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2,n3,n4
+    INTEGER  assert_eq4
+    if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
+       assert_eq4=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string,n1,n2,n3,n4
+       print *, 'program terminated by assert_eq4'
+       stop 1
+    end if
+  END FUNCTION assert_eq4
+  !BL
+  FUNCTION assert_eqn(nn,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, DIMENSION(:), INTENT(IN) :: nn
+    INTEGER  assert_eqn
+    if (all(nn(2:) == nn(1))) then
+       assert_eqn=nn(1)
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eqn'
+       stop 1
+    end if
+  END FUNCTION assert_eqn
+
+END MODULE assert_eq_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/assert_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/assert_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/assert_m.F90	(revision 222)
@@ -0,0 +1,69 @@
+! $Id$
+MODULE assert_m
+
+  implicit none
+
+  INTERFACE assert
+     MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v
+  END INTERFACE
+
+  private assert1,assert2,assert3,assert4,assert_v
+
+CONTAINS
+
+  SUBROUTINE assert1(n1,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1
+    if (.not. n1) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert1'
+       stop 1
+    end if
+  END SUBROUTINE assert1
+  !BL
+  SUBROUTINE assert2(n1,n2,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2
+    if (.not. (n1 .and. n2)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert2'
+       stop 1
+    end if
+  END SUBROUTINE assert2
+  !BL
+  SUBROUTINE assert3(n1,n2,n3,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2,n3
+    if (.not. (n1 .and. n2 .and. n3)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert3'
+       stop 1
+    end if
+  END SUBROUTINE assert3
+  !BL
+  SUBROUTINE assert4(n1,n2,n3,n4,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2,n3,n4
+    if (.not. (n1 .and. n2 .and. n3 .and. n4)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert4'
+       stop 1
+    end if
+  END SUBROUTINE assert4
+  !BL
+  SUBROUTINE assert_v(n,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, DIMENSION(:), INTENT(IN) :: n
+    if (.not. all(n)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert_v'
+       stop 1
+    end if
+  END SUBROUTINE assert_v
+
+END MODULE assert_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/cbrt.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/cbrt.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/cbrt.F	(revision 222)
@@ -0,0 +1,9 @@
+      FUNCTION cbrt(x)
+      IMPLICIT NONE
+
+      REAL x,cbrt
+
+      cbrt=sign(1.,x)*(abs(x)**(1./3.))
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/chfev.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/chfev.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/chfev.F	(revision 222)
@@ -0,0 +1,155 @@
+*DECK CHFEV
+      SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
+C***BEGIN PROLOGUE  CHFEV
+C***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an
+C            array of points.  While designed for use by PCHFE, it may
+C            be useful directly as an evaluator for a piecewise cubic
+C            Hermite function in applications, such as graphing, where
+C            the interval is known in advance.
+C***LIBRARY   SLATEC (PCHIP)
+C***CATEGORY  E3
+C***TYPE      SINGLE PRECISION (CHFEV-S, DCHFEV-D)
+C***KEYWORDS  CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION,
+C             PCHIP
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C             Lawrence Livermore National Laboratory
+C             P.O. Box 808  (L-316)
+C             Livermore, CA  94550
+C             FTS 532-4275, (510) 422-4275
+C***DESCRIPTION
+C
+C          CHFEV:  Cubic Hermite Function EValuator
+C
+C     Evaluates the cubic polynomial determined by function values
+C     F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points
+C     XE(J), J=1(1)NE.
+C
+C ----------------------------------------------------------------------
+C
+C  Calling sequence:
+C
+C        INTEGER  NE, NEXT(2), IERR
+C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE)
+C
+C        CALL  CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR)
+C
+C   Parameters:
+C
+C     X1,X2 -- (input) endpoints of interval of definition of cubic.
+C           (Error return if  X1.EQ.X2 .)
+C
+C     F1,F2 -- (input) values of function at X1 and X2, respectively.
+C
+C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
+C
+C     NE -- (input) number of evaluation points.  (Error return if
+C           NE.LT.1 .)
+C
+C     XE -- (input) real array of points at which the function is to be
+C           evaluated.  If any of the XE are outside the interval
+C           [X1,X2], a warning error is returned in NEXT.
+C
+C     FE -- (output) real array of values of the cubic function defined
+C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
+C
+C     NEXT -- (output) integer array indicating number of extrapolation
+C           points:
+C            NEXT(1) = number of evaluation points to left of interval.
+C            NEXT(2) = number of evaluation points to right of interval.
+C
+C     IERR -- (output) error flag.
+C           Normal return:
+C              IERR = 0  (no errors).
+C           "Recoverable" errors:
+C              IERR = -1  if NE.LT.1 .
+C              IERR = -2  if X1.EQ.X2 .
+C                (The FE-array has not been changed in either case.)
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   811019  DATE WRITTEN
+C   820803  Minor cosmetic changes for release 1.
+C   890411  Added SAVE statements (Vers. 3.2).
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890703  Corrected category record.  (WRB)
+C   890703  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  CHFEV
+C  Programming notes:
+C
+C     To produce a double precision version, simply:
+C        a. Change CHFEV to DCHFEV wherever it occurs,
+C        b. Change the real declaration to double precision, and
+C        c. Change the constant ZERO to double precision.
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  NE, NEXT(2), IERR
+      REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*)
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  I
+      REAL  C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
+      SAVE ZERO
+      DATA  ZERO /0./
+C
+C  VALIDITY-CHECK ARGUMENTS.
+C
+C***FIRST EXECUTABLE STATEMENT  CHFEV
+      IF (NE .LT. 1)  GO TO 5001
+      H = X2 - X1
+      IF (H .EQ. ZERO)  GO TO 5002
+C
+C  INITIALIZE.
+C
+      IERR = 0
+      NEXT(1) = 0
+      NEXT(2) = 0
+      XMI = MIN(ZERO, H)
+      XMA = MAX(ZERO, H)
+C
+C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
+C
+      DELTA = (F2 - F1)/H
+      DEL1 = (D1 - DELTA)/H
+      DEL2 = (D2 - DELTA)/H
+C                                           (DELTA IS NO LONGER NEEDED.)
+      C2 = -(DEL1+DEL1 + DEL2)
+      C3 = (DEL1 + DEL2)/H
+C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
+C
+C  EVALUATION LOOP.
+C
+      DO 500  I = 1, NE
+         X = XE(I) - X1
+         FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
+C          COUNT EXTRAPOLATION POINTS.
+         IF ( X.LT.XMI )  NEXT(1) = NEXT(1) + 1
+         IF ( X.GT.XMA )  NEXT(2) = NEXT(2) + 1
+C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
+  500 CONTINUE
+C
+C  NORMAL RETURN.
+C
+      RETURN
+C
+C  ERROR RETURNS.
+C
+ 5001 CONTINUE
+C     NE.LT.1 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'CHFEV',
+     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
+      RETURN
+C
+ 5002 CONTINUE
+C     X1.EQ.X2 RETURN.
+      IERR = -2
+      CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR,
+     +   1)
+      RETURN
+C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/cray.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/cray.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/cray.F	(revision 222)
@@ -0,0 +1,42 @@
+!
+! $Header$
+!
+#ifdef CRAY
+      SUBROUTINE riencray
+      END
+#else
+      subroutine scopy(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      real sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+         sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
+
+      function ssum(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,i,ix
+      real ssum,sx((n-1)*incx+1)
+c
+      ssum=0.
+      ix=1
+      do 10 i=1,n
+         ssum=ssum+sx(ix)
+         ix=ix+incx
+10    continue
+c
+      return
+      end
+#endif
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/fdump.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/fdump.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/fdump.F	(revision 222)
@@ -0,0 +1,31 @@
+*DECK FDUMP
+      SUBROUTINE FDUMP
+C***BEGIN PROLOGUE  FDUMP
+C***PURPOSE  Symbolic dump (should be locally written).
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3
+C***TYPE      ALL (FDUMP-A)
+C***KEYWORDS  ERROR, XERMSG
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C        ***Note*** Machine Dependent Routine
+C        FDUMP is intended to be replaced by a locally written
+C        version which produces a symbolic dump.  Failing this,
+C        it should be replaced by a version which prints the
+C        subprogram nesting list.  Note that this dump must be
+C        printed on each of up to five files, as indicated by the
+C        XGETUA routine.  See XSETUA and XGETUA for details.
+C
+C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  FDUMP
+C***FIRST EXECUTABLE STATEMENT  FDUMP
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/formcoord.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/formcoord.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/formcoord.F	(revision 222)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      subroutine formcoord(unit,n,x,a,rev,text)
+      implicit none
+      integer n,unit,ndec
+      logical rev
+      real x(n),a
+      character*4 text
+
+      integer i,id,i1,i2,in
+      real dx,dxmin
+
+      if(rev) then
+         id=-1
+         i1=n
+         i2=n-1
+         in=1
+         write(unit,3000) text(1:1)
+      else
+         id=1
+         i1=1
+         i2=2
+         in=n
+      endif
+
+      if (n.lt.2) then
+         ndec=1
+         write(unit,1000) text,n,x(1)*a
+      else
+         dxmin=abs(x(2)-x(1))
+         do i=2,n-1
+            dx=abs(x(i+1)-x(i))
+            if (dx.lt.dxmin) dxmin=dx
+         enddo
+
+         ndec=-log10(dxmin)+2
+         if(mod(n,6).eq.1) then
+            write(unit,1000) text,n,x(i1)*a
+            write(unit,2000) (x(i)*a,i=i2,in,id)
+         else
+            write(unit,1000) text,n
+            write(unit,2000) (x(i)*a,i=i1,in,id)
+         endif
+      endif
+
+1000  format(a4,2x,i4,' LEVELS',43x,f12.2)
+2000  format(6f12.2)
+c1000  format(a4,2x,i4,' LEVELS',43x,f12.<ndec>)
+c2000  format(6f12.<ndec>)
+3000  format('FORMAT ',a1,'REV')
+      return
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/handle_err_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/handle_err_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/handle_err_m.F90	(revision 222)
@@ -0,0 +1,46 @@
+! $Id$
+module handle_err_m
+
+  implicit none
+
+contains
+
+  subroutine handle_err(message, ncerr, ncid, varid)
+
+    use netcdf, only: nf90_strerror, nf90_noerr, nf90_close
+
+    character(len=*), intent(in):: message
+    ! (should include name of calling procedure)
+
+    integer, intent(in):: ncerr
+
+    integer, intent(in), optional :: ncid
+    ! (Provide this argument if you want "handle_err" to try to close
+    ! the file.)
+
+    integer, intent(in), optional :: varid
+
+    ! Variable local to the procedure:
+    integer ncerr_close
+
+    !-------------------
+
+    if (ncerr /= nf90_noerr) then
+       print *, message, ":"
+       if (present(varid)) print *, "varid = ", varid
+       print *, trim(nf90_strerror(ncerr))
+       if (present(ncid)) then
+          ! Try to close, to leave the file in a consistent state:
+          ncerr_close = nf90_close(ncid)
+          ! (do not call "nf95_close", we do not want to recurse)
+          if (ncerr_close /= nf90_noerr) then
+             print *, "nf90_close:"
+             print *, trim(nf90_strerror(ncerr_close))
+          end if
+       end if
+       stop 1
+    end if
+
+  end subroutine handle_err
+
+end module handle_err_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/i1mach.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/i1mach.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/i1mach.F	(revision 222)
@@ -0,0 +1,126 @@
+*DECK I1MACH
+      INTEGER FUNCTION I1MACH (I)
+C***BEGIN PROLOGUE  I1MACH
+C***PURPOSE  Return integer machine dependent constants.
+C***LIBRARY   SLATEC
+C***CATEGORY  R1
+C***TYPE      INTEGER (I1MACH-I)
+C***KEYWORDS  MACHINE CONSTANTS
+C***AUTHOR  Fox, P. A., (Bell Labs)
+C           Hall, A. D., (Bell Labs)
+C           Schryer, N. L., (Bell Labs)
+C***DESCRIPTION
+C
+C   I1MACH can be used to obtain machine-dependent parameters for the
+C   local machine environment.  It is a function subprogram with one
+C   (input) argument and can be referenced as follows:
+C
+C        K = I1MACH(I)
+C
+C   where I=1,...,16.  The (output) value of K above is determined by
+C   the (input) value of I.  The results for various values of I are
+C   discussed below.
+C
+C   I/O unit numbers:
+C     I1MACH( 1) = the standard input unit.
+C     I1MACH( 2) = the standard output unit.
+C     I1MACH( 3) = the standard punch unit.
+C     I1MACH( 4) = the standard error message unit.
+C
+C   Words:
+C     I1MACH( 5) = the number of bits per integer storage unit.
+C     I1MACH( 6) = the number of characters per integer storage unit.
+C
+C   Integers:
+C     assume integers are represented in the S-digit, base-A form
+C
+C                sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
+C
+C                where 0 .LE. X(I) .LT. A for I=0,...,S-1.
+C     I1MACH( 7) = A, the base.
+C     I1MACH( 8) = S, the number of base-A digits.
+C     I1MACH( 9) = A**S - 1, the largest magnitude.
+C
+C   Floating-Point Numbers:
+C     Assume floating-point numbers are represented in the T-digit,
+C     base-B form
+C                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
+C
+C                where 0 .LE. X(I) .LT. B for I=1,...,T,
+C                0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
+C     I1MACH(10) = B, the base.
+C
+C   Single-Precision:
+C     I1MACH(11) = T, the number of base-B digits.
+C     I1MACH(12) = EMIN, the smallest exponent E.
+C     I1MACH(13) = EMAX, the largest exponent E.
+C
+C   Double-Precision:
+C     I1MACH(14) = T, the number of base-B digits.
+C     I1MACH(15) = EMIN, the smallest exponent E.
+C     I1MACH(16) = EMAX, the largest exponent E.
+C
+C   To alter this function for a particular environment, the desired
+C   set of DATA statements should be activated by removing the C from
+C   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
+C   checked for consistency with the local operating system.
+C
+C***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
+C                 a portable library, ACM Transactions on Mathematical
+C                 Software 4, 2 (June 1978), pp. 177-188.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   750101  DATE WRITTEN
+C   891012  Added VAX G-floating constants.  (WRB)
+C   891012  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900618  Added DEC RISC constants.  (WRB)
+C   900723  Added IBM RS 6000 constants.  (WRB)
+C   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
+C           (RWC)
+C   910710  Added HP 730 constants.  (SMR)
+C   911114  Added Convex IEEE constants.  (WRB)
+C   920121  Added SUN -r8 compiler option constants.  (WRB)
+C   920229  Added Touchstone Delta i860 constants.  (WRB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C   920625  Added Convex -p8 and -pd8 compiler option constants.
+C           (BKS, WRB)
+C   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
+C   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
+C           options.  (DWL, RWC and WRB).
+C   100623  Use Fortran 95 intrinsic functions (Lionel GUEZ)
+C***END PROLOGUE  I1MACH
+C
+      INTEGER IMACH(16),OUTPUT
+      SAVE IMACH
+      EQUIVALENCE (IMACH(4),OUTPUT)
+C***FIRST EXECUTABLE STATEMENT  I1MACH
+      IMACH( 1) =         5
+      IMACH( 2) =         6
+      IMACH( 3) =         6
+      IMACH( 4) =         6
+      IMACH( 5) =        bit_size(0)
+      IMACH( 6) =         IMACH( 5) / 8
+      IMACH( 7) =         radix(0)
+      IMACH( 8) =        digits(0)
+      IMACH( 9) =     huge(0)
+      IMACH(10) =         radix(0.)
+      IMACH(11) =        digits(0.)
+      IMACH(12) =      minexponent(0.)
+      IMACH(13) =       maxexponent(0.)
+      IMACH(14) =        digits(0d0)
+      IMACH(15) =      minexponent(0d0)
+      IMACH(16) =       maxexponent(0d0)
+      IF (I .LT. 1  .OR.  I .GT. 16) GO TO 10
+C
+      I1MACH = IMACH(I)
+      RETURN
+C
+   10 CONTINUE
+      WRITE (UNIT = OUTPUT, FMT = 9000)
+ 9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
+C
+C     CALL FDUMP
+C
+      STOP
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/initdynav.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/initdynav.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/initdynav.F90	(revision 222)
@@ -0,0 +1,194 @@
+! $Id: initdynav.F90 1611 2012-01-25 14:31:54Z lguez $
+
+subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
+
+#ifdef CPP_IOIPSL
+  USE IOIPSL
+#endif
+  USE infotrac, ONLY : nqtot, ttext
+  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, &
+       dynhistave_file,dynhistvave_file,dynhistuave_file
+  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:
+
+  !      infile: nom du fichier histoire a creer
+  !      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
+
+
+  !   L. Fairhead, LMD, 03/99
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comconst.h"
+  include "comvert.h"
+  include "comgeom.h"
+  include "temps.h"
+  include "ener.h"
+  include "logic.h"
+  include "description.h"
+  include "serre.h"
+  include "iniprint.h"
+
+  !   Arguments
+
+  integer day0, anne0
+  real tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+
+  integer tau0
+  real zjulian
+  integer iq
+  real rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer uhoriid, vhoriid, thoriid, zvertiid
+  integer ii,jj
+  integer zan, dayref
+
+  !--------------------------------------------------------------------
+
+  !  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       
+  call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
+       1, iip1, 1, jjp1, &
+       tau0, zjulian, tstep, thoriid,histaveid)
+
+  ! 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
+  do jj = 1, jjm
+     do ii = 1, iip1
+        rlong(ii,jj) = rlonv(ii) * 180. / pi
+        rlat(ii,jj) = rlatv(jj) * 180. / pi
+     enddo
+  enddo
+
+  call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:), &
+       1, iip1, 1, jjm, &
+       tau0, zjulian, tstep, vhoriid,histvaveid)
+  ! 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
+
+  call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:), &
+       1, iip1, 1, jjp1, &
+       tau0, zjulian, tstep, uhoriid,histuaveid)
+
+  !  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., zvertiid,'down')
+  call histvert(histvaveid,'presnivs','Niveaux Pression approximatifs','mb', &
+       llm, presnivs/100., zvertiid,'down')
+
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+  !  Vents U
+
+  call histdef(histuaveid, 'u', 'vent u moyen ', &
+       'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Vents V
+
+  call histdef(histvaveid, 'v', 'vent v moyen', &
+       'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+
+  !  Temperature
+
+  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Temperature potentielle
+
+  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Geopotentiel
+
+  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Traceurs
+
+  !        DO iq=1,nqtot
+  !          call histdef(histaveid, ttext(iq), ttext(iq), '-', &
+  !                  iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+  !                  32, 'ave(X)', t_ops, t_wrt)
+  !        enddo
+
+  !  Masse
+
+  call histdef(histaveid, 'masse', 'masse', 'kg', &
+       iip1, jjp1, 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, jjp1, thoriid, 1, 1, 1, -99, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Geopotentiel au sol
+
+  !      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-', &
+  !                  iip1, jjp1, thoriid, 1, 1, 1, -99, &
+  !                  32, 'ave(X)', t_ops, t_wrt)
+
+  call histend(histaveid)
+  call histend(histuaveid)
+  call histend(histvaveid)
+#else
+  write(lunout,*)"initdynav: Warning this routine should not be", &
+       " used without ioipsl"
+#endif
+  ! of #ifdef CPP_IOIPSL
+
+end subroutine initdynav
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/initfluxsto.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/initfluxsto.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/initfluxsto.F	(revision 222)
@@ -0,0 +1,233 @@
+!
+! $Id: initfluxsto.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine initfluxsto
+     .  (infile,tstep,t_ops,t_wrt,
+     .                    fileid,filevid,filedid)
+
+#ifdef CPP_IOIPSL
+       USE IOIPSL
+#endif
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep: duree du pas de temps en seconde
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C      filevid:ID du fichier netcdf pour la grille v
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL to work
+C   Variables locales
+C
+      real nivd(1)
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+      integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+      integer ii,jj
+      integer zan, idayref
+      logical ok_sync
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+      str='q  '
+      ctrac = 'traceur   '
+      ok_sync = .true.
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = annee_ref
+      idayref = day_ref
+      CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+      tau0 = itau_dyn
+	
+	do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+ 
+      call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, uhoriid, fileid)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  un meme fichier)
+
+
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:),
+     .             1, iip1, 1, jjm,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+	
+	rl(1,1) = 1.	
+      call histbeg('defstoke.nc', 1, rl, 1, rl,
+     .             1, 1, 1, 1,
+     .             tau0, zjulian, tstep, dhoriid, filedid)
+
+C
+C  Appel a histhori pour rajouter les autres grilles horizontales
+C
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar',
+     .              'Grille points scalaires', thoriid)
+	
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              llm, nivsigs, zvertiid)
+c pour le fichier def
+      nivd(1) = 1
+      call histvert(filedid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              1, nivd, dvertiid)
+
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+	
+	CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	CALL histdef(filedid, "dtvr", "tps dyn", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+        
+         CALL histdef(filedid, "istdyn", "tps stock", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         
+         CALL histdef(filedid, "istphy", "tps stock phy", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+
+C
+C Masse 
+C
+      call histdef(fileid, 'masse', 'Masse', 'kg',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pbaru 
+C
+      call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Pbarv 
+C
+      call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
+     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  w 
+C
+      call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C Geopotentiel 
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      call histend(filedid)
+      if (ok_sync) then
+        call histsync(fileid)
+        call histsync(filevid)
+        call histsync(filedid)
+      endif
+	
+#else
+! tell the user this routine should be run with ioipsl
+      write(lunout,*)"initfluxsto: Warning this routine should not be",
+     &               " used without ioipsl"
+#endif
+! of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/inithist.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/inithist.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/inithist.F	(revision 222)
@@ -0,0 +1,197 @@
+!
+! $Id: inithist.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      subroutine inithist(day0,anne0,tstep,t_ops,t_wrt)
+
+#ifdef CPP_IOIPSL
+       USE IOIPSL
+#endif
+       USE infotrac, ONLY : nqtot, ttext
+       use com_io_dyn_mod, only : histid,histvid,histuid,               &
+     &                        dynhist_file,dynhistv_file,dynhistu_file
+
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      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      nq: nombre de traceurs
+C
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      integer day0, anne0
+      real tstep, t_ops, t_wrt
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL to work
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, dayref
+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
+      
+! -------------------------------------------------------------
+! Creation des 3 fichiers pour les grilles horizontales U,V,Scal
+! -------------------------------------------------------------
+!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
+       
+      call histbeg(dynhistu_file, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, uhoriid, histuid)
+
+! Grille V
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histbeg(dynhistv_file, iip1, rlong(:,1), jjm, rlat(1,:),
+     .             1, iip1, 1, jjm,
+     .             tau0, zjulian, tstep, vhoriid, histvid)
+
+!Grille Scalaire
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histbeg(dynhist_file, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, thoriid, histid)
+! -------------------------------------------------------------
+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., zvertiid,'down')
+      call histvert(histuid, 'presnivs', 'Niveaux pression','mb',
+     .              llm, presnivs/100., zvertiid,'down')
+C
+! -------------------------------------------------------------
+C  Appels a histdef pour la definition des variables a sauvegarder
+! -------------------------------------------------------------
+C
+C  Vents U
+C
+      call histdef(histuid, 'u', 'vent u', 'm/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      call histdef(histvid, 'v', 'vent v', 'm/s',
+     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      call histdef(histid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Geopotentiel
+C
+      call histdef(histid, 'phi', 'geopotentiel', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+!
+!        DO iq=1,nqtot
+!          call histdef(histid, ttext(iq),  ttext(iq), '-',
+!     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+!     .             32, 'inst(X)', t_ops, t_wrt)
+!        enddo
+!C
+C  Masse
+C
+      call histdef(histid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, 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, jjp1, 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, jjp1, 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
+! tell the user this routine should be run with ioipsl
+      write(lunout,*)"inithist: Warning this routine should not be",
+     &               " used without ioipsl"
+#endif
+! of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/interpolation.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/interpolation.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/interpolation.F90	(revision 222)
@@ -0,0 +1,138 @@
+! $Id$
+module interpolation
+
+  ! From Press et al., 1996, version 2.10a
+  ! B3 Interpolation and Extrapolation
+
+  IMPLICIT NONE 
+
+contains
+
+  pure FUNCTION locate(xx,x)
+
+    REAL, DIMENSION(:), INTENT(IN) :: xx
+    REAL, INTENT(IN) :: x
+    INTEGER  locate
+
+    ! Given an array xx(1:N), and given a value x, returns a value j,
+    ! between 0 and N, such that x is between xx(j) and xx(j + 1). xx
+    ! must be monotonic, either increasing or decreasing. j = 0 or j =
+    ! N is returned to indicate that x is out of range. This
+    ! procedure should not be called with a zero-sized array argument.
+    ! See notes.
+
+    INTEGER  n,jl,jm,ju
+    LOGICAL  ascnd
+
+    !----------------------------
+
+    n=size(xx)
+    ascnd = (xx(n) >= xx(1))
+    ! (True if ascending order of table, false otherwise.)
+    ! Initialize lower and upper limits:
+    jl=0
+    ju=n+1
+    do while (ju-jl > 1)
+       jm=(ju+jl)/2 ! Compute a midpoint,
+       if (ascnd .eqv. (x >= xx(jm))) then
+          jl=jm ! and replace either the lower limit
+       else
+          ju=jm ! or the upper limit, as appropriate.
+       end if
+    end do
+    ! {ju == jl + 1}
+
+    ! {(ascnd .and. xx(jl) <= x < xx(jl+1)) 
+    !  .neqv. 
+    !  (.not. ascnd .and. xx(jl+1) <= x < xx(jl))}
+
+    ! Then set the output, being careful with the endpoints:
+    if (x == xx(1)) then
+       locate=1
+    else if (x == xx(n)) then
+       locate=n-1
+    else
+       locate=jl
+    end if
+
+  END FUNCTION locate
+
+  !***************************
+
+  pure SUBROUTINE hunt(xx,x,jlo)
+
+    ! Given an array xx(1:N ), and given a value x, returns a value
+    ! jlo such that x is between xx(jlo) and xx(jlo+1). xx must be
+    ! monotonic, either increasing or decreasing. jlo = 0 or jlo = N is
+    ! returned to indicate that x is out of range. jlo on input is taken as
+    ! the initial guess for jlo on output.
+    ! Modified so that it uses the information "jlo = 0" on input.
+
+    INTEGER, INTENT(INOUT) :: jlo
+    REAL, INTENT(IN) :: x
+    REAL, DIMENSION(:), INTENT(IN) :: xx
+    INTEGER  n,inc,jhi,jm
+    LOGICAL  ascnd, hunt_up
+
+    !-----------------------------------------------------
+
+    n=size(xx)
+    ascnd = (xx(n) >= xx(1))
+    ! (True if ascending order of table, false otherwise.)
+    if (jlo < 0 .or. jlo > n) then
+       ! Input guess not useful. Go immediately to bisection.
+       jlo=0
+       jhi=n+1
+    else
+       inc=1 ! Set the hunting increment.
+       if (jlo == 0) then
+          hunt_up = .true.
+       else
+          hunt_up = x >= xx(jlo) .eqv. ascnd
+       end if
+       if (hunt_up) then ! Hunt up:
+          do
+             jhi=jlo+inc
+             if (jhi > n) then ! Done hunting, since off end of table.
+                jhi=n+1
+                exit
+             else
+                if (x < xx(jhi) .eqv. ascnd) exit
+                jlo=jhi ! Not done hunting,
+                inc=inc+inc ! so double the increment
+             end if
+          end do ! and try again.
+       else ! Hunt down:
+          jhi=jlo
+          do
+             jlo=jhi-inc
+             if (jlo < 1) then ! Done hunting, since off end of table.
+                jlo=0
+                exit
+             else
+                if (x >= xx(jlo) .eqv. ascnd) exit
+                jhi=jlo ! Not done hunting,
+                inc=inc+inc ! so double the increment
+             end if
+          end do ! and try again.
+       end if
+    end if ! Done hunting, value bracketed.
+
+    do ! Hunt is done, so begin the final bisection phase:
+       if (jhi-jlo <= 1) then
+          if (x == xx(n)) jlo=n-1
+          if (x == xx(1)) jlo=1
+          exit
+       else
+          jm=(jhi+jlo)/2
+          if (x >= xx(jm) .eqv. ascnd) then
+             jlo=jm
+          else
+             jhi=jm
+          end if
+       end if
+    end do
+
+  END SUBROUTINE hunt
+
+end module interpolation
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_errioipsl.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_errioipsl.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_errioipsl.F90	(revision 222)
@@ -0,0 +1,219 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_errioipsl
+!-
+!$Id: errioipsl.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+IMPLICIT NONE
+!-
+PRIVATE
+!-
+PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg
+!-
+  INTEGER :: n_l=6, ilv_cur=0, ilv_max=0
+  LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE.
+!-
+!===
+CONTAINS
+!===
+SUBROUTINE ipslnlf (new_number,old_number)
+!!--------------------------------------------------------------------
+!! The "ipslnlf" routine allows to know and modify
+!! the current logical number for the messages.
+!!
+!! SUBROUTINE ipslnlf (new_number,old_number)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_number : new logical number of the file
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_number : current logical number of the file
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(IN)  :: new_number
+  INTEGER,OPTIONAL,INTENT(OUT) :: old_number
+!---------------------------------------------------------------------
+  IF (PRESENT(old_number)) THEN
+    old_number = n_l
+  ENDIF
+  IF (PRESENT(new_number)) THEN
+    n_l = new_number
+  ENDIF
+!---------------------
+END SUBROUTINE ipslnlf
+!===
+SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!! The "ipslerr" routine
+!! allows to handle the messages to the user.
+!!
+!! INPUT
+!!
+!! plev   : Category of message to be reported to the user
+!!          1 = Note to the user
+!!          2 = Warning to the user
+!!          3 = Fatal error
+!! pcname : Name of subroutine which has called ipslerr
+!! pstr1   
+!! pstr2  : Strings containing the explanations to the user
+!! pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     ilv_cur = plev
+     ilv_max = MAX(ilv_max,plev)
+     WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
+   ENDIF
+   IF ( (plev == 3).AND.lact_mode) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!---------------------
+END SUBROUTINE ipslerr
+!===
+SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!--------------------------------------------------------------------
+!! The "ipslerr_act" routine allows to know and modify
+!! the current "action mode" for the error messages,
+!! and reinitialize the error level values.
+!!
+!! SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_mode : new error action mode
+!!                .TRUE.  -> STOP     in case of fatal error
+!!                .FALSE. -> CONTINUE in case of fatal error
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_mode : current error action mode
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_mode
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode
+!---------------------------------------------------------------------
+  IF (PRESENT(old_mode)) THEN
+    old_mode = lact_mode
+  ENDIF
+  IF (PRESENT(new_mode)) THEN
+    lact_mode = new_mode
+  ENDIF
+  ilv_cur = 0
+  ilv_max = 0
+!-------------------------
+END SUBROUTINE ipslerr_act
+!===
+SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!--------------------------------------------------------------------
+!! The "ipslerr_inq" routine allows to know
+!! the current level of the error messages
+!! and the maximum level encountered since the
+!! last call to "ipslerr_act".
+!!
+!! SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) current_level : current error level
+!! (I) maximum_level : maximum error level
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level
+!---------------------------------------------------------------------
+  IF (PRESENT(current_level)) THEN
+    current_level = ilv_cur
+  ENDIF
+  IF (PRESENT(maximum_level)) THEN
+    maximum_level = ilv_max
+  ENDIF
+!-------------------------
+END SUBROUTINE ipslerr_inq
+!===
+SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!- INPUT
+!- plev   : Category of message to be reported to the user
+!-          1 = Note to the user
+!-          2 = Warning to the user
+!-          3 = Fatal error
+!- pcname : Name of subroutine which has called histerr
+!- pstr1   
+!- pstr2  : String containing the explanations to the user
+!- pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     WRITE(*,'("     ")')
+     WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(*,'(" --> ",A)') pstr1
+     WRITE(*,'(" --> ",A)') pstr2
+     WRITE(*,'(" --> ",A)') pstr3
+   ENDIF
+   IF (plev == 3) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!---------------------
+END SUBROUTINE histerr
+!===
+SUBROUTINE ipsldbg (new_status,old_status)
+!!--------------------------------------------------------------------
+!! The "ipsldbg" routine
+!! allows to activate or deactivate the debug,
+!! and to know the current status of the debug.
+!!
+!! SUBROUTINE ipsldbg (new_status,old_status)
+!!
+!! Optional INPUT argument
+!!
+!! (L) new_status : new status of the debug
+!!
+!! Optional OUTPUT argument
+!!
+!! (L) old_status : current status of the debug
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_status
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_status
+!---------------------------------------------------------------------
+  IF (PRESENT(old_status)) THEN
+    old_status = ioipsl_debug
+  ENDIF
+  IF (PRESENT(new_status)) THEN
+    ioipsl_debug = new_status
+  ENDIF
+!---------------------
+END SUBROUTINE ipsldbg
+!===
+!-------------------
+END MODULE ioipsl_errioipsl
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_getincom.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_getincom.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_getincom.F90	(revision 222)
@@ -0,0 +1,1980 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_getincom
+!-
+!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+USE ioipsl_errioipsl, ONLY : ipslerr
+USE ioipsl_stringop, &
+ &   ONLY : nocomma,cmpblank,strlowercase
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+PUBLIC :: getin, getin_dump
+!-
+INTERFACE getin
+!!--------------------------------------------------------------------
+!! The "getin" routines get a variable.
+!! We first check if we find it in the database
+!! and if not we get it from the run.def file.
+!!
+!! SUBROUTINE getin (target,ret_val)
+!!
+!! INPUT
+!!
+!! (C) target : Name of the variable
+!!
+!! OUTPUT
+!!
+!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
+!!                     that will contain the (standard)
+!!                     integer/real/character/logical values
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
+ &                 getinis, getini1d, getini2d, &
+ &                 getincs, getinc1d, getinc2d, &
+ &                 getinls, getinl1d, getinl2d
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "getin_dump" routine will dump the content of the database
+!! into a file which has the same format as the run.def file.
+!! The idea is that the user can see which parameters were used
+!! and re-use the file for another run.
+!!
+!!  SUBROUTINE getin_dump (fileprefix)
+!!
+!! OPTIONAL INPUT argument
+!!
+!! (C) fileprefix : allows the user to change the name of the file
+!!                  in which the data will be archived
+!!--------------------------------------------------------------------
+!-
+  INTEGER,PARAMETER :: max_files=100
+  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
+  INTEGER,SAVE      :: nbfiles
+!-
+  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
+  INTEGER,SAVE :: nb_lines,i_txtsize=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
+  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
+!-
+  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
+  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
+!-
+! The data base of parameters
+!-
+  INTEGER,PARAMETER :: memslabs=200
+  INTEGER,PARAMETER :: compress_lim=20
+!-
+  INTEGER,SAVE :: nb_keys=0
+  INTEGER,SAVE :: keymemsize=0
+!-
+! keystr definition
+! name of a key
+!-
+! keystatus definition
+! keystatus = 1 : Value comes from run.def
+! keystatus = 2 : Default value is used
+! keystatus = 3 : Some vector elements were taken from default
+!-
+! keytype definition
+! keytype = 1 : Integer
+! keytype = 2 : Real
+! keytype = 3 : Character
+! keytype = 4 : Logical
+!-
+  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
+!-
+! Allow compression for keys (only for integer and real)
+! keycompress < 0 : not compressed
+! keycompress > 0 : number of repeat of the value
+!-
+TYPE :: t_key
+  CHARACTER(LEN=l_n) :: keystr
+  INTEGER :: keystatus, keytype, keycompress, &
+ &           keyfromfile, keymemstart, keymemlen
+END TYPE t_key
+!-
+  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
+!-
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
+  INTEGER,SAVE :: i_memsize=0, i_mempos=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
+  INTEGER,SAVE :: r_memsize=0, r_mempos=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
+  INTEGER,SAVE :: c_memsize=0, c_mempos=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
+  INTEGER,SAVE :: l_memsize=0, l_mempos=0
+!-
+CONTAINS
+!-
+!=== INTEGER INTERFACE
+!-
+SUBROUTINE getinis (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER :: ret_val
+!-
+  INTEGER,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,i_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinis
+!===
+SUBROUTINE getini1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getini1d
+!===
+SUBROUTINE getini2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:,:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getini2d
+!-
+!=== REAL INTERFACE
+!-
+SUBROUTINE getinrs (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL :: ret_val
+!-
+  REAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,r_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinrs
+!===
+SUBROUTINE getinr1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL,DIMENSION(:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinr1d
+!===
+SUBROUTINE getinr2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL,DIMENSION(:,:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinr2d
+!-
+!=== CHARACTER INTERFACE
+!-
+SUBROUTINE getincs (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,c_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getincs
+!===
+SUBROUTINE getinc1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinc1d
+!===
+SUBROUTINE getinc2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinc2d
+!-
+!=== LOGICAL INTERFACE
+!-
+SUBROUTINE getinls (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL :: ret_val
+!-
+  LOGICAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,l_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinls
+!===
+SUBROUTINE getinl1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL,DIMENSION(:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinl1d
+!===
+SUBROUTINE getinl2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL,DIMENSION(:,:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinl2d
+!-
+!=== Generic file/database INTERFACE
+!-
+SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Subroutine that will extract from the file the values
+!- attributed to the keyword target
+!-
+!- (C) target    : target for which we will look in the file
+!- (I) status    : tells us from where we obtained the data
+!- (I) fileorig  : index of the file from which the key comes
+!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
+!- (R) r_val(:)  : REAL(nb_to_ret)      values
+!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
+!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,INTENT(OUT) :: status,fileorig
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err
+  CHARACTER(LEN=n_d_fmt)  :: cnt
+  CHARACTER(LEN=80) :: str_READ,str_READ_lower
+  CHARACTER(LEN=9)  :: c_vtyp
+  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
+  LOGICAL :: def_beha,compressed
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: i_cmpval
+  REAL    :: r_cmpval
+  INTEGER :: ipos_tr,ipos_fl
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    nb_to_ret = SIZE(i_val)
+  CASE(k_r)
+    nb_to_ret = SIZE(r_val)
+  CASE(k_c)
+    nb_to_ret = SIZE(c_val)
+  CASE(k_l)
+    nb_to_ret = SIZE(l_val)
+  CASE DEFAULT
+    CALL ipslerr (3,'get_fil', &
+ &   'Internal error','Unknown type of data',' ')
+  END SELECT
+!-
+! Read the file(s)
+  CALL getin_read
+!-
+! Allocate and initialize the memory we need
+  ALLOCATE(found(nb_to_ret))
+  found(:) = .FALSE.
+!-
+! See what we find in the files read
+  DO it=1,nb_to_ret
+!---
+!-- First try the target as it is
+    CALL get_findkey (2,target,pos)
+!---
+!-- Another try
+!---
+    IF (pos < 0) THEN
+      WRITE(UNIT=cnt,FMT=c_i_fmt) it
+      CALL get_findkey (2,TRIM(target)//'__'//cnt,pos)
+    ENDIF
+!---
+!-- We dont know from which file the target could come.
+!-- Thus by default we attribute it to the first file :
+    fileorig = 1
+!---
+    IF (pos > 0) THEN
+!-----
+      found(it) = .TRUE.
+      fileorig = fromfile(pos)
+!-----
+!---- DECODE
+!-----
+      str_READ = ADJUSTL(fichier(pos))
+      str_READ_lower = str_READ
+      CALL strlowercase (str_READ_lower)
+!-----
+      IF (    (TRIM(str_READ_lower) == 'def')     &
+ &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
+        def_beha = .TRUE.
+      ELSE
+        def_beha = .FALSE.
+        len_str = LEN_TRIM(str_READ)
+        io_err = 0
+        SELECT CASE (k_typ)
+        CASE(k_i)
+          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
+        CASE(k_r)
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=*,IOSTAT=io_err) r_val(it)
+        CASE(k_c)
+          c_val(it) = str_READ(1:len_str)
+        CASE(k_l)
+          ipos_tr = -1
+          ipos_fl = -1
+          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
+ &                      INDEX(str_READ_lower,'y'))
+          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
+ &                      INDEX(str_READ_lower,'n'))
+          IF (ipos_tr > 0) THEN
+            l_val(it) = .TRUE.
+          ELSE IF (ipos_fl > 0) THEN
+            l_val(it) = .FALSE.
+          ELSE
+            io_err = 100
+          ENDIF
+        END SELECT
+        IF (io_err /= 0) THEN
+          CALL ipslerr (3,'get_fil', &
+ &         'Target '//TRIM(target), &
+ &         'is not of '//TRIM(c_vtyp)//' type',' ')
+        ENDIF
+      ENDIF
+!-----
+      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!-------
+!------ Is this the value of a compressed field ?
+        compressed = (compline(pos) > 0)
+        IF (compressed) THEN
+          IF (compline(pos) /= nb_to_ret) THEN
+            CALL ipslerr (2,'get_fil', &
+ &           'For key '//TRIM(target)//' we have a compressed field', &
+ &           'which does not have the right size.', &
+ &           'We will try to fix that.')
+          ENDIF
+          IF      (k_typ == k_i) THEN
+            i_cmpval = i_val(it)
+          ELSE IF (k_typ == k_r) THEN
+            r_cmpval = r_val(it)
+          ENDIF
+        ENDIF
+      ENDIF
+    ELSE
+      found(it) = .FALSE.
+      def_beha = .FALSE.
+      compressed = .FALSE.
+    ENDIF
+  ENDDO
+!-
+  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!---
+!-- If this is a compressed field then we will uncompress it
+    IF (compressed) THEN
+      DO it=1,nb_to_ret
+        IF (.NOT.found(it)) THEN
+          IF      (k_typ == k_i) THEN
+            i_val(it) = i_cmpval
+          ELSE IF (k_typ == k_r) THEN
+          ENDIF
+          found(it) = .TRUE.
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+! Now we set the status for what we found
+  IF (def_beha) THEN
+    status = 2
+    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target)
+  ELSE
+    status_cnt = 0
+    DO it=1,nb_to_ret
+      IF (.NOT.found(it)) THEN
+        status_cnt = status_cnt+1
+        IF      (status_cnt <= max_msgs) THEN
+          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
+ &               ADVANCE='NO') TRIM(target)
+          IF (nb_to_ret > 1) THEN
+            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
+            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
+          ENDIF
+          SELECT CASE (k_typ)
+          CASE(k_i)
+            WRITE (UNIT=*,FMT=*) "=",i_val(it)
+          CASE(k_r)
+            WRITE (UNIT=*,FMT=*) "=",r_val(it)
+          CASE(k_c)
+            WRITE (UNIT=*,FMT=*) "=",c_val(it)
+          CASE(k_l)
+            WRITE (UNIT=*,FMT=*) "=",l_val(it)
+          END SELECT
+        ELSE IF (status_cnt == max_msgs+1) THEN
+          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
+        ENDIF
+      ENDIF
+    ENDDO
+!---
+    IF (status_cnt == 0) THEN
+      status = 1
+    ELSE IF (status_cnt == nb_to_ret) THEN
+      status = 2
+    ELSE
+      status = 3
+    ENDIF
+  ENDIF
+! Deallocate the memory
+  DEALLOCATE(found)
+!---------------------
+END SUBROUTINE get_fil
+!===
+SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Read the required variable in the database
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: pos,size_of_in
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,k_beg,k_end
+  CHARACTER(LEN=9) :: c_vtyp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keytype /= k_typ) THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Wrong data type for keyword '//TRIM(target), &
+ &   '(NOT '//TRIM(c_vtyp)//')',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keycompress > 0) THEN
+    IF (    (key_tab(pos)%keycompress /= size_of_in) &
+ &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong compression length','for keyword '//TRIM(target),' ')
+    ELSE
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
+      END SELECT
+    ENDIF
+  ELSE
+    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong array length','for keyword '//TRIM(target),' ')
+    ELSE
+      k_beg = key_tab(pos)%keymemstart
+      k_end = k_beg+key_tab(pos)%keymemlen-1
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(k_beg:k_end)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(k_beg:k_end)
+      CASE(k_c)
+        c_val(1:size_of_in) = c_mem(k_beg:k_end)
+      CASE(k_l)
+        l_val(1:size_of_in) = l_mem(k_beg:k_end)
+      END SELECT
+    ENDIF
+  ENDIF
+!---------------------
+END SUBROUTINE get_rdb
+!===
+SUBROUTINE get_wdb &
+ &  (target,status,fileorig,size_of_in, &
+ &   i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Write data into the data base
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER :: status,fileorig,size_of_in
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ
+  CHARACTER(LEN=9) :: c_vtyp
+  INTEGER :: k_mempos,k_memsize,k_beg,k_end
+  LOGICAL :: l_cmp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_wdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+! First check if we have sufficiant space for the new key
+  IF (nb_keys+1 > keymemsize) THEN
+    CALL getin_allockeys ()
+  ENDIF
+!-
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    k_mempos = i_mempos; k_memsize = i_memsize;
+    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_r)
+    k_mempos = r_mempos; k_memsize = r_memsize;
+    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_c)
+    k_mempos = c_mempos; k_memsize = c_memsize;
+    l_cmp = .FALSE.
+  CASE(k_l)
+    k_mempos = l_mempos; k_memsize = l_memsize;
+    l_cmp = .FALSE.
+  END SELECT
+!-
+! Fill out the items of the data base
+  nb_keys = nb_keys+1
+  key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n))
+  key_tab(nb_keys)%keystatus = status
+  key_tab(nb_keys)%keytype = k_typ
+  key_tab(nb_keys)%keyfromfile = fileorig
+  key_tab(nb_keys)%keymemstart = k_mempos+1
+  IF (l_cmp) THEN
+    key_tab(nb_keys)%keycompress = size_of_in
+    key_tab(nb_keys)%keymemlen = 1
+  ELSE
+    key_tab(nb_keys)%keycompress = -1
+    key_tab(nb_keys)%keymemlen = size_of_in
+  ENDIF
+!-
+! Before writing the actual size lets see if we have the space
+  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
+ &    > k_memsize) THEN
+    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
+  ENDIF
+!-
+  k_beg = key_tab(nb_keys)%keymemstart
+  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
+    i_mempos = k_end
+  CASE(k_r)
+    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
+    r_mempos = k_end
+  CASE(k_c)
+    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
+    c_mempos = k_end
+  CASE(k_l)
+    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
+    l_mempos = k_end
+  END SELECT
+!---------------------
+END SUBROUTINE get_wdb
+!-
+!===
+!-
+SUBROUTINE getin_read
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,SAVE :: allread=0
+  INTEGER,SAVE :: current
+!---------------------------------------------------------------------
+  IF (allread == 0) THEN
+!-- Allocate a first set of memory.
+    CALL getin_alloctxt ()
+    CALL getin_allockeys ()
+    CALL getin_allocmem (k_i,0)
+    CALL getin_allocmem (k_r,0)
+    CALL getin_allocmem (k_c,0)
+    CALL getin_allocmem (k_l,0)
+!-- Start with reading the files
+    nbfiles = 1
+    filelist(1) = 'run.def'
+    current = 1
+!--
+    DO WHILE (current <= nbfiles)
+      CALL getin_readdef (current)
+      current = current+1
+    ENDDO
+    allread = 1
+    CALL getin_checkcohe ()
+  ENDIF
+!------------------------
+END SUBROUTINE getin_read
+!-
+!===
+!-
+  SUBROUTINE getin_readdef(current)
+!---------------------------------------------------------------------
+!- This subroutine will read the files and only keep the
+!- the relevant information. The information is kept as it
+!- found in the file. The data will be analysed later.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: current
+!-
+  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: nb_lastkey
+!-
+  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  eof = 0
+  ptn = 1
+  nb_lastkey = 0
+!-
+  IF (check) THEN
+    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
+  ENDIF
+!-
+  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
+  IF (io_err /= 0) THEN
+    CALL ipslerr (2,'getin_readdef', &
+ &  'Could not open file '//TRIM(filelist(current)),' ',' ')
+    RETURN
+  ENDIF
+!-
+  DO WHILE (eof /= 1)
+!---
+    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
+    len_str = LEN_TRIM(READ_str)
+    ptn = INDEX(READ_str,'=')
+!---
+    IF (ptn > 0) THEN
+!---- Get the target
+      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
+!---- Make sure that a vector keyword has the right length
+      iund = INDEX(key_str,'__')
+      IF (iund > 0) THEN
+        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
+ &        LEN_TRIM(key_str)-iund-1
+        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
+ &           FMT=c_fmt,IOSTAT=io_err) it
+        IF ( (io_err == 0).AND.(it > 0) ) THEN
+          WRITE(UNIT=cnt,FMT=c_i_fmt) it
+          key_str = key_str(1:iund+1)//cnt
+        ELSE
+          CALL ipslerr (3,'getin_readdef', &
+ &         'A very strange key has just been found :', &
+ &         TRIM(key_str),' ')
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
+      CALL nocomma (NEW_str)
+      CALL cmpblank (NEW_str)
+      NEW_str  = TRIM(ADJUSTL(NEW_str))
+      IF (check) THEN
+        WRITE(*,*) &
+ &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
+      ENDIF
+!---- Decypher the content of NEW_str
+!-
+!---- This has to be a new key word, thus :
+      nb_lastkey = 0
+!----
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+!----
+    ELSE IF (len_str > 0) THEN
+!---- Prepare the key if we have an old one to which
+!---- we will add the line just read
+      IF (nb_lastkey > 0) THEN
+        iund =  INDEX(last_key,'__')
+        IF (iund > 0) THEN
+!-------- We only continue a keyword, thus it is easy
+          key_str = last_key(1:iund-1)
+        ELSE
+          IF (nb_lastkey /= 1) THEN
+            CALL ipslerr (3,'getin_readdef', &
+ &           'We can not have a scalar keyword', &
+ &           'and a vector content',' ')
+          ENDIF
+!-------- The last keyword needs to be transformed into a vector.
+          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
+          targetlist(nb_lines) = &
+ &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
+          key_str = last_key(1:LEN_TRIM(last_key))
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+    ELSE
+!---- If we have an empty line then the keyword finishes
+      nb_lastkey = 0
+      IF (check) THEN
+        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
+      ENDIF
+    ENDIF
+  ENDDO
+!-
+  CLOSE(UNIT=22)
+!-
+  IF (check) THEN
+    OPEN (UNIT=22,file='run.def.test')
+    DO i=1,nb_lines
+      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
+    ENDDO
+    CLOSE(UNIT=22)
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_readdef
+!-
+!===
+!-
+SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
+!---------------------------------------------------------------------
+!- This subroutine is going to decypher the line.
+!- It essentialy checks how many items are included and
+!- it they can be attached to a key.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER :: current,nb_lastkey
+  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
+!-
+! LOCAL
+!-
+  INTEGER :: len_str,blk,nbve,starpos
+  CHARACTER(LEN=100) :: tmp_str,new_key,mult
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+!---------------------------------------------------------------------
+  len_str = LEN_TRIM(NEW_str)
+  blk = INDEX(NEW_str(1:len_str),' ')
+  tmp_str = NEW_str(1:len_str)
+!-
+! If the key is a new file then we take it up. Else
+! we save the line and go on.
+!-
+  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
+    DO WHILE (blk > 0)
+      IF (nbfiles+1 > max_files) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'Too many files to include',' ',' ')
+      ENDIF
+!-----
+      nbfiles = nbfiles+1
+      filelist(nbfiles) = tmp_str(1:blk)
+!-----
+      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
+    ENDDO
+!---
+    IF (nbfiles+1 > max_files) THEN
+      CALL ipslerr (3,'getin_decrypt', &
+ &     'Too many files to include',' ',' ')
+    ENDIF
+!---
+    nbfiles =  nbfiles+1
+    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
+!---
+    last_key = 'INCLUDEDEF'
+    nb_lastkey = 1
+  ELSE
+!-
+!-- We are working on a new line of input
+!-
+    IF (nb_lines+1 > i_txtsize) THEN
+      CALL getin_alloctxt ()
+    ENDIF
+    nb_lines = nb_lines+1
+!-
+!-- First we solve the issue of conpressed information. Once
+!-- this is done all line can be handled in the same way.
+!-
+    starpos = INDEX(NEW_str(1:len_str),'*')
+    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
+ &                    .AND.(tmp_str(1:1) /= "'") ) THEN
+!-----
+      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We can not have a compressed field of values', &
+ &       'in a vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str))
+      ENDIF
+!-
+!---- Read the multiplied
+!-
+      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
+!---- Construct the new string and its parameters
+      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
+      len_str = LEN_TRIM(NEW_str)
+      blk = INDEX(NEW_str(1:len_str),' ')
+      IF (blk > 1) THEN
+        CALL ipslerr (2,'getin_decrypt', &
+ &       'This is a strange behavior','you could report',' ')
+      ENDIF
+      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
+      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
+!---
+    ELSE
+      compline(nb_lines) = -1
+    ENDIF
+!-
+!-- If there is no space wthin the line then the target is a scalar
+!-- or the element of a properly written vector.
+!-- (ie of the type TARGET__00001)
+!-
+    IF (    (blk <= 1) &
+ &      .OR.(tmp_str(1:1) == '"') &
+ &      .OR.(tmp_str(1:1) == "'") ) THEN
+!-
+      IF (nb_lastkey == 0) THEN
+!------ Save info of current keyword as a scalar
+!------ if it is not a continuation
+        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        nb_lastkey = 1
+      ELSE
+!------ We are continuing a vector so the keyword needs
+!------ to get the underscores
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
+        targetlist(nb_lines) = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        last_key = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        nb_lastkey = nb_lastkey+1
+      ENDIF
+!-----
+      fichier(nb_lines) = NEW_str(1:len_str)
+      fromfile(nb_lines) = current
+    ELSE
+!-
+!---- If there are blanks whithin the line then we are dealing
+!---- with a vector and we need to split it in many entries
+!---- with the TARGET__n notation.
+!----
+!---- Test if the targer is not already a vector target !
+!-
+      IF (INDEX(TRIM(key_str),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We have found a mixed vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str),' ')
+      ENDIF
+!-
+      nbve = nb_lastkey
+      nbve = nbve+1
+      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      DO WHILE (blk > 0)
+!-
+!------ Save the content of target__nbve
+!-
+        fichier(nb_lines) = tmp_str(1:blk)
+        new_key = &
+ &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+        fromfile(nb_lines) = current
+!-
+        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+        blk = INDEX(TRIM(tmp_str),' ')
+!-
+        IF (nb_lines+1 > i_txtsize) THEN
+          CALL getin_alloctxt ()
+        ENDIF
+        nb_lines = nb_lines+1
+        nbve = nbve+1
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      ENDDO
+!-
+!---- Save the content of the last target
+!-
+      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
+      new_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+      fromfile(nb_lines) = current
+!-
+      last_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      nb_lastkey = nbve
+!-
+    ENDIF
+!-
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_decrypt
+!-
+!===
+!-
+SUBROUTINE getin_checkcohe ()
+!---------------------------------------------------------------------
+!- This subroutine checks for redundancies.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: line,n_k,k
+!---------------------------------------------------------------------
+  DO line=1,nb_lines-1
+!-
+    n_k = 0
+    DO k=line+1,nb_lines
+      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
+        n_k = k
+        EXIT
+      ENDIF
+    ENDDO
+!---
+!-- IF we have found it we have a problem to solve.
+!---
+    IF (n_k > 0) THEN
+      WRITE(*,*) 'COUNT : ',n_k
+      WRITE(*,*) &
+ &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
+      WRITE(*,*) &
+ &  'getin_checkcohe : The following values were encoutered :'
+      WRITE(*,*) &
+ &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
+      WRITE(*,*) &
+ &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
+      WRITE(*,*) &
+ &  'getin_checkcohe : We will keep only the last value'
+      targetlist(line) = ' '
+    ENDIF
+  ENDDO
+!-----------------------------
+END SUBROUTINE getin_checkcohe
+!-
+!===
+!-
+SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: unit,eof,nb_lastkey
+  CHARACTER(LEN=100) :: dummy
+  CHARACTER(LEN=100) :: out_string
+  CHARACTER(LEN=1) :: first
+!---------------------------------------------------------------------
+  first="#"
+  eof = 0
+  out_string = "    "
+!-
+  DO WHILE (first == "#")
+    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
+    dummy = TRIM(ADJUSTL(dummy))
+    first=dummy(1:1)
+    IF (first == "#") THEN
+      nb_lastkey = 0
+    ENDIF
+  ENDDO
+  out_string=dummy
+!-
+  RETURN
+!-
+9998 CONTINUE
+  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
+!-
+7778 CONTINUE
+  eof = 1
+!----------------------------
+END SUBROUTINE getin_skipafew
+!-
+!===
+!-
+SUBROUTINE getin_allockeys ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  IF (keymemsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) memslabs
+    ALLOCATE(key_tab(memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    nb_keys = 0
+    keymemsize = memslabs
+    key_tab(:)%keycompress = -1
+!---
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize
+    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate tmp_key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
+    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
+    DEALLOCATE(key_tab)
+    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    key_tab(:)%keycompress = -1
+    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
+    DEALLOCATE(tmp_key_tab)
+    keymemsize = keymemsize+memslabs
+  ENDIF
+!-----------------------------
+END SUBROUTINE getin_allockeys
+!-
+!===
+!-
+SUBROUTINE getin_allocmem (type,len_wanted)
+!---------------------------------------------------------------------
+!- Allocate the memory of the data base for all 4 types of memory
+!- INTEGER / REAL / CHARACTER / LOGICAL
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: type,len_wanted
+!-
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+  REAL,ALLOCATABLE :: tmp_real(:)
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
+  LOGICAL,ALLOCATABLE :: tmp_logic(:)
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  SELECT CASE (type)
+  CASE(k_i)
+    IF (i_memsize == 0) THEN
+      ALLOCATE(i_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_memsize=memslabs
+    ELSE
+      ALLOCATE(tmp_int(i_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_int', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
+      DEALLOCATE(i_mem)
+      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
+      i_memsize = i_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_int)
+    ENDIF
+  CASE(k_r)
+    IF (r_memsize == 0) THEN
+      ALLOCATE(r_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_memsize =  memslabs
+    ELSE
+      ALLOCATE(tmp_real(r_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_real', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
+      DEALLOCATE(r_mem)
+      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
+      r_memsize = r_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_real)
+    ENDIF
+  CASE(k_c)
+    IF (c_memsize == 0) THEN
+      ALLOCATE(c_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_char(c_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_char', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
+      DEALLOCATE(c_mem)
+      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
+      c_memsize = c_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_char)
+    ENDIF
+  CASE(k_l)
+    IF (l_memsize == 0) THEN
+      ALLOCATE(l_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_logic(l_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_logic', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
+      DEALLOCATE(l_mem)
+      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
+      l_memsize = l_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_logic)
+    ENDIF
+  CASE DEFAULT
+    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
+  END SELECT
+!----------------------------
+END SUBROUTINE getin_allocmem
+!-
+!===
+!-
+SUBROUTINE getin_alloctxt ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
+  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
+!---------------------------------------------------------------------
+  IF (i_txtsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
+    ALLOCATE(fichier(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(targetlist(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(fromfile(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(compline(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    nb_lines = 0
+    i_txtsize = i_txtslab
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
+    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
+    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_fic', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
+    DEALLOCATE(fichier)
+    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
+    DEALLOCATE(tmp_fic)
+!---
+    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_tgl', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
+    DEALLOCATE(targetlist)
+    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
+    DEALLOCATE(tmp_tgl)
+!---
+    ALLOCATE(tmp_int(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_int', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
+    DEALLOCATE(fromfile)
+    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
+!---
+    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
+    DEALLOCATE(compline)
+    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
+    DEALLOCATE(tmp_int)
+!---
+    i_txtsize = i_txtsize+i_txtslab
+  ENDIF
+!----------------------------
+END SUBROUTINE getin_alloctxt
+!-
+!===
+!-
+SUBROUTINE getin_dump (fileprefix)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(*),OPTIONAL :: fileprefix
+!-
+  CHARACTER(LEN=80) :: usedfileprefix
+  INTEGER :: ikey,if,iff,iv
+  CHARACTER(LEN=20) :: c_tmp
+  CHARACTER(LEN=100) :: tmp_str,used_filename
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  IF (PRESENT(fileprefix)) THEN
+    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
+  ELSE
+    usedfileprefix = "used"
+  ENDIF
+!-
+  DO if=1,nbfiles
+!---
+    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
+    IF (check) THEN
+      WRITE(*,*) &
+ &      'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if
+      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
+    ENDIF
+    OPEN (UNIT=22,FILE=used_filename)
+!---
+!-- If this is the first file we need to add the list
+!-- of file which belong to it
+    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
+      WRITE(22,*) '# '
+      WRITE(22,*) '# This file is linked to the following files :'
+      WRITE(22,*) '# '
+      DO iff=2,nbfiles
+        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
+      ENDDO
+      WRITE(22,*) '# '
+    ENDIF
+!---
+    DO ikey=1,nb_keys
+!-----
+!---- Is this key from this file ?
+      IF (key_tab(ikey)%keyfromfile == if) THEN
+!-------
+!------ Write some comments
+        WRITE(22,*) '#'
+        SELECT CASE (key_tab(ikey)%keystatus)
+        CASE(1)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes from the run.def.'
+        CASE(2)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
+        CASE(3)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr), &
+ &          ' are a mix of run.def and defaults.'
+        CASE DEFAULT
+          WRITE(22,*) '# Dont know from where the value of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes.'
+        END SELECT
+        WRITE(22,*) '#'
+!-------
+!------ Write the values
+        SELECT CASE (key_tab(ikey)%keytype)
+        CASE(k_i)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+ &              ' * ',i_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_r)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_c)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            tmp_str = c_mem(key_tab(ikey)%keymemstart)
+            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',TRIM(tmp_str)
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',TRIM(tmp_str)
+            ENDDO
+          ENDIF
+        CASE(k_l)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
+            ELSE
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
+              ELSE
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
+              ENDIF
+            ENDDO
+          ENDIF
+        CASE DEFAULT
+          CALL ipslerr (3,'getin_dump', &
+ &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
+ &         ' ',' ')
+        END SELECT
+      ENDIF
+    ENDDO
+!-
+    CLOSE(UNIT=22)
+!-
+  ENDDO
+!------------------------
+END SUBROUTINE getin_dump
+!===
+SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
+!---------------------------------------------------------------------
+!- Returns the type of the argument (mutually exclusive)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(OUT) :: k_typ
+  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
+  REAL,DIMENSION(:),OPTIONAL             :: r_v
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
+!---------------------------------------------------------------------
+  k_typ = 0
+  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
+ &    /= 1) THEN
+    CALL ipslerr (3,'get_qtyp', &
+ &   'Invalid number of optional arguments','(/= 1)',' ')
+  ENDIF
+!-
+  IF     (PRESENT(i_v)) THEN
+    k_typ = k_i
+    c_vtyp = 'INTEGER'
+  ELSEIF (PRESENT(r_v)) THEN
+    k_typ = k_r
+    c_vtyp = 'REAL'
+  ELSEIF (PRESENT(c_v)) THEN
+    k_typ = k_c
+    c_vtyp = 'CHARACTER'
+  ELSEIF (PRESENT(l_v)) THEN
+    k_typ = k_l
+    c_vtyp = 'LOGICAL'
+  ENDIF
+!----------------------
+END SUBROUTINE get_qtyp
+!===
+SUBROUTINE get_findkey (i_tab,c_key,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a key in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
+!-            2 -> search in targetlist(1:nb_lines)
+!-   c_key  : Name of the key we are looking for
+!- OUTPUT
+!-   pos    : -1 if key not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in) :: i_tab
+  CHARACTER(LEN=*),INTENT(in) :: c_key
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: ikey_max,ikey
+  CHARACTER(LEN=l_n) :: c_q_key
+!---------------------------------------------------------------------
+  pos = -1
+  IF     (i_tab == 1) THEN
+    ikey_max = nb_keys
+  ELSEIF (i_tab == 2) THEN
+    ikey_max = nb_lines
+  ELSE
+    ikey_max = 0
+  ENDIF
+  IF ( ikey_max > 0 ) THEN
+    DO ikey=1,ikey_max
+      IF (i_tab == 1) THEN
+        c_q_key = key_tab(ikey)%keystr
+      ELSE
+        c_q_key = targetlist(ikey)
+      ENDIF
+      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
+        pos = ikey
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!-------------------------
+END SUBROUTINE get_findkey
+!===
+!------------------
+END MODULE ioipsl_getincom
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_stringop.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_stringop.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ioipsl_stringop.F90	(revision 222)
@@ -0,0 +1,243 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_stringop
+!-
+!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+!-
+  INTEGER,DIMENSION(30) :: &
+ & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
+ & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
+!-
+!---------------------------------------------------------------------
+CONTAINS
+!=
+SUBROUTINE cmpblank (str)
+!---------------------------------------------------------------------
+!- Compact blanks
+!---------------------------------------------------------------------
+  CHARACTER(LEN=*),INTENT(inout) :: str
+!-
+  INTEGER :: lcc,ipb
+!---------------------------------------------------------------------
+  lcc = LEN_TRIM(str)
+  ipb = 1
+  DO
+    IF (ipb >= lcc)   EXIT
+    IF (str(ipb:ipb+1) == '  ') THEN
+      str(ipb+1:) = str(ipb+2:lcc)
+      lcc = lcc-1
+    ELSE
+      ipb = ipb+1
+    ENDIF
+  ENDDO
+!----------------------
+END SUBROUTINE cmpblank
+!===
+INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds number of occurences of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!-
+  INTEGER :: ipos,indx
+!---------------------------------------------------------------------
+  cntpos = 0
+  ipos   = 1
+  DO
+    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
+    IF (indx > 0) THEN
+      cntpos = cntpos+1
+      ipos   = ipos+indx+l_r-1
+    ELSE
+      EXIT
+    ENDIF
+  ENDDO
+!------------------
+END FUNCTION cntpos
+!===
+INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds position of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!---------------------------------------------------------------------
+  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
+  IF (findpos == 0)  findpos=-1
+!-------------------
+END FUNCTION findpos
+!===
+SUBROUTINE find_str (str_tab,str,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a string in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   str_tab  : Table  of strings
+!-   str      : Target we are looking for
+!- OUTPUT
+!-   pos      : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
+  CHARACTER(LEN=*),INTENT(in) :: str
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: nb_str,i
+!---------------------------------------------------------------------
+  pos = -1
+  nb_str=SIZE(str_tab)
+  IF ( nb_str > 0 ) THEN
+    DO i=1,nb_str
+      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
+        pos = i
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!----------------------
+END SUBROUTINE find_str
+!===
+SUBROUTINE nocomma (str)
+!---------------------------------------------------------------------
+!- Replace commas with blanks
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    IF (str(i:i) == ',')   str(i:i) = ' '
+  ENDDO
+!---------------------
+END SUBROUTINE nocomma
+!===
+SUBROUTINE strlowercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into lowercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
+  ENDDO
+!--------------------------
+END SUBROUTINE strlowercase
+!===
+SUBROUTINE struppercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into uppercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
+  ENDDO
+!--------------------------
+END SUBROUTINE struppercase
+!===
+SUBROUTINE gensig (str,sig)
+!---------------------------------------------------------------------
+!- Generate a signature from the first 30 characters of the string
+!- This signature is not unique and thus when one looks for the
+!- one needs to also verify the string.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+  INTEGER          :: sig
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  sig = 0
+  DO i=1,MIN(LEN_TRIM(str),30)
+    sig = sig + prime(i)*IACHAR(str(i:i))
+  ENDDO
+!--------------------
+END SUBROUTINE gensig
+!===
+SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
+!---------------------------------------------------------------------
+!- Find the string signature in a list of signatures
+!---------------------------------------------------------------------
+!- INPUT
+!-   nb_sig      : length of table of signatures
+!-   str_tab     : Table of strings
+!-   str         : Target string we are looking for
+!-   sig_tab     : Table of signatures
+!-   sig         : Target signature we are looking for
+!- OUTPUT
+!-   pos         : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb_sig
+  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
+  CHARACTER(LEN=*) :: str
+  INTEGER,DIMENSION(nb_sig) :: sig_tab
+  INTEGER :: sig
+!-
+  INTEGER :: pos
+  INTEGER,DIMENSION(nb_sig) :: loczeros
+!-
+  INTEGER :: il,len
+  INTEGER,DIMENSION(1) :: minpos
+!---------------------------------------------------------------------
+  pos = -1
+  il = LEN_TRIM(str)
+!-
+  IF ( nb_sig > 0 ) THEN
+    loczeros = ABS(sig_tab(1:nb_sig)-sig)
+    IF ( COUNT(loczeros < 1) == 1 ) THEN
+      minpos = MINLOC(loczeros)
+      len = LEN_TRIM(str_tab(minpos(1)))
+      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+          .AND.(len == il) ) THEN
+        pos = minpos(1)
+      ENDIF
+    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
+      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
+        minpos = MINLOC(loczeros)
+        len = LEN_TRIM(str_tab(minpos(1)))
+        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+            .AND.(len == il) ) THEN
+          pos = minpos(1)
+        ELSE
+          loczeros(minpos(1)) = 99999
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-----------------------
+ END SUBROUTINE find_sig
+!===
+!------------------
+END MODULE ioipsl_stringop
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ismax.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ismax.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ismax.F	(revision 222)
@@ -0,0 +1,24 @@
+!
+! $Header$
+!
+      function ismax(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      INTEGER n,i,incx,ismax,ix
+      real sx((n-1)*incx+1),sxmax
+c
+      ix=1
+      ismax=1
+      sxmax=sx(1)
+      do 10 i=1,n-1
+       ix=ix+incx
+       if(sx(ix).gt.sxmax) then
+         sxmax=sx(ix)
+         ismax=i+1
+       endif
+10    continue
+c
+      return
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ismin.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ismin.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/ismin.F	(revision 222)
@@ -0,0 +1,24 @@
+!
+! $Header$
+!
+      FUNCTION ismin(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,i,incx,ismin,ix
+      real sx((n-1)*incx+1),sxmin
+c
+      ix=1
+      ismin=1
+      sxmin=sx(1)
+      DO i=1,n-1
+         ix=ix+incx
+         if(sx(ix).lt.sxmin) then
+             sxmin=sx(ix)
+             ismin=i+1
+         endif
+      ENDDO
+c
+      return
+      end
+C
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/j4save.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/j4save.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/j4save.F	(revision 222)
@@ -0,0 +1,65 @@
+*DECK J4SAVE
+      FUNCTION J4SAVE (IWHICH, IVALUE, ISET)
+C***BEGIN PROLOGUE  J4SAVE
+C***SUBSIDIARY
+C***PURPOSE  Save or recall global variables needed by error
+C            handling routines.
+C***LIBRARY   SLATEC (XERROR)
+C***TYPE      INTEGER (J4SAVE-I)
+C***KEYWORDS  ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        J4SAVE saves and recalls several global variables needed
+C        by the library error handling routines.
+C
+C     Description of Parameters
+C      --Input--
+C        IWHICH - Index of item desired.
+C                = 1 Refers to current error number.
+C                = 2 Refers to current error control flag.
+C                = 3 Refers to current unit number to which error
+C                    messages are to be sent.  (0 means use standard.)
+C                = 4 Refers to the maximum number of times any
+C                     message is to be printed (as set by XERMAX).
+C                = 5 Refers to the total number of units to which
+C                     each error message is to be written.
+C                = 6 Refers to the 2nd unit for error messages
+C                = 7 Refers to the 3rd unit for error messages
+C                = 8 Refers to the 4th unit for error messages
+C                = 9 Refers to the 5th unit for error messages
+C        IVALUE - The value to be set for the IWHICH-th parameter,
+C                 if ISET is .TRUE. .
+C        ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
+C                 given the value, IVALUE.  If ISET=.FALSE., the
+C                 IWHICH-th parameter will be unchanged, and IVALUE
+C                 is a dummy parameter.
+C      --Output--
+C        The (old) value of the IWHICH-th parameter will be returned
+C        in the function value, J4SAVE.
+C
+C***SEE ALSO  XERMSG
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900205  Minor modifications to prologue.  (WRB)
+C   900402  Added TYPE section.  (WRB)
+C   910411  Added KEYWORDS section.  (WRB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  J4SAVE
+      LOGICAL ISET
+      INTEGER IPARAM(9)
+      SAVE IPARAM
+      DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/
+      DATA IPARAM(5)/1/
+      DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
+C***FIRST EXECUTABLE STATEMENT  J4SAVE
+      J4SAVE = IPARAM(IWHICH)
+      IF (ISET) IPARAM(IWHICH) = IVALUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/misc_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/misc_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/misc_mod.F90	(revision 222)
@@ -0,0 +1,6 @@
+module misc_mod
+  integer,save :: itaumax
+  logical,save :: adjust
+  integer,save :: ItCount
+  logical,save :: debug
+end module misc_mod 
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/netcdf95.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/netcdf95.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/netcdf95.F90	(revision 222)
@@ -0,0 +1,17 @@
+! $Id$
+module netcdf95
+
+  ! Author: Lionel GUEZ
+  ! See:
+  ! http://www.lmd.jussieu.fr/~lglmd/NetCDF95
+
+  use nf95_def_var_m
+  use nf95_put_var_m
+  use nf95_get_var_m
+  use nf95_gw_var_m
+  use nf95_put_att_m
+  use nf95_get_att_m
+  use simple
+  use handle_err_m
+
+end module netcdf95
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/new_unit_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/new_unit_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/new_unit_m.F90	(revision 222)
@@ -0,0 +1,25 @@
+module new_unit_m
+
+  implicit none
+
+contains
+
+  subroutine new_unit(unit)
+
+    integer, intent(out):: unit
+
+    ! Variables local to the procedure:
+    logical opened, exist
+
+    !------------------------------------------------------
+
+    unit = 0
+    do
+       inquire(unit=unit, opened=opened, exist=exist)
+       if (exist .and. .not. opened) exit
+       unit = unit + 1
+    end do
+
+  end subroutine new_unit
+
+end module new_unit_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_def_var_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_def_var_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_def_var_m.F90	(revision 222)
@@ -0,0 +1,102 @@
+! $Id$
+module nf95_def_var_m
+
+  ! The generic procedure name "nf90_def_var" applies to
+  ! "nf90_def_var_Scalar" but we cannot apply the generic procedure name
+  ! "nf95_def_var" to "nf95_def_var_scalar" because of the additional
+  ! optional argument.
+  ! "nf95_def_var_scalar" cannot be distinguished from "nf95_def_var_oneDim".
+
+  implicit none
+
+  interface nf95_def_var
+    module procedure nf95_def_var_oneDim, nf95_def_var_ManyDims
+  end interface
+
+  private
+  public nf95_def_var, nf95_def_var_scalar
+
+contains
+
+  subroutine nf95_def_var_scalar(ncid, name, xtype, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_scalar " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_scalar
+
+  !***********************
+
+  subroutine nf95_def_var_oneDim(ncid, name, xtype, dimids, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer,               intent( in) :: dimids
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_oneDim " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_oneDim
+
+  !***********************
+
+  subroutine nf95_def_var_ManyDims(ncid, name, xtype, dimids, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer, dimension(:), intent( in) :: dimids
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_ManyDims " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_ManyDims
+
+end module nf95_def_var_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_get_att_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_get_att_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_get_att_m.F90	(revision 222)
@@ -0,0 +1,105 @@
+! $Id$
+module nf95_get_att_m
+
+  use handle_err_m, only: handle_err
+  use netcdf, only: nf90_get_att, nf90_noerr
+  use simple, only: nf95_inquire_attribute
+
+  implicit none
+
+  interface nf95_get_att
+     module procedure nf95_get_att_text, nf95_get_att_one_FourByteInt
+
+     ! The difference between the specific procedures is the type of
+     ! argument "values".
+  end interface
+
+  private
+  public nf95_get_att
+
+contains
+
+  subroutine nf95_get_att_text(ncid, varid, name, values, ncerr)
+
+    integer,                          intent( in) :: ncid, varid
+    character(len = *),               intent( in) :: name
+    character(len = *),               intent(out) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variables local to the procedure:
+    integer ncerr_not_opt
+    integer att_len
+
+    !-------------------
+
+    ! Check that the length of "values" is large enough:
+    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
+         ncerr=ncerr_not_opt)
+    if (ncerr_not_opt == nf90_noerr) then
+       if (len(values) < att_len) then
+          print *, "nf95_get_att_text"
+          print *, "varid = ", varid
+          print *, "attribute name: ", name
+          print *, 'length of "values" is not large enough'
+          print *, "len(values) = ", len(values)
+          print *, "number of characters in attribute: ", att_len
+          stop 1
+       end if
+    end if
+
+    values = "" ! useless in NetCDF version 3.6.2 or better
+    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_att_text " // trim(name), ncerr_not_opt, &
+            ncid, varid)
+    end if
+
+    if (att_len >= 1 .and. ncerr_not_opt == nf90_noerr) then
+       ! Remove null terminator, if any:
+       if (iachar(values(att_len:att_len)) == 0) values(att_len:att_len) = " "
+    end if
+
+  end subroutine nf95_get_att_text
+
+  !***********************
+
+  subroutine nf95_get_att_one_FourByteInt(ncid, varid, name, values, ncerr)
+
+    integer,                                    intent( in) :: ncid, varid
+    character(len = *),                         intent( in) :: name
+    integer ,               intent(out) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variables local to the procedure:
+    integer ncerr_not_opt
+    integer att_len
+
+    !-------------------
+
+    ! Check that the attribute contains a single value:
+    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
+         ncerr=ncerr_not_opt)
+    if (ncerr_not_opt == nf90_noerr) then
+       if (att_len /= 1) then
+          print *, "nf95_get_att_one_FourByteInt"
+          print *, "varid = ", varid
+          print *, "attribute name: ", name
+          print *, 'the attribute does not contain a single value'
+          print *, "number of values in attribute: ", att_len
+          stop 1
+       end if
+    end if
+
+    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_att_one_FourByteInt " // trim(name), &
+            ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_get_att_one_FourByteInt
+
+end module nf95_get_att_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_get_var_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_get_var_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_get_var_m.F90	(revision 222)
@@ -0,0 +1,391 @@
+module nf95_get_var_m
+
+  use netcdf, only: nf90_get_var
+  use handle_err_m, only: handle_err
+
+  implicit none
+
+  interface nf95_get_var
+     module procedure nf95_get_var_FourByteReal, nf95_get_var_FourByteInt, &
+          nf95_get_var_1D_FourByteReal, nf95_get_var_1D_FourByteInt, &
+          nf95_get_var_2D_FourByteReal, &
+          nf95_get_var_3D_FourByteInt, &
+          nf95_get_var_3D_FourByteReal, &
+          nf95_get_var_4D_FourByteReal, &
+          nf95_get_var_5D_FourByteReal
+  end interface
+
+  private
+  public nf95_get_var
+
+contains
+
+  subroutine nf95_get_var_FourByteReal(ncid, varid, values, start, ncerr)
+
+    integer, intent(in) :: ncid, varid
+    real, intent(out) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_FourByteInt(ncid, varid, values, start, ncerr)
+
+    integer, intent(in) :: ncid, varid
+    integer, intent(out) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_1D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_1D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    integer, intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_1D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_2D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_2D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_2D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_2D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal), intent(out) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_2D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_2D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_3D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer, intent(in):: ncid, varid
+    integer, intent(out):: values(:, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_3D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_3D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(out) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_4D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_4D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_4D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_4D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(out):: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_4D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_4D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_5D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer, intent(in):: ncid, varid
+    real, intent(out):: values(:, :, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_5D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_5D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_5D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(out):: values(:, :, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_5D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_5D_EightByteReal
+
+end module nf95_get_var_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_gw_var_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_gw_var_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_gw_var_m.F90	(revision 222)
@@ -0,0 +1,336 @@
+! $Id$
+module nf95_gw_var_m
+
+  use nf95_get_var_m, only: NF95_GET_VAR
+  use simple, only: nf95_inquire_variable, nf95_inquire_dimension
+
+  implicit none
+
+  interface nf95_gw_var
+     ! "nf95_gw_var" stands for "NetCDF 1995 get whole variable".
+     ! These procedures read a whole NetCDF variable (coordinate or
+     ! primary) into an array.
+     ! The difference between the procedures is the rank and type of
+     ! argument "values".
+     ! The procedures do not check the type of the NetCDF variable.
+
+     ! Not including double precision procedures in the generic
+     ! interface because we use a compilation option that changes default
+     ! real precision.
+     module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, &
+          nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_real_5d, &
+          nf95_gw_var_int_1d, nf95_gw_var_int_3d
+  end interface
+
+  private
+  public nf95_gw_var
+
+contains
+
+  subroutine nf95_gw_var_real_1d(ncid, varid, values)
+
+    ! Real type, the array has rank 1.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:)
+
+    ! Variables local to the procedure:
+    integer nclen
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 1) then
+       print *, "nf95_gw_var_real_1d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen))
+    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_1d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_2d(ncid, varid, values)
+
+    ! Real type, the array has rank 2.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 2) then
+       print *, "nf95_gw_var_real_2d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 2"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2))
+    if (nclen1 /= 0 .and. nclen2 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_2d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_3d(ncid, varid, values)
+
+    ! Real type, the array has rank 3.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2, nclen3
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 3) then
+       print *, "nf95_gw_var_real_3d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2, nclen3))
+    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_3d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_4d(ncid, varid, values)
+
+    ! Real type, the array has rank 4.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :, :)
+
+    ! Variables local to the procedure:
+    integer len_dim(4), i
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 4) then
+       print *, "nf95_gw_var_real_4d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 4"
+       stop 1
+    end if
+
+    do i = 1, 4
+       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
+    end do
+    deallocate(dimids) ! pointer
+
+    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4)))
+    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_4d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_5d(ncid, varid, values)
+
+    ! Real type, the array has rank 5.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :, :, :)
+
+    ! Variables local to the procedure:
+    integer len_dim(5), i
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 5) then
+       print *, "nf95_gw_var_real_5d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 5"
+       stop 1
+    end if
+
+    do i = 1, 5
+       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
+    end do
+    deallocate(dimids) ! pointer
+
+    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4), len_dim(5)))
+    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_5d
+
+  !************************************
+
+!!$  subroutine nf95_gw_var_dble_1d(ncid, varid, values)
+!!$
+!!$    ! Double precision, the array has rank 1.
+!!$
+!!$    integer, intent(in):: ncid
+!!$    integer, intent(in):: varid
+!!$    double precision, pointer:: values(:)
+!!$
+!!$    ! Variables local to the procedure:
+!!$    integer nclen
+!!$    integer, pointer:: dimids(:)
+!!$
+!!$    !---------------------
+!!$
+!!$    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+!!$
+!!$    if (size(dimids) /= 1) then
+!!$       print *, "nf95_gw_var_dble_1d:"
+!!$       print *, "varid = ", varid
+!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+!!$        stop 1
+!!$    end if
+!!$
+!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+!!$    deallocate(dimids) ! pointer
+!!$
+!!$    allocate(values(nclen))
+!!$    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+!!$
+!!$  end subroutine nf95_gw_var_dble_1d
+!!$
+!!$  !************************************
+!!$
+!!$  subroutine nf95_gw_var_dble_3d(ncid, varid, values)
+!!$
+!!$    ! Double precision, the array has rank 3.
+!!$
+!!$    integer, intent(in):: ncid
+!!$    integer, intent(in):: varid
+!!$    double precision, pointer:: values(:, :, :)
+!!$
+!!$    ! Variables local to the procedure:
+!!$    integer nclen1, nclen2, nclen3
+!!$    integer, pointer:: dimids(:)
+!!$
+!!$    !---------------------
+!!$
+!!$    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+!!$
+!!$    if (size(dimids) /= 3) then
+!!$       print *, "nf95_gw_var_dble_3d:"
+!!$       print *, "varid = ", varid
+!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+!!$       stop 1
+!!$    end if
+!!$
+!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+!!$    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+!!$    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+!!$    deallocate(dimids) ! pointer
+!!$
+!!$    allocate(values(nclen1, nclen2, nclen3))
+!!$    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+!!$
+!!$  end subroutine nf95_gw_var_dble_3d
+!!$
+  !************************************
+
+  subroutine nf95_gw_var_int_1d(ncid, varid, values)
+
+    ! Integer type, the array has rank 1.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    integer, pointer:: values(:)
+
+    ! Variables local to the procedure:
+    integer nclen
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 1) then
+       print *, "nf95_gw_var_int_1d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen))
+    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_int_1d
+
+  !************************************
+
+  subroutine nf95_gw_var_int_3d(ncid, varid, values)
+
+    ! Integer type, the array has rank 3.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    integer, pointer:: values(:, :, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2, nclen3
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 3) then
+       print *, "nf95_gw_var_int_3d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2, nclen3))
+    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_int_3d
+
+end module nf95_gw_var_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_put_att_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_put_att_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_put_att_m.F90	(revision 222)
@@ -0,0 +1,67 @@
+! $Id$
+module nf95_put_att_m
+
+  implicit none
+
+  interface nf95_put_att
+     module procedure nf95_put_att_text, nf95_put_att_one_FourByteInt
+  end interface
+
+  private
+  public nf95_put_att
+
+contains
+
+  subroutine nf95_put_att_text(ncid, varid, name, values, ncerr)
+
+    use netcdf, only: nf90_put_att
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    character(len = *), intent(in) :: name
+    character(len = *), intent(in) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_att_text", ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_put_att_text
+
+  !************************************
+
+  subroutine nf95_put_att_one_FourByteInt(ncid, varid, name, values, ncerr)
+
+    use netcdf, only: nf90_put_att
+    use handle_err_m, only: handle_err
+    use typesizes, only: FourByteInt
+
+    integer, intent(in) :: ncid, varid
+    character(len = *), intent(in) :: name
+    integer(kind = FourByteInt), intent(in) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_att_one_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_att_one_FourByteInt
+
+end module nf95_put_att_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_put_var_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_put_var_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/nf95_put_var_m.F90	(revision 222)
@@ -0,0 +1,335 @@
+! $Id$
+module nf95_put_var_m
+
+  implicit none
+
+  interface nf95_put_var
+     module procedure nf95_put_var_FourByteReal, nf95_put_var_FourByteInt, &
+          nf95_put_var_1D_FourByteReal, nf95_put_var_1D_FourByteInt, &
+          nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, &
+          nf95_put_var_4D_FourByteReal
+  end interface
+
+  private
+  public nf95_put_var
+
+contains
+
+  subroutine nf95_put_var_FourByteReal(ncid, varid, values, start, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    real, intent(in) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_FourByteInt(ncid, varid, values, start, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    integer, intent(in) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_FourByteInt
+
+  !***********************
+
+  subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    integer, intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_put_var_1D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_2D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_2D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_2D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal), intent(in) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_2D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_2D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_3D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_3D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_3D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(in) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_3D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_4D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_4D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_4D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(in):: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_4D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_4D_EightByteReal
+
+end module nf95_put_var_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchdf.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchdf.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchdf.F	(revision 222)
@@ -0,0 +1,106 @@
+*DECK PCHDF
+      REAL FUNCTION PCHDF (K, X, S, IERR)
+C***BEGIN PROLOGUE  PCHDF
+C***SUBSIDIARY
+C***PURPOSE  Computes divided differences for PCHCE and PCHSP
+C***LIBRARY   SLATEC (PCHIP)
+C***TYPE      SINGLE PRECISION (PCHDF-S, DPCHDF-D)
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C***DESCRIPTION
+C
+C          PCHDF:   PCHIP Finite Difference Formula
+C
+C     Uses a divided difference formulation to compute a K-point approx-
+C     imation to the derivative at X(K) based on the data in X and S.
+C
+C     Called by  PCHCE  and  PCHSP  to compute 3- and 4-point boundary
+C     derivative approximations.
+C
+C ----------------------------------------------------------------------
+C
+C     On input:
+C        K      is the order of the desired derivative approximation.
+C               K must be at least 3 (error return if not).
+C        X      contains the K values of the independent variable.
+C               X need not be ordered, but the values **MUST** be
+C               distinct.  (Not checked here.)
+C        S      contains the associated slope values:
+C                  S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1.
+C               (Note that S need only be of length K-1.)
+C
+C     On return:
+C        S      will be destroyed.
+C        IERR   will be set to -1 if K.LT.2 .
+C        PCHDF  will be set to the desired derivative approximation if
+C               IERR=0 or to zero if IERR=-1.
+C
+C ----------------------------------------------------------------------
+C
+C***SEE ALSO  PCHCE, PCHSP
+C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
+C                 Verlag, New York, 1978, pp. 10-16.
+C***ROUTINES CALLED  XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   820503  DATE WRITTEN
+C   820805  Converted to SLATEC library version.
+C   870813  Minor cosmetic changes.
+C   890411  Added SAVE statements (Vers. 3.2).
+C   890411  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   900328  Added TYPE section.  (WRB)
+C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
+C   920429  Revised format and order of references.  (WRB,FNF)
+C   930503  Improved purpose.  (FNF)
+C***END PROLOGUE  PCHDF
+C
+C**End
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  K, IERR
+      REAL  X(K), S(K)
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  I, J
+      REAL  VALUE, ZERO
+      SAVE ZERO
+      DATA  ZERO /0./
+C
+C  CHECK FOR LEGAL VALUE OF K.
+C
+C***FIRST EXECUTABLE STATEMENT  PCHDF
+      IF (K .LT. 3)  GO TO 5001
+C
+C  COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL.
+C
+      DO 10  J = 2, K-1
+         DO 9  I = 1, K-J
+            S(I) = (S(I+1)-S(I))/(X(I+J)-X(I))
+    9    CONTINUE
+   10 CONTINUE
+C
+C  EVALUATE DERIVATIVE AT X(K).
+C
+      VALUE = S(1)
+      DO 20  I = 2, K-1
+         VALUE = S(I) + VALUE*(X(K)-X(I))
+   20 CONTINUE
+C
+C  NORMAL RETURN.
+C
+      IERR = 0
+      PCHDF = VALUE
+      RETURN
+C
+C  ERROR RETURN.
+C
+ 5001 CONTINUE
+C     K.LT.3 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1)
+      PCHDF = ZERO
+      RETURN
+C------------- LAST LINE OF PCHDF FOLLOWS ------------------------------
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchfe.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchfe.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchfe.F	(revision 222)
@@ -0,0 +1,308 @@
+*DECK PCHFE
+      SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
+C***BEGIN PROLOGUE  PCHFE
+C***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
+C            points.  May be used by itself for Hermite interpolation,
+C            or as an evaluator for PCHIM or PCHIC.
+C***LIBRARY   SLATEC (PCHIP)
+C***CATEGORY  E3
+C***TYPE      SINGLE PRECISION (PCHFE-S, DPCHFE-D)
+C***KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
+C             PIECEWISE CUBIC EVALUATION
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C             Lawrence Livermore National Laboratory
+C             P.O. Box 808  (L-316)
+C             Livermore, CA  94550
+C             FTS 532-4275, (510) 422-4275
+C***DESCRIPTION
+C
+C          PCHFE:  Piecewise Cubic Hermite Function Evaluator
+C
+C     Evaluates the cubic Hermite function defined by  N, X, F, D  at
+C     the points  XE(J), J=1(1)NE.
+C
+C     To provide compatibility with PCHIM and PCHIC, includes an
+C     increment between successive values of the F- and D-arrays.
+C
+C ----------------------------------------------------------------------
+C
+C  Calling sequence:
+C
+C        PARAMETER  (INCFD = ...)
+C        INTEGER  N, NE, IERR
+C        REAL  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE)
+C        LOGICAL  SKIP
+C
+C        CALL  PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
+C
+C   Parameters:
+C
+C     N -- (input) number of data points.  (Error return if N.LT.2 .)
+C
+C     X -- (input) real array of independent variable values.  The
+C           elements of X must be strictly increasing:
+C                X(I-1) .LT. X(I),  I = 2(1)N.
+C           (Error return if not.)
+C
+C     F -- (input) real array of function values.  F(1+(I-1)*INCFD) is
+C           the value corresponding to X(I).
+C
+C     D -- (input) real array of derivative values.  D(1+(I-1)*INCFD) is
+C           the value corresponding to X(I).
+C
+C     INCFD -- (input) increment between successive values in F and D.
+C           (Error return if  INCFD.LT.1 .)
+C
+C     SKIP -- (input/output) logical variable which should be set to
+C           .TRUE. if the user wishes to skip checks for validity of
+C           preceding parameters, or to .FALSE. otherwise.
+C           This will save time in case these checks have already
+C           been performed (say, in PCHIM or PCHIC).
+C           SKIP will be set to .TRUE. on normal return.
+C
+C     NE -- (input) number of evaluation points.  (Error return if
+C           NE.LT.1 .)
+C
+C     XE -- (input) real array of points at which the function is to be
+C           evaluated.
+C
+C          NOTES:
+C           1. The evaluation will be most efficient if the elements
+C              of XE are increasing relative to X;
+C              that is,   XE(J) .GE. X(I)
+C              implies    XE(K) .GE. X(I),  all K.GE.J .
+C           2. If any of the XE are outside the interval [X(1),X(N)],
+C              values are extrapolated from the nearest extreme cubic,
+C              and a warning error is returned.
+C
+C     FE -- (output) real array of values of the cubic Hermite function
+C           defined by  N, X, F, D  at the points  XE.
+C
+C     IERR -- (output) error flag.
+C           Normal return:
+C              IERR = 0  (no errors).
+C           Warning error:
+C              IERR.GT.0  means that extrapolation was performed at
+C                 IERR points.
+C           "Recoverable" errors:
+C              IERR = -1  if N.LT.2 .
+C              IERR = -2  if INCFD.LT.1 .
+C              IERR = -3  if the X-array is not strictly increasing.
+C              IERR = -4  if NE.LT.1 .
+C             (The FE-array has not been changed in any of these cases.)
+C               NOTE:  The above errors are checked in the order listed,
+C                   and following arguments have **NOT** been validated.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  CHFEV, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   811020  DATE WRITTEN
+C   820803  Minor cosmetic changes for release 1.
+C   870707  Minor cosmetic changes to prologue.
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890831  Modified array declarations.  (WRB)
+C   890831  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  PCHFE
+C  Programming notes:
+C
+C     1. To produce a double precision version, simply:
+C        a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they
+C           occur,
+C        b. Change the real declaration to double precision,
+C
+C     2. Most of the coding between the call to CHFEV and the end of
+C        the IR-loop could be eliminated if it were permissible to
+C        assume that XE is ordered relative to X.
+C
+C     3. CHFEV does not assume that X1 is less than X2.  thus, it would
+C        be possible to write a version of PCHFE that assumes a strict-
+C        ly decreasing X-array by simply running the IR-loop backwards
+C        (and reversing the order of appropriate tests).
+C
+C     4. The present code has a minor bug, which I have decided is not
+C        worth the effort that would be required to fix it.
+C        If XE contains points in [X(N-1),X(N)], followed by points .LT.
+C        X(N-1), followed by points .GT.X(N), the extrapolation points
+C        will be counted (at least) twice in the total returned in IERR.
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  N, INCFD, NE, IERR
+      REAL  X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*)
+      LOGICAL  SKIP
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  I, IERC, IR, J, JFIRST, NEXT(2), NJ
+C
+C  VALIDITY-CHECK ARGUMENTS.
+C
+C***FIRST EXECUTABLE STATEMENT  PCHFE
+      IF (SKIP)  GO TO 5
+C
+      IF ( N.LT.2 )  GO TO 5001
+      IF ( INCFD.LT.1 )  GO TO 5002
+      DO 1  I = 2, N
+         IF ( X(I).LE.X(I-1) )  GO TO 5003
+    1 CONTINUE
+C
+C  FUNCTION DEFINITION IS OK, GO ON.
+C
+    5 CONTINUE
+      IF ( NE.LT.1 )  GO TO 5004
+      IERR = 0
+      SKIP = .TRUE.
+C
+C  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
+C                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
+      JFIRST = 1
+      IR = 2
+   10 CONTINUE
+C
+C     SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
+C
+         IF (JFIRST .GT. NE)  GO TO 5000
+C
+C     LOCATE ALL POINTS IN INTERVAL.
+C
+         DO 20  J = JFIRST, NE
+            IF (XE(J) .GE. X(IR))  GO TO 30
+   20    CONTINUE
+         J = NE + 1
+         GO TO 40
+C
+C     HAVE LOCATED FIRST POINT BEYOND INTERVAL.
+C
+   30    CONTINUE
+         IF (IR .EQ. N)  J = NE + 1
+C
+   40    CONTINUE
+         NJ = J - JFIRST
+C
+C     SKIP EVALUATION IF NO POINTS IN INTERVAL.
+C
+         IF (NJ .EQ. 0)  GO TO 50
+C
+C     EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
+C
+C       ----------------------------------------------------------------
+        CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR),
+     *              NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC)
+C       ----------------------------------------------------------------
+         IF (IERC .LT. 0)  GO TO 5005
+C
+         IF (NEXT(2) .EQ. 0)  GO TO 42
+C        IF (NEXT(2) .GT. 0)  THEN
+C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
+C           RIGHT OF X(IR).
+C
+            IF (IR .LT. N)  GO TO 41
+C           IF (IR .EQ. N)  THEN
+C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
+               IERR = IERR + NEXT(2)
+               GO TO 42
+   41       CONTINUE
+C           ELSE
+C              WE SHOULD NEVER HAVE GOTTEN HERE.
+               GO TO 5005
+C           ENDIF
+C        ENDIF
+   42    CONTINUE
+C
+         IF (NEXT(1) .EQ. 0)  GO TO 49
+C        IF (NEXT(1) .GT. 0)  THEN
+C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
+C           LEFT OF X(IR-1).
+C
+            IF (IR .GT. 2)  GO TO 43
+C           IF (IR .EQ. 2)  THEN
+C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
+               IERR = IERR + NEXT(1)
+               GO TO 49
+   43       CONTINUE
+C           ELSE
+C              XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
+C              EVALUATION INTERVAL.
+C
+C              FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
+               DO 44  I = JFIRST, J-1
+                  IF (XE(I) .LT. X(IR-1))  GO TO 45
+   44          CONTINUE
+C              NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
+C                     IN CHFEV.
+               GO TO 5005
+C
+   45          CONTINUE
+C              RESET J.  (THIS WILL BE THE NEW JFIRST.)
+               J = I
+C
+C              NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
+               DO 46  I = 1, IR-1
+                  IF (XE(J) .LT. X(I)) GO TO 47
+   46          CONTINUE
+C              NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
+C
+   47          CONTINUE
+C              AT THIS POINT, EITHER  XE(J) .LT. X(1)
+C                 OR      X(I-1) .LE. XE(J) .LT. X(I) .
+C              RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
+C              CYCLING.
+               IR = MAX(1, I-1)
+C           ENDIF
+C        ENDIF
+   49    CONTINUE
+C
+         JFIRST = J
+C
+C     END OF IR-LOOP.
+C
+   50 CONTINUE
+      IR = IR + 1
+      IF (IR .LE. N)  GO TO 10
+C
+C  NORMAL RETURN.
+C
+ 5000 CONTINUE
+      RETURN
+C
+C  ERROR RETURNS.
+C
+ 5001 CONTINUE
+C     N.LT.2 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'PCHFE',
+     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
+      RETURN
+C
+ 5002 CONTINUE
+C     INCFD.LT.1 RETURN.
+      IERR = -2
+      CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR,
+     +   1)
+      RETURN
+C
+ 5003 CONTINUE
+C     X-ARRAY NOT STRICTLY INCREASING.
+      IERR = -3
+      CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING'
+     +   , IERR, 1)
+      RETURN
+C
+ 5004 CONTINUE
+C     NE.LT.1 RETURN.
+      IERR = -4
+      CALL XERMSG ('SLATEC', 'PCHFE',
+     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
+      RETURN
+C
+ 5005 CONTINUE
+C     ERROR RETURN FROM CHFEV.
+C   *** THIS CASE SHOULD NEVER OCCUR ***
+      IERR = -5
+      CALL XERMSG ('SLATEC', 'PCHFE',
+     +   'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2)
+      RETURN
+C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchfe_95_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchfe_95_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchfe_95_m.F90	(revision 222)
@@ -0,0 +1,76 @@
+module PCHFE_95_m
+
+  implicit none
+
+contains
+
+  SUBROUTINE PCHFE_95(X, F, D, SKIP, XE, FE, IERR)
+
+    ! PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
+    !            points.  May be used by itself for Hermite interpolation,
+    !            or as an evaluator for PCHIM or PCHIC.
+    ! CATEGORY  E3
+    ! KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
+    !             PIECEWISE CUBIC EVALUATION
+
+    !          PCHFE:  Piecewise Cubic Hermite Function Evaluator
+    ! Evaluates the cubic Hermite function defined by  X, F, D  at
+    ! the points  XE.
+
+    use assert_eq_m, only: assert_eq
+
+    REAL, intent(in):: X(:) ! real array of independent variable values
+    ! The elements of X must be strictly increasing.
+
+    REAL, intent(in):: F(:) ! real array of function values
+    ! F(I) is the value corresponding to X(I).
+
+    REAL, intent(in):: D(:) ! real array of derivative values
+    ! D(I) is the value corresponding to X(I).
+
+    LOGICAL, intent(inout):: SKIP 
+    ! request to skip checks for validity of "x"
+    ! If "skip" is false then "pchfe" will check that size(x) >= 2 and
+    ! "x" is in strictly ascending order.
+    ! Setting "skip" to true will save time in case these checks have
+    ! already been performed (say, in "PCHIM" or "PCHIC").
+    ! "SKIP" will be set to TRUE on normal return.
+
+    real, intent(in):: XE(:) ! points at which the function is to be evaluated
+    ! NOTES:
+    ! 1. The evaluation will be most efficient if the elements of XE
+    ! are increasing relative to X.
+    ! That is,   XE(J) .GE. X(I)
+    ! implies    XE(K) .GE. X(I),  all K.GE.J
+    ! 2. If any of the XE are outside the interval [X(1),X(N)], values
+    ! are extrapolated from the nearest extreme cubic, and a warning
+    ! error is returned.
+
+    real, intent(out):: FE(:) ! values of the cubic Hermite function
+    ! defined by X, F, D at the points XE
+
+    integer, intent(out):: IERR ! error flag
+    ! Normal return:
+    ! IERR = 0  no error
+    ! Warning error:
+    ! IERR > 0  means that extrapolation was performed at IERR points
+    ! "Recoverable" errors:
+    !              IERR = -1  if N < 2
+    !              IERR = -3  if the X-array is not strictly increasing
+    !              IERR = -4  if NE < 1
+    ! NOTE: The above errors are checked in the order listed, and
+    ! following arguments have **NOT** been validated.
+
+    ! Variables local to the procedure:
+
+    INTEGER  N, NE
+
+    !---------------------------------------
+
+    n = assert_eq(size(x), size(f), size(d), "PCHFE_95 n")
+    ne = assert_eq(size(xe), size(fe), "PCHFE_95 ne")
+    call PCHFE(N, X, F, D, 1, SKIP, NE, XE, FE, IERR)
+
+  end SUBROUTINE PCHFE_95
+
+end module PCHFE_95_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchsp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchsp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchsp.F	(revision 222)
@@ -0,0 +1,388 @@
+*DECK PCHSP
+      SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
+C***BEGIN PROLOGUE  PCHSP
+C***PURPOSE  Set derivatives needed to determine the Hermite represen-
+C            tation of the cubic spline interpolant to given data, with
+C            specified boundary conditions.
+C***LIBRARY   SLATEC (PCHIP)
+C***CATEGORY  E1A
+C***TYPE      SINGLE PRECISION (PCHSP-S, DPCHSP-D)
+C***KEYWORDS  CUBIC HERMITE INTERPOLATION, PCHIP,
+C             PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION
+C***AUTHOR  Fritsch, F. N., (LLNL)
+C             Lawrence Livermore National Laboratory
+C             P.O. Box 808  (L-316)
+C             Livermore, CA  94550
+C             FTS 532-4275, (510) 422-4275
+C***DESCRIPTION
+C
+C          PCHSP:   Piecewise Cubic Hermite Spline
+C
+C     Computes the Hermite representation of the cubic spline inter-
+C     polant to the data given in X and F satisfying the boundary
+C     conditions specified by IC and VC.
+C
+C     To facilitate two-dimensional applications, includes an increment
+C     between successive values of the F- and D-arrays.
+C
+C     The resulting piecewise cubic Hermite function may be evaluated
+C     by PCHFE or PCHFD.
+C
+C     NOTE:  This is a modified version of C. de Boor's cubic spline
+C            routine CUBSPL.
+C
+C ----------------------------------------------------------------------
+C
+C  Calling sequence:
+C
+C        PARAMETER  (INCFD = ...)
+C        INTEGER  IC(2), N, NWK, IERR
+C        REAL  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
+C
+C        CALL  PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
+C
+C   Parameters:
+C
+C     IC -- (input) integer array of length 2 specifying desired
+C           boundary conditions:
+C           IC(1) = IBEG, desired condition at beginning of data.
+C           IC(2) = IEND, desired condition at end of data.
+C
+C           IBEG = 0  to set D(1) so that the third derivative is con-
+C              tinuous at X(2).  This is the "not a knot" condition
+C              provided by de Boor's cubic spline routine CUBSPL.
+C              < This is the default boundary condition. >
+C           IBEG = 1  if first derivative at X(1) is given in VC(1).
+C           IBEG = 2  if second derivative at X(1) is given in VC(1).
+C           IBEG = 3  to use the 3-point difference formula for D(1).
+C                     (Reverts to the default b.c. if N.LT.3 .)
+C           IBEG = 4  to use the 4-point difference formula for D(1).
+C                     (Reverts to the default b.c. if N.LT.4 .)
+C          NOTES:
+C           1. An error return is taken if IBEG is out of range.
+C           2. For the "natural" boundary condition, use IBEG=2 and
+C              VC(1)=0.
+C
+C           IEND may take on the same values as IBEG, but applied to
+C           derivative at X(N).  In case IEND = 1 or 2, the value is
+C           given in VC(2).
+C
+C          NOTES:
+C           1. An error return is taken if IEND is out of range.
+C           2. For the "natural" boundary condition, use IEND=2 and
+C              VC(2)=0.
+C
+C     VC -- (input) real array of length 2 specifying desired boundary
+C           values, as indicated above.
+C           VC(1) need be set only if IC(1) = 1 or 2 .
+C           VC(2) need be set only if IC(2) = 1 or 2 .
+C
+C     N -- (input) number of data points.  (Error return if N.LT.2 .)
+C
+C     X -- (input) real array of independent variable values.  The
+C           elements of X must be strictly increasing:
+C                X(I-1) .LT. X(I),  I = 2(1)N.
+C           (Error return if not.)
+C
+C     F -- (input) real array of dependent variable values to be inter-
+C           polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
+C
+C     D -- (output) real array of derivative values at the data points.
+C           These values will determine the cubic spline interpolant
+C           with the requested boundary conditions.
+C           The value corresponding to X(I) is stored in
+C                D(1+(I-1)*INCFD),  I=1(1)N.
+C           No other entries in D are changed.
+C
+C     INCFD -- (input) increment between successive values in F and D.
+C           This argument is provided primarily for 2-D applications.
+C           (Error return if  INCFD.LT.1 .)
+C
+C     WK -- (scratch) real array of working storage.
+C
+C     NWK -- (input) length of work array.
+C           (Error return if NWK.LT.2*N .)
+C
+C     IERR -- (output) error flag.
+C           Normal return:
+C              IERR = 0  (no errors).
+C           "Recoverable" errors:
+C              IERR = -1  if N.LT.2 .
+C              IERR = -2  if INCFD.LT.1 .
+C              IERR = -3  if the X-array is not strictly increasing.
+C              IERR = -4  if IBEG.LT.0 or IBEG.GT.4 .
+C              IERR = -5  if IEND.LT.0 of IEND.GT.4 .
+C              IERR = -6  if both of the above are true.
+C              IERR = -7  if NWK is too small.
+C               NOTE:  The above errors are checked in the order listed,
+C                   and following arguments have **NOT** been validated.
+C             (The D-array has not been changed in any of these cases.)
+C              IERR = -8  in case of trouble solving the linear system
+C                         for the interior derivative values.
+C             (The D-array may have been changed in this case.)
+C             (             Do **NOT** use it!                )
+C
+C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
+C                 Verlag, New York, 1978, pp. 53-59.
+C***ROUTINES CALLED  PCHDF, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   820503  DATE WRITTEN
+C   820804  Converted to SLATEC library version.
+C   870707  Minor cosmetic changes to prologue.
+C   890411  Added SAVE statements (Vers. 3.2).
+C   890703  Corrected category record.  (WRB)
+C   890831  Modified array declarations.  (WRB)
+C   890831  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   920429  Revised format and order of references.  (WRB,FNF)
+C***END PROLOGUE  PCHSP
+C  Programming notes:
+C
+C     To produce a double precision version, simply:
+C        a. Change PCHSP to DPCHSP wherever it occurs,
+C        b. Change the real declarations to double precision, and
+C        c. Change the constants ZERO, HALF, ... to double precision.
+C
+C  DECLARE ARGUMENTS.
+C
+      INTEGER  IC(2), N, INCFD, NWK, IERR
+      REAL  VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*)
+C
+C  DECLARE LOCAL VARIABLES.
+C
+      INTEGER  IBEG, IEND, INDEX, J, NM1
+      REAL  G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO
+      SAVE ZERO, HALF, ONE, TWO, THREE
+      REAL  PCHDF
+C
+      DATA  ZERO /0./,  HALF /0.5/,  ONE /1./,  TWO /2./,  THREE /3./
+C
+C  VALIDITY-CHECK ARGUMENTS.
+C
+C***FIRST EXECUTABLE STATEMENT  PCHSP
+      IF ( N.LT.2 )  GO TO 5001
+      IF ( INCFD.LT.1 )  GO TO 5002
+      DO 1  J = 2, N
+         IF ( X(J).LE.X(J-1) )  GO TO 5003
+    1 CONTINUE
+C
+      IBEG = IC(1)
+      IEND = IC(2)
+      IERR = 0
+      IF ( (IBEG.LT.0).OR.(IBEG.GT.4) )  IERR = IERR - 1
+      IF ( (IEND.LT.0).OR.(IEND.GT.4) )  IERR = IERR - 2
+      IF ( IERR.LT.0 )  GO TO 5004
+C
+C  FUNCTION DEFINITION IS OK -- GO ON.
+C
+      IF ( NWK .LT. 2*N )  GO TO 5007
+C
+C  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
+C  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
+      DO 5  J=2,N
+         WK(1,J) = X(J) - X(J-1)
+         WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J)
+    5 CONTINUE
+C
+C  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
+C
+      IF ( IBEG.GT.N )  IBEG = 0
+      IF ( IEND.GT.N )  IEND = 0
+C
+C  SET UP FOR BOUNDARY CONDITIONS.
+C
+      IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) )  THEN
+         D(1,1) = VC(1)
+      ELSE IF (IBEG .GT. 2)  THEN
+C        PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
+         DO 10  J = 1, IBEG
+            INDEX = IBEG-J+1
+C           INDEX RUNS FROM IBEG DOWN TO 1.
+            XTEMP(J) = X(INDEX)
+            IF (J .LT. IBEG)  STEMP(J) = WK(2,INDEX)
+   10    CONTINUE
+C                 --------------------------------
+         D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR)
+C                 --------------------------------
+         IF (IERR .NE. 0)  GO TO 5009
+         IBEG = 1
+      ENDIF
+C
+      IF ( (IEND.EQ.1).OR.(IEND.EQ.2) )  THEN
+         D(1,N) = VC(2)
+      ELSE IF (IEND .GT. 2)  THEN
+C        PICK UP LAST IEND POINTS.
+         DO 15  J = 1, IEND
+            INDEX = N-IEND+J
+C           INDEX RUNS FROM N+1-IEND UP TO N.
+            XTEMP(J) = X(INDEX)
+            IF (J .LT. IEND)  STEMP(J) = WK(2,INDEX+1)
+   15    CONTINUE
+C                 --------------------------------
+         D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR)
+C                 --------------------------------
+         IF (IERR .NE. 0)  GO TO 5009
+         IEND = 1
+      ENDIF
+C
+C --------------------( BEGIN CODING FROM CUBSPL )--------------------
+C
+C  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
+C  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
+C  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
+C     WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
+C
+C  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
+C             WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
+C
+      IF (IBEG .EQ. 0)  THEN
+         IF (N .EQ. 2)  THEN
+C           NO CONDITION AT LEFT END AND N = 2.
+            WK(2,1) = ONE
+            WK(1,1) = ONE
+            D(1,1) = TWO*WK(2,2)
+         ELSE
+C           NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
+            WK(2,1) = WK(1,3)
+            WK(1,1) = WK(1,2) + WK(1,3)
+            D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3)
+     *                        + WK(1,2)**2*WK(2,3)) / WK(1,1)
+         ENDIF
+      ELSE IF (IBEG .EQ. 1)  THEN
+C        SLOPE PRESCRIBED AT LEFT END.
+         WK(2,1) = ONE
+         WK(1,1) = ZERO
+      ELSE
+C        SECOND DERIVATIVE PRESCRIBED AT LEFT END.
+         WK(2,1) = TWO
+         WK(1,1) = ONE
+         D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
+      ENDIF
+C
+C  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
+C  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
+C  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
+C
+      NM1 = N-1
+      IF (NM1 .GT. 1)  THEN
+         DO 20 J=2,NM1
+            IF (WK(2,J-1) .EQ. ZERO)  GO TO 5008
+            G = -WK(1,J+1)/WK(2,J-1)
+            D(1,J) = G*D(1,J-1)
+     *                  + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J))
+            WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1))
+   20    CONTINUE
+      ENDIF
+C
+C  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
+C           (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
+C
+C     IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
+C     SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
+C     AT THIS POINT.
+      IF (IEND .EQ. 1)  GO TO 30
+C
+      IF (IEND .EQ. 0)  THEN
+         IF (N.EQ.2 .AND. IBEG.EQ.0)  THEN
+C           NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
+            D(1,2) = WK(2,2)
+            GO TO 30
+         ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0))  THEN
+C           EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
+C           NOT-A-KNOT AT LEFT END POINT).
+            D(1,N) = TWO*WK(2,N)
+            WK(2,N) = ONE
+            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
+            G = -ONE/WK(2,N-1)
+         ELSE
+C           NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
+C           KNOT AT LEFT END POINT.
+            G = WK(1,N-1) + WK(1,N)
+C           DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
+            D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1)
+     *                  + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
+            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
+            G = -G/WK(2,N-1)
+            WK(2,N) = WK(1,N-1)
+         ENDIF
+      ELSE
+C        SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
+         D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
+         WK(2,N) = TWO
+         IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
+         G = -ONE/WK(2,N-1)
+      ENDIF
+C
+C  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
+C
+      WK(2,N) = G*WK(1,N-1) + WK(2,N)
+      IF (WK(2,N) .EQ. ZERO)   GO TO 5008
+      D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N)
+C
+C  CARRY OUT BACK SUBSTITUTION
+C
+   30 CONTINUE
+      DO 40 J=NM1,1,-1
+         IF (WK(2,J) .EQ. ZERO)  GO TO 5008
+         D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J)
+   40 CONTINUE
+C --------------------(  END  CODING FROM CUBSPL )--------------------
+C
+C  NORMAL RETURN.
+C
+      RETURN
+C
+C  ERROR RETURNS.
+C
+ 5001 CONTINUE
+C     N.LT.2 RETURN.
+      IERR = -1
+      CALL XERMSG ('SLATEC', 'PCHSP',
+     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
+      RETURN
+C
+ 5002 CONTINUE
+C     INCFD.LT.1 RETURN.
+      IERR = -2
+      CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR,
+     +   1)
+      RETURN
+C
+ 5003 CONTINUE
+C     X-ARRAY NOT STRICTLY INCREASING.
+      IERR = -3
+      CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING'
+     +   , IERR, 1)
+      RETURN
+C
+ 5004 CONTINUE
+C     IC OUT OF RANGE RETURN.
+      IERR = IERR - 3
+      CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1)
+      RETURN
+C
+ 5007 CONTINUE
+C     NWK TOO SMALL RETURN.
+      IERR = -7
+      CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1)
+      RETURN
+C
+ 5008 CONTINUE
+C     SINGULAR SYSTEM.
+C   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
+C   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
+      IERR = -8
+      CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR,
+     +   1)
+      RETURN
+C
+ 5009 CONTINUE
+C     ERROR RETURN FROM PCHDF.
+C   *** THIS CASE SHOULD NEVER OCCUR ***
+      IERR = -9
+      CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR,
+     +   1)
+      RETURN
+C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchsp_95_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchsp_95_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pchsp_95_m.F90	(revision 222)
@@ -0,0 +1,116 @@
+module pchsp_95_m
+
+  implicit none
+
+contains
+
+  function pchsp_95(x, f, ibeg, iend, vc_beg, vc_end)
+
+    ! PURPOSE: Set derivatives needed to determine the Hermite
+    ! representation of the cubic spline interpolant to given data,
+    ! with specified boundary conditions.
+
+    ! Part of the "pchip" package.
+
+    ! CATEGORY: E1A
+
+    ! KEYWORDS: cubic hermite interpolation, piecewise cubic
+    ! interpolation, spline interpolation
+
+    ! DESCRIPTION: "pchsp" stands for "Piecewise Cubic Hermite Spline"
+    ! Computes the Hermite representation of the cubic spline
+    ! interpolant to the data given in X and F satisfying the boundary
+    ! conditions specified by Ibeg, iend, vc_beg and VC_end.
+
+    ! The resulting piecewise cubic Hermite function may be evaluated
+    ! by "pchfe" or "pchfd".
+
+    ! NOTE: This is a modified version of C. de Boor's cubic spline
+    ! routine "cubspl".
+
+    ! REFERENCE: Carl de Boor, A Practical Guide to Splines, Springer,
+    ! 2001, pages 43-47
+
+    use assert_eq_m, only: assert_eq
+
+    real, intent(in):: x(:)
+    ! independent variable values
+    ! The elements of X must be strictly increasing:
+    !                X(I-1) < X(I),  I = 2...N.
+    !           (Error return if not.)
+    ! (error if size(x) < 2)
+
+    real, intent(in):: f(:)
+    !     dependent variable values to be interpolated
+    !  F(I) is value corresponding to X(I).
+
+    INTEGER, intent(in):: ibeg
+    !     desired boundary condition at beginning of data
+
+    !        IBEG = 0  to set pchsp_95(1) so that the third derivative is con-
+    !              tinuous at X(2).  This is the "not a knot" condition
+    !              provided by de Boor's cubic spline routine CUBSPL.
+    !              This is the default boundary condition.
+    !        IBEG = 1  if first derivative at X(1) is given in VC_BEG.
+    !        IBEG = 2  if second derivative at X(1) is given in VC_BEG.
+    !        IBEG = 3  to use the 3-point difference formula for pchsp_95(1).
+    !              (Reverts to the default boundary condition if size(x) < 3 .)
+    !        IBEG = 4  to use the 4-point difference formula for pchsp_95(1).
+    !              (Reverts to the default boundary condition if size(x) < 4 .)
+
+    !          NOTES:
+    !           1. An error return is taken if IBEG is out of range.
+    !           2. For the "natural" boundary condition, use IBEG=2 and
+    !              VC_BEG=0.
+
+    INTEGER, intent(in):: iend
+    !           IC(2) = IEND, desired condition at end of data.
+    !  IEND may take on the same values as IBEG, but applied to
+    !  derivative at X(N). In case IEND = 1 or 2, The value is given in VC_END.
+
+    !          NOTES:
+    !           1. An error return is taken if IEND is out of range.
+    !           2. For the "natural" boundary condition, use IEND=2 and
+    !              VC_END=0.
+
+    REAL, intent(in), optional:: vc_beg
+    ! desired boundary value, as indicated above.
+    !           VC_BEG need be set only if IBEG = 1 or 2 .
+
+    REAL, intent(in), optional:: vc_end
+    ! desired boundary value, as indicated above.
+    !           VC_END need be set only if Iend = 1 or 2 .
+
+    real pchsp_95(size(x))
+    ! derivative values at the data points
+    !           These values will determine the cubic spline interpolant
+    !           with the requested boundary conditions.
+    !           The value corresponding to X(I) is stored in
+    !                PCHSP_95(I),  I=1...N.
+
+    ! LOCAL VARIABLES:
+    real wk(2, size(x)) ! real array of working storage
+    INTEGER n ! number of data points
+    integer ierr, ic(2)
+    real vc(2)
+
+    !-------------------------------------------------------------------
+
+    n = assert_eq(size(x), size(f), "pchsp_95 n")
+    if ((ibeg == 1 .or. ibeg == 2) .and. .not. present(vc_beg)) then
+       print *, "vc_beg required for IBEG = 1 or 2"
+       stop 1
+    end if
+    if ((iend == 1 .or. iend == 2) .and. .not. present(vc_end)) then
+       print *, "vc_end required for IEND = 1 or 2"
+       stop 1
+    end if
+    ic = (/ibeg, iend/)
+    if (present(vc_beg)) vc(1) = vc_beg
+    if (present(vc_end)) vc(2) = vc_end
+    call PCHSP(IC, VC, N, X, F, pchsp_95, 1, WK, size(WK), IERR)
+    if (ierr /= 0) stop 1
+
+  END function pchsp_95
+
+end module pchsp_95_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pres2lev_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pres2lev_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/pres2lev_mod.F90	(revision 222)
@@ -0,0 +1,79 @@
+! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $
+!
+MODULE pres2lev_mod
+
+CONTAINS 
+
+!******************************************************
+SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp)
+!
+! interpolation lineaire pour passer
+! a une nouvelle discretisation verticale pour
+! les variables de GCM
+! Francois Forget (01/1995)
+! MOdif remy roca 12/97 pour passer de pres2sig
+! Modif F.Codron 07/08 po en 3D
+!**********************************************************
+
+  IMPLICIT NONE
+
+!   Declarations:
+! ==============
+!
+!  ARGUMENTS
+!  """""""""
+  LOGICAL, INTENT(IN) :: ok_invertp
+  INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches
+  INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches
+  
+  INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal
+  REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille
+  REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille
+
+  REAL, INTENT(IN)  :: varo(ni*nj,lmo) ! var dans l'ancienne grille
+  REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille
+
+  REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo)
+
+! Autres variables
+! """"""""""""""""
+  INTEGER ::  ln ,lo, k
+  REAL    :: coef
+
+
+! Inversion de l'ordre des niveaux verticaux
+  IF (ok_invertp) THEN
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lmo+1-lo)
+        zvaro(k,lo)=varo(k,lmo+1-lo)
+      ENDDO
+    ENDDO
+  ELSE
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lo)
+        zvaro(k,lo)=varo(k,lo)
+      ENDDO
+    ENDDO
+  ENDIF 
+
+  DO ln=1,lmn
+    DO lo=1,lmo-1
+      DO k=1,ni*nj
+        IF (pn(k,ln) >= zpo(k,1) ) THEN
+          varn(k,ln) = zvaro(k,1)
+        ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN
+          varn(k,ln) = zvaro(k,lmo)
+        ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN
+          coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo))
+          varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo))
+        ENDIF
+         
+      ENDDO  
+    ENDDO
+  ENDDO                
+
+END SUBROUTINE pres2lev    
+
+END MODULE pres2lev_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr1_lint_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr1_lint_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr1_lint_m.F90	(revision 222)
@@ -0,0 +1,98 @@
+! $Id$
+module regr1_lint_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr1_lint
+     ! Each procedure regrids by linear interpolation.
+     ! The regridding operation is done on the first dimension of the
+     ! input array.
+     ! The difference betwwen the procedures is the rank of the first argument.
+     module procedure regr11_lint, regr12_lint
+  end interface
+
+  private
+  public regr1_lint
+
+contains
+
+  function regr11_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 1.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt !!, polint
+
+    real, intent(in):: vs(:)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(xt)) ! values of the function on the target grid
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs), size(xs), "regr11_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+!!       call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it))
+       vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) &
+            + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr11_lint
+
+  !*********************************************************
+
+  function regr12_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 2.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(xt), size(vs, 2)) ! values of the function on the target grid
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) &
+            + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr12_lint
+
+end module regr1_lint_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr1_step_av_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr1_step_av_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr1_step_av_m.F90	(revision 222)
@@ -0,0 +1,268 @@
+! $Id$
+module regr1_step_av_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr1_step_av
+
+     ! Each procedure regrids a step function by averaging it.
+     ! The regridding operation is done on the first dimension of the
+     ! input array.
+     ! Source grid contains edges of steps.
+     ! Target grid contains positions of cell edges.
+     ! The target grid should be included in the source grid: no
+     ! extrapolation is allowed.
+     ! The difference between the procedures is the rank of the first argument.
+
+     module procedure regr11_step_av, regr12_step_av, regr13_step_av, &
+          regr14_step_av
+  end interface
+
+  private
+  public regr1_step_av
+
+contains
+
+  function regr11_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 1.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1) ! average values on the target grid
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns")
+    nt = size(xt) - 1
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr11_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr11_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr11_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it)":
+       left_edge = xt(it)
+       vt(it) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) &
+            / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr11_step_av
+
+  !********************************************
+
+  function regr12_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 2.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr12_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr12_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr12_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :)":
+       left_edge = xt(it)
+       vt(it, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) &
+            / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr12_step_av
+
+  !********************************************
+
+  function regr13_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 3.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) 
+    ! (average values on the target grid)
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr13_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr13_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr13_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :, :)":
+       left_edge = xt(it)
+       vt(it, :, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :, :) = (vt(it, :, :) &
+            + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr13_step_av
+
+  !********************************************
+
+  function regr14_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 4.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4))
+    ! (average values on the target grid)
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr14_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr14_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr14_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :, :, :)":
+       left_edge = xt(it)
+       vt(it, :, :, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) &
+               * vs(is, :, :, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) &
+            * vs(is, :, :, :)) / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr14_step_av
+
+end module regr1_step_av_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr3_lint_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr3_lint_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/regr3_lint_m.F90	(revision 222)
@@ -0,0 +1,100 @@
+! $Id$
+module regr3_lint_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr3_lint
+     ! Each procedure regrids by linear interpolation.
+     ! The regridding operation is done on the third dimension of the
+     ! input array.
+     ! The difference betwwen the procedures is the rank of the first argument.
+     module procedure regr33_lint, regr34_lint
+  end interface
+
+  private
+  public regr3_lint
+
+contains
+
+  function regr33_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 3.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(vs, 1), size(vs, 2), size(xt))
+    ! (values of the function on the target grid)
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 3), size(xs), "regr33_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) &
+            + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr33_lint
+
+  !*********************************************************
+
+  function regr34_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 4.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :, :, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(vs, 1), size(vs, 2), size(xt), size(vs, 4))
+    ! (values of the function on the target grid)
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 3), size(xs), "regr34_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(:, :, it, :) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b, :) &
+            + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) &
+            / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr34_lint
+
+end module regr3_lint_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/simple.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/simple.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/simple.F90	(revision 222)
@@ -0,0 +1,361 @@
+! $Id$
+module simple
+
+  use handle_err_m, only: handle_err
+  
+  implicit none
+
+  private handle_err
+
+contains
+
+  subroutine nf95_open(path, mode, ncid, chunksize, ncerr)
+
+    use netcdf, only: nf90_open
+
+    character(len=*), intent(in):: path
+    integer, intent(in):: mode
+    integer, intent(out):: ncid
+    integer, intent(inout), optional:: chunksize
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_open(path, mode, ncid, chunksize)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_open " // path, ncerr_not_opt)
+    end if
+
+  end subroutine nf95_open
+
+  !************************
+
+  subroutine nf95_inq_dimid(ncid, name, dimid, ncerr)
+
+    use netcdf, only: nf90_inq_dimid
+
+    integer,             intent(in) :: ncid
+    character (len = *), intent(in) :: name
+    integer,             intent(out) :: dimid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inq_dimid(ncid, name, dimid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inq_dimid " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inq_dimid
+
+  !************************
+
+  subroutine nf95_inquire_dimension(ncid, dimid, name, nclen, ncerr)
+
+    use netcdf, only: nf90_inquire_dimension
+
+    integer,                       intent( in) :: ncid, dimid
+    character (len = *), optional, intent(out) :: name
+    integer,             optional, intent(out) :: nclen
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, nclen)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_dimension", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inquire_dimension
+
+  !************************
+
+  subroutine nf95_inq_varid(ncid, name, varid, ncerr)
+
+    use netcdf, only: nf90_inq_varid
+
+    integer,             intent(in) :: ncid
+    character(len=*), intent(in):: name
+    integer,             intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inq_varid(ncid, name, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inq_varid, name = " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inq_varid
+
+  !************************
+
+  subroutine nf95_inquire_variable(ncid, varid, name, xtype, ndims, dimids, &
+       nAtts, ncerr)
+
+    ! In "nf90_inquire_variable", "dimids" is an assumed-size array.
+    ! This is not optimal.
+    ! We are in the classical case of an array the size of which is
+    ! unknown in the calling procedure, before the call.
+    ! Here we use a better solution: a pointer argument array.
+    ! This procedure associates and defines "dimids" if it is present.
+
+    use netcdf, only: nf90_inquire_variable, nf90_max_var_dims
+
+    integer, intent(in):: ncid, varid
+    character(len = *), optional, intent(out):: name
+    integer, optional, intent(out) :: xtype, ndims
+    integer, dimension(:), optional, pointer :: dimids
+    integer, optional, intent(out) :: nAtts
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+    integer dimids_local(nf90_max_var_dims)
+    integer ndims_not_opt
+
+    !-------------------
+
+    if (present(dimids)) then
+       ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, &
+            ndims_not_opt, dimids_local, nAtts)
+       allocate(dimids(ndims_not_opt)) ! also works if ndims_not_opt == 0
+       dimids = dimids_local(:ndims_not_opt)
+       if (present(ndims)) ndims = ndims_not_opt
+    else
+       ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, ndims, &
+            nAtts=nAtts)
+    end if
+
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_inquire_variable
+
+  !************************
+
+  subroutine nf95_create(path, cmode, ncid, initialsize, chunksize, ncerr)
+    
+    use netcdf, only: nf90_create
+
+    character (len = *), intent(in   ) :: path
+    integer,             intent(in   ) :: cmode
+    integer,             intent(  out) :: ncid
+    integer, optional,   intent(in   ) :: initialsize
+    integer, optional,   intent(inout) :: chunksize
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_create(path, cmode, ncid, initialsize, chunksize)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_create " // path, ncerr_not_opt)
+    end if
+
+  end subroutine nf95_create
+
+  !************************
+
+  subroutine nf95_def_dim(ncid, name, nclen, dimid, ncerr)
+
+    use netcdf, only: nf90_def_dim
+
+    integer,             intent( in) :: ncid
+    character (len = *), intent( in) :: name
+    integer,             intent( in) :: nclen
+    integer,             intent(out) :: dimid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_dim(ncid, name, nclen, dimid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_dim " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_dim
+
+  !***********************
+
+  subroutine nf95_redef(ncid, ncerr)
+
+    use netcdf, only: nf90_redef
+
+    integer, intent( in) :: ncid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_redef(ncid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_redef", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_redef
+  
+  !***********************
+
+  subroutine nf95_enddef(ncid, h_minfree, v_align, v_minfree, r_align, ncerr)
+
+    use netcdf, only: nf90_enddef
+
+    integer,           intent( in) :: ncid
+    integer, optional, intent( in) :: h_minfree, v_align, v_minfree, r_align
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_enddef(ncid, h_minfree, v_align, v_minfree, r_align)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_enddef", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_enddef
+
+  !***********************
+
+  subroutine nf95_close(ncid, ncerr)
+
+    use netcdf, only: nf90_close
+
+    integer, intent( in) :: ncid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_close(ncid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_close", ncerr_not_opt)
+    end if
+
+  end subroutine nf95_close
+
+  !***********************
+
+  subroutine nf95_copy_att(ncid_in, varid_in, name, ncid_out, varid_out, ncerr)
+
+    use netcdf, only: nf90_copy_att
+
+    integer, intent( in):: ncid_in,  varid_in
+    character(len=*), intent( in):: name
+    integer, intent( in):: ncid_out, varid_out
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_copy_att(ncid_in, varid_in, name, ncid_out, varid_out)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_copy_att " // name, ncerr_not_opt, ncid_out)
+    end if
+
+  end subroutine nf95_copy_att
+
+  !***********************
+
+  subroutine nf95_inquire_attribute(ncid, varid, name, xtype, nclen, attnum, &
+       ncerr)
+
+    use netcdf, only: nf90_inquire_attribute
+
+    integer,             intent( in)           :: ncid, varid
+    character (len = *), intent( in)           :: name
+    integer,             intent(out), optional :: xtype, nclen, attnum
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, xtype, nclen, &
+         attnum)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_attribute " // name, ncerr_not_opt, &
+            ncid, varid)
+    end if
+
+  end subroutine nf95_inquire_attribute
+
+  !***********************
+
+  subroutine nf95_inquire(ncid, nDimensions, nVariables, nAttributes, &
+       unlimitedDimId, formatNum, ncerr)
+
+    use netcdf, only: nf90_inquire
+
+    integer,           intent( in) :: ncid
+    integer, optional, intent(out) :: nDimensions, nVariables, nAttributes
+    integer, optional, intent(out) :: unlimitedDimId, formatNum
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire(ncid, nDimensions, nVariables, nAttributes, &
+         unlimitedDimId, formatNum)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inquire
+
+end module simple
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/vampir.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/vampir.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/vampir.F90	(revision 222)
@@ -0,0 +1,86 @@
+module Vampir
+
+  INTEGER,parameter :: VTcaldyn=1
+  INTEGER,parameter :: VTintegre=2
+  INTEGER,parameter :: VTadvection=3
+  INTEGER,parameter :: VTdissipation=4
+  INTEGER,parameter :: VThallo=5
+  INTEGER,parameter :: VTphysiq=6
+  INTEGER,parameter :: VTinca=7
+  
+  INTEGER,parameter :: nb_inst=7
+  INTEGER :: MPE_begin(nb_inst)
+  INTEGER :: MPE_end(nb_inst)
+  
+contains
+
+  subroutine InitVampir
+    implicit none
+
+#ifdef USE_VT
+    include 'VT.inc'
+    integer :: ierr
+    
+    call VTSYMDEF(VTcaldyn,"caldyn","caldyn",ierr)
+    call VTSYMDEF(VTintegre,"integre","integre",ierr)
+    call VTSYMDEF(VTadvection,"advection","advection",ierr)
+    call VTSYMDEF(VTdissipation,"dissipation","dissipation",ierr)
+    call VTSYMDEF(VThallo,"hallo","hallo",ierr)
+    call VTSYMDEF(VTphysiq,"physiq","physiq",ierr)
+    call VTSYMDEF(VTinca,"inca","inca",ierr)
+#endif
+
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    
+    DO i=1,nb_inst
+      ierr = MPE_Log_get_state_eventIDs( MPE_begin(i), MPE_end(i) )
+    ENDDO
+    
+    ierr = MPE_Describe_state( MPE_begin(VTcaldyn), MPE_end(VTcaldyn),"caldyn", "yellow" )
+    ierr = MPE_Describe_state( MPE_begin(VTintegre), MPE_end(VTintegre),"integre", "blue" )
+    ierr = MPE_Describe_state( MPE_begin(VTadvection), MPE_end(VTadvection),"advection", "green" )
+    ierr = MPE_Describe_state( MPE_begin(VTdissipation), MPE_end(VTdissipation),"dissipation", "ivory" )
+    ierr = MPE_Describe_state( MPE_begin(VThallo), MPE_end(VThallo),"hallo", "orange" )
+    ierr = MPE_Describe_state( MPE_begin(VTphysiq), MPE_end(VTphysiq),"physiq", "purple" )
+    ierr = MPE_Describe_state( MPE_begin(VTinca), MPE_end(VTinca),"inca", "LightBlue" )
+#endif     
+  end subroutine InitVampir
+
+  subroutine VTb(number)
+    implicit none
+    INTEGER :: number
+#ifdef USE_VT    
+    include 'VT.inc'
+    integer :: ierr
+    
+    call VTBEGIN(number,ierr)
+#endif 
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    ierr = MPE_Log_event( MPE_begin(number), 0, '' )
+#endif
+
+  end subroutine VTb
+
+  subroutine VTe(number)
+    implicit none
+    INTEGER :: Number
+#ifdef USE_VT    
+    include 'VT.inc'
+    integer :: ierr
+   
+    call VTEND(number,ierr)
+#endif    
+
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    ierr = MPE_Log_event( MPE_end(number), 0, '' )
+#endif
+
+  end subroutine VTe
+  
+end module Vampir
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/write_field.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/write_field.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/write_field.F90	(revision 222)
@@ -0,0 +1,326 @@
+!
+! $Id: write_field.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+module write_field
+implicit none
+
+  integer, parameter :: MaxWriteField = 100
+  integer, dimension(MaxWriteField),save :: FieldId
+  integer, dimension(MaxWriteField),save :: FieldVarId
+  integer, dimension(MaxWriteField),save :: FieldIndex
+  character(len=255), dimension(MaxWriteField) ::  FieldName 
+   
+  integer,save :: NbField = 0
+  
+  interface WriteField
+    module procedure WriteField3d,WriteField2d,WriteField1d
+  end interface WriteField
+  contains
+  
+    function GetFieldIndex(name)
+    implicit none
+      integer          :: GetFieldindex
+      character(len=*) :: name
+    
+      character(len=255) :: TrueName
+      integer            :: i
+       
+      
+      TrueName=TRIM(ADJUSTL(name))
+    
+      GetFieldIndex=-1
+      do i=1,NbField
+        if (TrueName==FieldName(i)) then
+          GetFieldIndex=i
+          exit
+        endif
+      enddo
+    end function GetFieldIndex
+ 
+    subroutine WriteField3d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:,:) :: Field 
+      integer, dimension(3) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),Dim(2),Dim(3))  
+  
+    end subroutine WriteField3d
+    
+    subroutine WriteField2d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:) :: Field 
+      integer, dimension(2) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),Dim(2),1)  
+  
+    end subroutine WriteField2d
+    
+    subroutine WriteField1d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:) :: Field 
+      integer, dimension(1) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),1,1)  
+  
+    end subroutine WriteField1d
+        
+    subroutine WriteField_gen(name,Field,dimx,dimy,dimz)
+    implicit none
+    include 'netcdf.inc'
+      character(len=*) :: name
+      integer :: dimx,dimy,dimz
+      real,dimension(dimx,dimy,dimz) :: Field
+      integer,dimension(dimx*dimy*dimz) :: ndex
+      integer :: status
+      integer :: index
+      integer :: start(4)
+      integer :: count(4)
+      
+           
+      Index=GetFieldIndex(name)
+      if (Index==-1) then
+        call CreateNewField(name,dimx,dimy,dimz)
+	Index=GetFieldIndex(name)
+      else
+        FieldIndex(Index)=FieldIndex(Index)+1.
+      endif
+      
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=FieldIndex(Index)
+
+      count(1)=dimx
+      count(2)=dimy
+      count(3)=dimz
+      count(4)=1
+
+      status = NF_PUT_VARA_DOUBLE(FieldId(Index),FieldVarId(Index),start,count,Field)
+      status = NF_SYNC(FieldId(Index))
+      
+    end subroutine WriteField_gen
+       
+    subroutine CreateNewField(name,dimx,dimy,dimz)
+    implicit none
+    include 'netcdf.inc'  
+      character(len=*) :: name
+      integer :: dimx,dimy,dimz
+      integer :: TabDim(4)
+      integer :: status
+      
+      
+      NbField=NbField+1
+      FieldName(NbField)=TRIM(ADJUSTL(name))
+      FieldIndex(NbField)=1
+      
+      
+      status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField))
+      status = NF_DEF_DIM(FieldId(NbField),'X',dimx,TabDim(1))
+      status = NF_DEF_DIM(FieldId(NbField),'Y',dimy,TabDim(2))
+      status = NF_DEF_DIM(FieldId(NbField),'Z',dimz,TabDim(3))
+      status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(4))
+      status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,4,TabDim,FieldVarId(NbField))
+      status = NF_ENDDEF(FieldId(NbField))
+
+    end subroutine CreateNewField
+    
+    
+    
+  subroutine write_field1D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    character(len=20) :: str
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos
+    character(len=255) :: form
+    character(len=255) :: MaxLen
+    
+    
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'",//)')
+    Dim=shape(Field)
+    MaxLen=int2str(len(trim(int2str(Dim(1)))))
+    ColumnSize=20+6+3+len(trim(int2str(Dim(1))))
+    Nb=0
+    Pos=2
+    do i=1,Dim(1)
+      nb=nb+1
+      
+      if (MOD(nb,NbCol)==0) then
+        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)'
+        Pos=2
+      else
+        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)'
+        Pos=Pos+ColumnSize
+      endif
+      write (id,form,advance='no') i,Field(i)
+    enddo
+     
+    close(id)
+
+  end subroutine write_field1D
+
+  subroutine write_field2D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    character(len=20) :: str
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,j,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos,offset
+    character(len=255) :: form
+    character(len=255) :: spacing
+    
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'",//)')
+    
+    Dim=shape(Field)
+    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3
+    ColumnSize=20+6+3+offset
+
+    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
+    
+    do i=1,Dim(2)
+      nb=0
+      Pos=2
+      do j=1,Dim(1)
+        nb=nb+1
+      
+        if (MOD(nb,NbCol)==0) then
+          form='(t'//trim(int2str(pos))//            &
+               ',"('//trim(int2str(j))//','          &
+                    //trim(int2str(i))//')",t'       & 
+                    //trim(int2str(pos+offset))     &    
+                    //'," ---> ",g22.16,/)'
+          Pos=2
+        else
+          form='(t'//trim(int2str(pos))//            &
+               ',"('//trim(int2str(j))//','          &
+                    //trim(int2str(i))//')",t'       & 
+                    //trim(int2str(pos+offset))     &    
+                    //'," ---> ",g22.16," | ")'
+          Pos=Pos+ColumnSize
+        endif
+        write (id,form,advance='no') Field(j,i)
+      enddo
+      if (MOD(nb,NbCol)==0) then
+        write (id,spacing)
+      else
+        write (id,'("")')
+        write (id,spacing)
+      endif
+    enddo
+     
+  end subroutine write_field2D
+  
+  subroutine write_field3D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,j,k,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos,offset
+    character(len=255) :: form
+    character(len=255) :: spacing
+
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'"//)')
+    
+    Dim=shape(Field)
+    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4
+    ColumnSize=22+6+3+offset
+
+!    open(unit=id,file=name,form=formatted
+   
+    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
+    
+    do i=1,Dim(3)
+    
+      do j=1,Dim(2)
+        nb=0
+        Pos=2
+        
+        do k=1,Dim(1)
+        nb=nb+1
+      
+          if (MOD(nb,NbCol)==0) then
+            form='(t'//trim(int2str(pos))//            &
+                 ',"('//trim(int2str(k))//','          &
+                      //trim(int2str(j))//','          &
+                      //trim(int2str(i))//')",t'       & 
+                      //trim(int2str(pos+offset))      &    
+                      //'," ---> ",g22.16,/)'
+           Pos=2
+          else
+            form='(t'//trim(int2str(pos))//            &
+                 ',"('//trim(int2str(k))//','          &
+                      //trim(int2str(j))//','          &
+                      //trim(int2str(i))//')",t'       & 
+                      //trim(int2str(pos+offset))      &    
+                      //'," ---> ",g22.16," | ")'
+! dépent de l'implémention, sur compaq, c'est necessaire
+!            Pos=Pos+ColumnSize
+          endif
+          write (id,form,advance='no') Field(k,j,i)
+        enddo
+        if (MOD(nb,NbCol)==0) then
+          write (id,spacing)
+        else
+          write (id,'("")')
+          write (id,spacing)
+        endif
+      enddo
+      write (id,spacing)
+    enddo
+    
+    close(id)
+  
+  end subroutine write_field3D  
+  
+  function int2str(int)
+    implicit none
+    integer, parameter :: MaxLen=10
+    integer,intent(in) :: int
+    character(len=MaxLen) :: int2str
+    logical :: flag
+    integer :: i
+    flag=.true.
+    
+    i=int
+    
+    int2str=''
+    do while (flag)
+      int2str=CHAR(MOD(i,10)+48)//int2str
+      i=i/10
+      if (i==0) flag=.false.
+    enddo
+  end function int2str
+
+end module write_field
+  
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/writedynav.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/writedynav.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/writedynav.F90	(revision 222)
@@ -0,0 +1,141 @@
+! $Id: writedynav.F90 1612 2012-01-31 10:11:48Z lguez $
+
+subroutine writedynav(time, vcov, ucov, teta, ppk, phi, q, masse, ps, phis)
+
+#ifdef CPP_IOIPSL
+  USE ioipsl
+#endif
+  USE infotrac, ONLY : nqtot, ttext
+  use com_io_dyn_mod, only : histaveid, histvaveid, histuaveid
+
+  implicit none
+
+  !   Ecriture du fichier histoire au format IOIPSL
+
+  !   Appels succesifs des routines: histwrite
+
+  !   Entree:
+  !      time: temps de l'ecriture
+  !      vcov: vents v covariants
+  !      ucov: vents u covariants
+  !      teta: temperature potentielle
+  !      phi : geopotentiel instantane
+  !      q   : traceurs
+  !      masse: masse
+  !      ps   :pression au sol
+  !      phis : geopotentiel au sol
+
+  !   L. Fairhead, LMD, 03/99
+
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comconst.h"
+  include "comvert.h"
+  include "comgeom.h"
+  include "temps.h"
+  include "ener.h"
+  include "logic.h"
+  include "description.h"
+  include "serre.h"
+  include "iniprint.h"
+
+  !   Arguments
+
+  REAL vcov(ip1jm, llm), ucov(ip1jmp1, llm) 
+  REAL teta(ip1jmp1*llm), phi(ip1jmp1, llm), ppk(ip1jmp1*llm)     
+  REAL ps(ip1jmp1), masse(ip1jmp1, llm)                   
+  REAL phis(ip1jmp1)                  
+  REAL q(ip1jmp1, llm, nqtot)
+  integer time
+
+#ifdef CPP_IOIPSL
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+
+  integer ndex2d(ip1jmp1), ndexu(ip1jmp1*llm), ndexv(ip1jm*llm)
+  INTEGER iq, ii, ll
+  real tm(ip1jmp1*llm)
+  REAL vnat(ip1jm, llm), unat(ip1jmp1, llm) 
+  logical ok_sync
+  integer itau_w
+
+  !-----------------------------------------------------------------
+
+  !  Initialisations
+
+  ndexu = 0
+  ndexv = 0
+  ndex2d = 0
+  ok_sync = .TRUE.
+  tm = 999.999
+  vnat = 999.999
+  unat = 999.999
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  call covnat(llm, ucov, vcov, unat, vnat)
+
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+
+  !  Vents U 
+
+  call histwrite(histuaveid, 'u', itau_w, unat,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Vents V
+
+  call histwrite(histvaveid, 'v', itau_w, vnat,  &
+       iip1*jjm*llm, ndexv)
+
+  !  Temperature potentielle moyennee
+
+  call histwrite(histaveid, 'theta', itau_w, teta,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Temperature moyennee
+
+  do ii = 1, ijp1llm
+     tm(ii) = teta(ii) * ppk(ii)/cpp
+  enddo
+  call histwrite(histaveid, 'temp', itau_w, tm,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Geopotentiel
+
+  call histwrite(histaveid, 'phi', itau_w, phi,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Traceurs
+
+  !  DO iq=1, nqtot
+  !       call histwrite(histaveid, ttext(iq), itau_w, q(:, :, iq), &
+  !                   iip1*jjp1*llm, ndexu)
+  ! enddo
+
+  !  Masse
+
+  call histwrite(histaveid, 'masse', itau_w, masse,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Pression au sol
+
+  call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+
+  ! Geopotentiel au sol
+
+  ! call histwrite(histaveid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+
+  if (ok_sync) then
+     call histsync(histaveid)
+     call histsync(histvaveid)
+     call histsync(histuaveid)
+  ENDIF
+
+#else
+  write(lunout, *) "writedynav: Warning this routine should not be", &
+       " used without ioipsl"
+#endif
+  ! of #ifdef CPP_IOIPSL
+
+end subroutine writedynav
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/writehist.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/writehist.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/writehist.F	(revision 222)
@@ -0,0 +1,136 @@
+!
+! $Id: writehist.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
+
+#ifdef CPP_IOIPSL
+      USE ioipsl
+#endif
+      USE infotrac, ONLY : nqtot, ttext
+      use com_io_dyn_mod, only : histid,histvid,histuid
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      time: temps de l'ecriture
+C      vcov: vents v covariants
+C      ucov: vents u covariants
+C      teta: temperature potentielle
+C      phi : geopotentiel instantane
+C      q   : traceurs
+C      masse: masse
+C      ps   :pression au sol
+C      phis : geopotentiel au sol
+C      
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C
+C   Arguments
+C
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL phis(ip1jmp1)                  
+      REAL q(ip1jmp1,llm,nqtot)
+      integer time
+
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL to work
+C   Variables locales
+C
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+      logical ok_sync
+      integer itau_w
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
+
+C
+C  Initialisations
+C
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
+      ok_sync =.TRUE.
+      itau_w = itau_dyn + time
+!  Passage aux composantes naturelles du vent
+      call covnat(llm, ucov, vcov, unat, vnat)
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      call histwrite(histuid, 'u', itau_w, unat, 
+     .               iip1*jjp1*llm, ndexu)
+C
+C  Vents V
+C
+      call histwrite(histvid, 'v', itau_w, vnat, 
+     .               iip1*jjm*llm, ndexv)
+
+C
+C  Temperature potentielle
+C
+      call histwrite(histid, 'teta', itau_w, teta, 
+     .                iip1*jjp1*llm, ndexu)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi, 
+     .                iip1*jjp1*llm, ndexu)
+C
+C  Traceurs
+C
+!        DO iq=1,nqtot
+!          call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), 
+!     .                   iip1*jjp1*llm, ndexu)
+!        enddo
+!C
+C  Masse
+C
+      call histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+C
+C  Geopotentiel au sol
+C
+!      call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+        call histsync(histuid)
+      endif
+#else
+! tell the user this routine should be run with ioipsl
+      write(lunout,*)"writehist: Warning this routine should not be",
+     &               " used without ioipsl"
+#endif
+! of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/wxios.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/wxios.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/wxios.F90	(revision 222)
@@ -0,0 +1,561 @@
+! $Id: wxios.F90 $
+#ifdef CPP_XIOS
+MODULE wxios
+    USE xios
+    USE iaxis
+    USE iaxis_attr
+    USE icontext_attr
+    USE idate
+    USE idomain_attr
+    USE ifield_attr
+    USE ifile_attr
+    USE ixml_tree
+
+    !Variables disponibles pendant toute l'execution du programme:
+    
+    INTEGER, SAVE :: g_comm
+    CHARACTER(len=100), SAVE :: g_ctx_name
+    TYPE(xios_context), SAVE :: g_ctx
+!$OMP THREADPRIVATE(g_comm,g_cts_name,g_ctx)
+    LOGICAL, SAVE :: g_flag_xml = .FALSE.
+    CHARACTER(len=100) :: g_field_name = "nofield"
+!$OMP THREADPRIVATE(g_flag_xml,g_field_name)
+
+
+    CONTAINS
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !   36day => 36d etc     !!!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    
+    SUBROUTINE reformadate(odate, ndate)
+        CHARACTER(len=*), INTENT(IN) :: odate
+        CHARACTER(len=100), INTENT(OUT) :: ndate
+        
+        INTEGER :: i = 0
+         !!!!!!!!!!!!!!!!!!
+         ! Pour XIOS:
+         !  year : y
+         !  month : mo
+         !  day : d
+         !  hour : h
+         !  minute : mi
+         !  second : s
+         !!!!!!!!!!!!!!!!!!
+
+        i = INDEX(odate, "day")
+        IF (i > 0) THEN
+            ndate = odate(1:i-1)//"d"
+        END IF
+
+        i = INDEX(odate, "hr")
+        IF (i > 0) THEN
+            ndate = odate(1:i-1)//"h"
+        END IF
+
+        i = INDEX(odate, "mth")
+        IF (i > 0) THEN
+            ndate = odate(1:i-1)//"mo"
+        END IF
+        
+        !IF (prt_level >= 10) WRITE(lunout,*) "Xios. ", odate, " => ", ndate
+    END SUBROUTINE reformadate
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !   ave(X) => average etc     !!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    
+    CHARACTER(len=7) FUNCTION reformaop(op)
+        CHARACTER(len=*), INTENT(IN) :: op
+        
+        INTEGER :: i = 0
+        reformaop = "average"
+        
+        IF (op.EQ."inst(X)") THEN
+            reformaop = "instant"
+        END IF
+        
+        IF (op.EQ."once") THEN
+            reformaop = "once"
+        END IF
+        
+        IF (op.EQ."t_max(X)") THEN
+            reformaop = "maximum"
+        END IF
+        
+        IF (op.EQ."t_min(X)") THEN
+            reformaop = "minimum"
+        END IF
+        
+        !IF (prt_level >= 10) WRITE(lunout,*) "Xios. ", op, " => ", reformaop
+    END FUNCTION reformaop
+
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Routine d'initialisation      !!!!!!!!!!!!!
+    !     A lancer juste aprÃÂšs mpi_init !!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    SUBROUTINE wxios_init(xios_ctx_name, locom, outcom, type_ocean)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+      CHARACTER(len=*), INTENT(IN) :: xios_ctx_name
+      INTEGER, INTENT(IN), OPTIONAL :: locom
+      INTEGER, INTENT(OUT), OPTIONAL :: outcom
+      CHARACTER(len=6), INTENT(IN), OPTIONAL :: type_ocean
+
+    
+        TYPE(xios_context) :: xios_ctx
+        INTEGER :: xios_comm
+
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: Initialization"
+
+
+
+        IF (PRESENT(locom)) THEN
+          CALL xios_initialize(xios_ctx_name, local_comm = locom, return_comm = xios_comm )
+          IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: ctx=",xios_ctx_name," local_comm=",locom,", return_comm=",xios_comm
+        ELSE
+          CALL xios_initialize(xios_ctx_name, return_comm = xios_comm )
+          IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: ctx=",xios_ctx_name," return_comm=",xios_comm
+        END IF
+        
+        IF (PRESENT(outcom)) THEN
+          outcom = xios_comm
+          IF (prt_level >= 10) WRITE(lunout,*) "wxios_init: ctx=",xios_ctx_name," outcom=",outcom
+        END IF
+        
+        !Enregistrement des variables globales:
+        g_comm = xios_comm
+        g_ctx_name = xios_ctx_name
+        
+        ! Si couple alors init fait dans cpl_init
+        IF (.not. PRESENT(type_ocean)) THEN
+            CALL wxios_context_init()
+        ENDIF
+
+    END SUBROUTINE wxios_init
+
+    SUBROUTINE wxios_context_init()
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        TYPE(xios_context) :: xios_ctx
+
+        !Initialisation du contexte:
+        CALL xios_context_initialize(g_ctx_name, g_comm)
+        CALL xios_get_handle(g_ctx_name, xios_ctx)    !RÃÂ©cupÃÂ©ration
+        CALL xios_set_current_context(xios_ctx)            !Activation
+        g_ctx = xios_ctx
+
+        IF (prt_level >= 10) THEN
+          WRITE(lunout,*) "wxios_context_init: Current context is ",trim(g_ctx_name)
+          WRITE(lunout,*) "     now call xios_solve_inheritance()"
+        ENDIF
+        !Une premiÃÂšre analyse des hÃÂ©ritages:
+        CALL xios_solve_inheritance()
+    END SUBROUTINE wxios_context_init
+
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Routine de paramÃÂ©trisation !!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    SUBROUTINE wxios_set_cal(pasdetemps, calendrier, annee, mois, jour, heure)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+     !ParamÃÂštres:
+     CHARACTER(len=*), INTENT(IN) :: calendrier
+     INTEGER, INTENT(IN) :: annee, mois, jour
+     REAL, INTENT(IN) :: pasdetemps, heure
+     
+     !Variables:
+     CHARACTER(len=80) :: abort_message
+     CHARACTER(len=19) :: date
+     INTEGER :: njour = 1
+     
+     !Variables pour xios:
+     TYPE(xios_time) :: mdtime
+     !REAL(kind = 8) :: year=0, month=0, day=0, hour=0, minute=0, second=0
+     
+        mdtime = xios_time(0, 0, 0, 0, 0, pasdetemps)
+
+        !RÃÂ©glage du calendrier:
+        SELECT CASE (calendrier)
+            CASE('earth_360d')
+                CALL xios_set_context_attr_hdl(g_ctx, calendar_type= "D360")
+                IF (prt_level >= 10) WRITE(lunout,*) 'wxios_set_cal: Calendrier terrestre a 360 jours/an'
+            CASE('earth_365d')
+                CALL xios_set_context_attr_hdl(g_ctx, calendar_type= "NoLeap")
+                IF (prt_level >= 10) WRITE(lunout,*) 'wxios_set_cal: Calendrier terrestre a 365 jours/an'
+            CASE('earth_366d')
+                CALL xios_set_context_attr_hdl(g_ctx, calendar_type= "Gregorian")
+                IF (prt_level >= 10) WRITE(lunout,*) 'wxios_set_cal: Calendrier gregorien'
+            CASE DEFAULT
+                abort_message = 'wxios_set_cal: Mauvais choix de calendrier'
+                CALL abort_gcm('Gcm:Xios',abort_message,1)
+        END SELECT
+        
+        !Formatage de la date de dÃÂ©part:
+        WRITE(date, "(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") annee, mois, jour
+        
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_set_cal: Initial time: ", date
+        
+        CALL xios_set_context_attr_hdl(g_ctx, start_date= date)
+        
+        !Et enfin,le pas de temps:
+        CALL xios_set_timestep(mdtime)
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_set_cal: ts=",mdtime
+    END SUBROUTINE wxios_set_cal
+
+    SUBROUTINE wxios_set_timestep(ts)
+        REAL, INTENT(IN) :: ts
+        TYPE(xios_time) :: mdtime     
+
+        mdtime = xios_time(0, 0, 0, 0, 0, ts)
+
+        CALL xios_set_timestep(mdtime)
+    END SUBROUTINE wxios_set_timestep
+
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour initialiser un domaine !!!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_domain_param(dom_id, is_sequential, ni, nj, ni_glo, nj_glo,        &
+                                    ibegin, iend, ii_begin, ii_end, jbegin, jend,       &
+                                    data_ni, data_ibegin, data_iend,                    &
+                                    io_lat, io_lon,is_south_pole,mpi_rank)
+         
+
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER(len=*),INTENT(IN) :: dom_id ! domain identifier
+        LOGICAL,INTENT(IN) :: is_sequential ! flag
+        INTEGER,INTENT(IN) :: ni ! local MPI domain number of longitudes
+        INTEGER,INTENT(IN) :: nj ! local MPI domain number of latitudes
+        INTEGER,INTENT(IN) :: ni_glo ! global grid number of longitudes
+        INTEGER,INTENT(IN) :: nj_glo ! global grid number of latitudes
+        INTEGER,INTENT(IN) :: ibegin ! start index, on global grid, of local MPI domain 
+        INTEGER,INTENT(IN) :: iend ! end index, on global grid, of local MPI domain
+        INTEGER,INTENT(IN) :: ii_begin ! i index at which local data starts (first row)
+        INTEGER,INTENT(IN) :: ii_end ! i index at which local data ends (last row)
+        INTEGER,INTENT(IN) :: jbegin ! start index, on global grid, of local MPI domain 
+        INTEGER,INTENT(IN) :: jend ! end index, on global grid, of local MPI domain
+        INTEGER,INTENT(IN) :: data_ni
+        INTEGER,INTENT(IN) :: data_ibegin
+        INTEGER,INTENT(IN) :: data_iend
+        REAL,INTENT(IN) :: io_lat(:) ! latitudes (of global grid)
+        REAL,INTENT(IN) :: io_lon(:) ! longitudes (of global grid)
+        logical,intent(in) :: is_south_pole ! does this process include the south pole?
+        integer,intent(in) :: mpi_rank ! rank of process
+        
+        TYPE(xios_domain) :: dom
+        LOGICAL :: boool
+        
+        !Masque pour les problÃÂšmes de recouvrement MPI:
+        LOGICAL :: mask(ni,nj)
+        
+        !On rÃÂ©cupÃÂšre le handle:
+        CALL xios_get_domain_handle(dom_id, dom)
+        
+        IF (prt_level >= 10) THEN
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ni:",ni," ni_glo:", ni_glo, " nj:", nj, " nj_glo:", nj_glo
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ibegin:",ibegin," iend:", iend, " jbegin:", jbegin, " jend:", jend
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ii_begin:",ii_begin," ii_end:", ii_end
+          WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," Size io_lon:", SIZE(io_lon(ibegin:iend)), " io_lat:", SIZE(io_lat(jbegin:jend))
+        ENDIF
+        
+        !On parametrise le domaine:
+        CALL xios_set_domain_attr_hdl(dom, ni_glo=ni_glo, ibegin=ibegin, ni=ni)
+        CALL xios_set_domain_attr_hdl(dom, nj_glo=nj_glo, jbegin=jbegin, nj=nj, data_dim=2)
+        CALL xios_set_domain_attr_hdl(dom, lonvalue=io_lon(ibegin:iend), latvalue=io_lat(jbegin:jend))
+
+        IF (.NOT.is_sequential) THEN
+            mask(:,:)=.TRUE.
+            if (ii_begin>1) mask(1:ii_begin-1,1) = .FALSE.
+            if (ii_end<ni) mask(ii_end+1:ni,nj) = .FALSE.
+            ! special case for south pole
+            if ((ii_end.eq.1).and.(is_south_pole)) mask(1:ni,nj)=.true.
+            IF (prt_level >= 10) THEN
+              WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:,1)=",mask(:,1)
+              WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:,nj)=",mask(:,nj)
+            ENDIF
+            CALL xios_set_domain_attr_hdl(dom, mask=mask)
+        END IF
+
+         CALL xios_is_defined_domain_attr_hdl(dom,ni_glo=boool)
+        !VÃÂ©rification:
+        IF (xios_is_valid_domain(dom_id)) THEN
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_domain_param: Domain initialized: ", trim(dom_id), boool
+        ELSE
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_domain_param: Invalid domain: ", trim(dom_id)
+        END IF
+    END SUBROUTINE wxios_domain_param
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour dÃÂ©clarer un axe vertical !!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_vaxis(axis_id, axis_size, axis_value)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER (len=*), INTENT(IN) :: axis_id
+        INTEGER, INTENT(IN) :: axis_size
+        REAL, DIMENSION(axis_size), INTENT(IN) :: axis_value
+        
+!        TYPE(xios_axisgroup) :: axgroup
+!        TYPE(xios_axis) :: ax
+!        CHARACTER(len=50) :: axis_id 
+        
+!        IF (len_trim(axisgroup_id).gt.len(axis_id)) THEN
+!          WRITE(lunout,*) "wxios_add_vaxis: error, size of axis_id too small!!"
+!          WRITE(lunout,*) "     increase it to at least ",len_trim(axisgroup_id)
+!          CALL abort_gcm("wxios_add_vaxis","len(axis_id) too small",1)
+!        ENDIF
+!        axis_id=trim(axisgroup_id)
+        
+        !On rÃÂ©cupÃÂšre le groupe d'axes qui va bien:
+        !CALL xios_get_axisgroup_handle(axisgroup_id, axgroup)
+        
+        !On ajoute l'axe correspondant ÃÂ  ce fichier:
+        !CALL xios_add_axis(axgroup, ax, TRIM(ADJUSTL(axis_id)))
+        
+        !Et on le parametrise:
+        !CALL xios_set_axis_attr_hdl(ax, size=axis_size, value=axis_value)
+        
+        ! Ehouarn: New way to declare axis, without axis_group:
+        CALL xios_set_axis_attr(trim(axis_id),size=axis_size,value=axis_value)
+        
+        !VÃÂ©rification:
+        IF (xios_is_valid_axis(TRIM(ADJUSTL(axis_id)))) THEN
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_vaxis: Axis created: ", TRIM(ADJUSTL(axis_id))
+        ELSE
+            WRITE(lunout,*) "wxios_add_vaxis: Invalid axis: ", TRIM(ADJUSTL(axis_id))
+        END IF
+
+    END SUBROUTINE wxios_add_vaxis
+    
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour dÃÂ©clarer un fichier  !!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_file(fname, ffreq, flvl)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER(len=*), INTENT(IN) :: fname
+        CHARACTER(len=*), INTENT(IN) :: ffreq
+        INTEGER, INTENT(IN) :: flvl
+        
+        TYPE(xios_file) :: x_file
+        TYPE(xios_filegroup) :: x_fg
+        CHARACTER(len=100) :: nffreq
+        
+        !On regarde si le fichier n'est pas dÃÂ©fini par XML:
+        IF (.NOT.xios_is_valid_file(fname)) THEN
+            !On crÃÂ©ÃÂ© le noeud:
+            CALL xios_get_filegroup_handle("defile", x_fg)
+            CALL xios_add_file(x_fg, x_file, fname)
+        
+            !On reformate la frÃÂ©quence:
+            CALL reformadate(ffreq, nffreq)
+        
+            !On configure:
+            CALL xios_set_file_attr_hdl(x_file, name="X"//fname,&
+                output_freq=TRIM(ADJUSTL(nffreq)), output_level=flvl, enabled=.TRUE.)
+        
+            IF (xios_is_valid_file("X"//fname)) THEN
+                IF (prt_level >= 10) THEN
+                  WRITE(lunout,*) "wxios_add_file: New file: ", "X"//fname
+                  WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
+                ENDIF
+            ELSE
+                WRITE(lunout,*) "wxios_add_file: Error, invalid file: ", "X"//trim(fname)
+                WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
+            END IF
+        ELSE
+            IF (prt_level >= 10) THEN
+              WRITE(lunout,*) "wxios_add_file: File ",trim(fname), " dÃÂ©fined using XML."
+            ENDIF
+            ! Ehouarn: add an enable=.true. on top of xml definitions... why???
+            CALL xios_set_file_attr(fname, enabled=.TRUE.)
+        END IF
+    END SUBROUTINE wxios_add_file
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour crÃÂ©er un champ      !!!!!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_field(fieldname, fieldgroup, fieldlongname, fieldunit)
+        USE netcdf, only: nf90_fill_real
+
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+        
+        CHARACTER(len=*), INTENT(IN) :: fieldname
+        TYPE(xios_fieldgroup), INTENT(IN) :: fieldgroup
+        CHARACTER(len=*), INTENT(IN) :: fieldlongname
+        CHARACTER(len=*), INTENT(IN) :: fieldunit
+        
+        TYPE(xios_field) :: field
+        CHARACTER(len=10) :: newunit
+        REAL(KIND=8) :: def
+        
+        !La valeur par dÃÂ©faut des champs non dÃÂ©finis:
+        def = nf90_fill_real
+        
+        IF (fieldunit .EQ. " ") THEN
+            newunit = "-"
+        ELSE
+            newunit = fieldunit
+        ENDIF
+        
+        !On ajoute le champ:
+        CALL xios_add_field(fieldgroup, field, fieldname)
+        !IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field: ",fieldname,fieldgroup, fieldlongname, fieldunit
+        
+        !On rentre ses paramÃÂštres:
+        CALL xios_set_field_attr_hdl(field, standard_name=fieldlongname, unit=newunit, default_value=def)
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field: Field ",trim(fieldname), "cree:"
+        IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field: long_name=",trim(fieldlongname),"; unit=",trim(newunit),";  default_value=",nf90_fill_real
+
+    END SUBROUTINE wxios_add_field
+    
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Pour dÃÂ©clarer un champ      !!!!!!!!!!!!!!!!!
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    SUBROUTINE wxios_add_field_to_file(fieldname, fdim, fid, fname, fieldlongname, fieldunit, field_level, op)
+        IMPLICIT NONE
+        INCLUDE 'iniprint.h'
+
+        CHARACTER(len=*), INTENT(IN) :: fieldname
+        INTEGER, INTENT(IN)          :: fdim, fid
+        CHARACTER(len=*), INTENT(IN) :: fname
+        CHARACTER(len=*), INTENT(IN) :: fieldlongname
+        CHARACTER(len=*), INTENT(IN) :: fieldunit
+        INTEGER, INTENT(IN)          :: field_level
+        CHARACTER(len=*), INTENT(IN) :: op
+        
+        CHARACTER(len=20) :: axis_id ! Ehouarn: dangerous...
+        CHARACTER(len=100) :: operation
+        TYPE(xios_file) :: f
+        TYPE(xios_field) :: field
+        TYPE(xios_fieldgroup) :: fieldgroup
+        LOGICAL :: bool=.FALSE.
+        INTEGER :: lvl =0
+        
+        
+        ! Ajout Abd pour NMC:
+        IF (fid.LE.6) THEN
+          axis_id="presnivs"
+        ELSE
+          axis_id="plev"
+        ENDIF
+        
+        !on prÃÂ©pare le nom de l'opÃÂ©ration:
+        operation = reformaop(op)
+        
+        
+        !On selectionne le bon groupe de champs:
+        IF (fdim.EQ.2) THEN
+          CALL xios_get_fieldgroup_handle("fields_2D", fieldgroup)
+        ELSE
+          CALL xios_get_fieldgroup_handle("fields_3D", fieldgroup)
+        ENDIF
+        
+        !On regarde si le champ ÃÂ  dÃÂ©jÃÂ  ÃÂ©tÃÂ© crÃÂ©ÃÂ© ou non:
+        IF (xios_is_valid_field(fieldname) .AND. .NOT. g_field_name == fieldname) THEN
+            !Si ce champ existe via XML (ie, dÃÂšs le premier passage, ie g_field_name != fieldname) alors rien d'autre ÃÂ  faire
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field_to_file: Field ", trim(fieldname), "exists via XML"
+            g_flag_xml = .TRUE.
+            g_field_name = fieldname
+
+        ELSE IF (.NOT. g_field_name == fieldname) THEN
+            !Si premier pssage et champ indÃÂ©fini, alors on le crÃÂ©ÃÂ©
+
+            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field_to_file: Field ", trim(fieldname), "does not exist"
+            
+            !On le crÃÂ©ÃÂ©:
+            CALL wxios_add_field(fieldname,  fieldgroup, fieldlongname, fieldunit)
+            IF (xios_is_valid_field(fieldname)) THEN
+                IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_field_to_file: Field ", trim(fieldname), "created"
+            ENDIF
+
+            g_flag_xml = .FALSE.
+            g_field_name = fieldname
+
+        END IF
+
+        IF (.NOT. g_flag_xml) THEN
+            !Champ existe dÃÂ©jÃÂ , mais pas XML, alors on l'ajoute
+            !On ajoute le champ:
+            CALL xios_get_file_handle(fname, f)
+            CALL xios_add_fieldtofile(f, field)
+            
+            
+            !L'operation, sa frequence:
+            CALL xios_set_field_attr_hdl(field, field_ref=fieldname, operation=TRIM(ADJUSTL(operation)), freq_op="1ts", prec=4)
+
+            
+            !On rentre ses paramÃÂštres:
+            CALL xios_set_field_attr_hdl(field, level=field_level, enabled=.TRUE.)
+            
+            IF (fdim.EQ.2) THEN
+                !Si c'est un champ 2D:
+                IF (prt_level >= 10) THEN
+                  WRITE(lunout,*) "wxios_add_field_to_file: 2D Field ", trim(fieldname), " in ", "X"//trim(fname) ," configured with:"
+                  WRITE(lunout,*) "wxios_add_field_to_file: op=", TRIM(ADJUSTL(operation))
+                  WRITE(lunout,*) "wxios_add_field_to_file: freq_op=1ts","; lvl=",field_level
+                ENDIF
+            ELSE
+                !Si 3D :
+                !On ajoute l'axe vertical qui va bien:
+                CALL xios_set_field_attr_hdl(field, axis_ref=TRIM(ADJUSTL(axis_id)))
+                
+                IF (prt_level >= 10) THEN
+                  WRITE(lunout,*) "wxios_add_field_to_file: 3D Field",trim(fieldname), " in ", "X"//trim(fname), "configured with:"
+                  WRITE(lunout,*) "wxios_add_field_to_file: freq_op=1ts","; lvl=",field_level
+                  WRITE(lunout,*) "wxios_add_field_to_file: axis=",TRIM(ADJUSTL(axis_id))
+                ENDIF
+            END IF
+        
+        ELSE
+            !Sinon on se contente de l'activer:
+            CALL xios_set_field_attr(fieldname, enabled=.TRUE.)
+            !NB: This will override an enable=.false. set by a user in the xml file;
+            !   then the only way to not output the field is by changing its
+            !   output level
+        ENDIF       
+        
+    END SUBROUTINE wxios_add_field_to_file
+    
+!    SUBROUTINE wxios_update_calendar(ito)
+!        INTEGER, INTENT(IN) :: ito
+!        CALL xios_update_calendar(ito)
+!    END SUBROUTINE wxios_update_calendar
+!    
+!    SUBROUTINE wxios_write_2D(fieldname, fdata)
+!        CHARACTER(len=*), INTENT(IN) :: fieldname
+!        REAL, DIMENSION(:,:), INTENT(IN) :: fdata
+!
+!        CALL xios_send_field(fieldname, fdata)
+!    END SUBROUTINE wxios_write_2D
+    
+!    SUBROUTINE wxios_write_3D(fieldname, fdata)
+!        CHARACTER(len=*), INTENT(IN) :: fieldname
+!        REAL, DIMENSION(:,:,:), INTENT(IN) :: fdata
+!        
+!        CALL xios_send_field(fieldname, fdata)
+!    END SUBROUTINE wxios_write_3D
+    
+    SUBROUTINE wxios_closedef()
+        CALL xios_close_context_definition()
+        CALL xios_update_calendar(0)
+    END SUBROUTINE wxios_closedef
+    
+    SUBROUTINE wxios_close()
+        CALL xios_context_finalize()
+         CALL xios_finalize()
+     END SUBROUTINE wxios_close
+END MODULE wxios
+#endif
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xercnt.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xercnt.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xercnt.F	(revision 222)
@@ -0,0 +1,60 @@
+*DECK XERCNT
+      SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
+C***BEGIN PROLOGUE  XERCNT
+C***SUBSIDIARY
+C***PURPOSE  Allow user control over handling of errors.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERCNT-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        Allows user control over handling of individual errors.
+C        Just after each message is recorded, but before it is
+C        processed any further (i.e., before it is printed or
+C        a decision to abort is made), a call is made to XERCNT.
+C        If the user has provided his own version of XERCNT, he
+C        can then override the value of KONTROL used in processing
+C        this message by redefining its value.
+C        KONTRL may be set to any value from -2 to 2.
+C        The meanings for KONTRL are the same as in XSETF, except
+C        that the value of KONTRL changes only for this message.
+C        If KONTRL is set to a value outside the range from -2 to 2,
+C        it will be moved back into that range.
+C
+C     Description of Parameters
+C
+C      --Input--
+C        LIBRAR - the library that the routine is in.
+C        SUBROU - the subroutine that XERMSG is being called from
+C        MESSG  - the first 20 characters of the error message.
+C        NERR   - same as in the call to XERMSG.
+C        LEVEL  - same as in the call to XERMSG.
+C        KONTRL - the current value of the control flag as set
+C                 by a call to XSETF.
+C
+C      --Output--
+C        KONTRL - the new value of KONTRL.  If KONTRL is not
+C                 defined, it will remain at its original value.
+C                 This changed value of control affects only
+C                 the current occurrence of the current message.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900206  Routine changed from user-callable to subsidiary.  (WRB)
+C   900510  Changed calling sequence to include LIBRARY and SUBROUTINE
+C           names, changed routine name from XERCTL to XERCNT.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERCNT
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+C***FIRST EXECUTABLE STATEMENT  XERCNT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xerhlt.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xerhlt.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xerhlt.F	(revision 222)
@@ -0,0 +1,39 @@
+*DECK XERHLT
+      SUBROUTINE XERHLT (MESSG)
+C***BEGIN PROLOGUE  XERHLT
+C***SUBSIDIARY
+C***PURPOSE  Abort program execution and print error message.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERHLT-A)
+C***KEYWORDS  ABORT PROGRAM EXECUTION, ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        ***Note*** machine dependent routine
+C        XERHLT aborts the execution of the program.
+C        The error message causing the abort is given in the calling
+C        sequence, in case one needs it for printing on a dayfile,
+C        for example.
+C
+C     Description of Parameters
+C        MESSG is as in XERMSG.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900206  Routine changed from user-callable to subsidiary.  (WRB)
+C   900510  Changed calling sequence to delete length of character
+C           and changed routine name from XERABT to XERHLT.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERHLT
+      CHARACTER*(*) MESSG
+C***FIRST EXECUTABLE STATEMENT  XERHLT
+      STOP
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xermsg.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xermsg.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xermsg.F	(revision 222)
@@ -0,0 +1,364 @@
+*DECK XERMSG
+      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
+C***BEGIN PROLOGUE  XERMSG
+C***PURPOSE  Process error messages for SLATEC and other libraries.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERMSG-A)
+C***KEYWORDS  ERROR MESSAGE, XERROR
+C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
+C***DESCRIPTION
+C
+C   XERMSG processes a diagnostic message in a manner determined by the
+C   value of LEVEL and the current value of the library error control
+C   flag, KONTRL.  See subroutine XSETF for details.
+C
+C    LIBRAR   A character constant (or character variable) with the name
+C             of the library.  This will be 'SLATEC' for the SLATEC
+C             Common Math Library.  The error handling package is
+C             general enough to be used by many libraries
+C             simultaneously, so it is desirable for the routine that
+C             detects and reports an error to identify the library name
+C             as well as the routine name.
+C
+C    SUBROU   A character constant (or character variable) with the name
+C             of the routine that detected the error.  Usually it is the
+C             name of the routine that is calling XERMSG.  There are
+C             some instances where a user callable library routine calls
+C             lower level subsidiary routines where the error is
+C             detected.  In such cases it may be more informative to
+C             supply the name of the routine the user called rather than
+C             the name of the subsidiary routine that detected the
+C             error.
+C
+C    MESSG    A character constant (or character variable) with the text
+C             of the error or warning message.  In the example below,
+C             the message is a character constant that contains a
+C             generic message.
+C
+C                   CALL XERMSG ('SLATEC', 'MMPY',
+C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
+C                  *3, 1)
+C
+C             It is possible (and is sometimes desirable) to generate a
+C             specific message--e.g., one that contains actual numeric
+C             values.  Specific numeric values can be converted into
+C             character strings using formatted WRITE statements into
+C             character variables.  This is called standard Fortran
+C             internal file I/O and is exemplified in the first three
+C             lines of the following example.  You can also catenate
+C             substrings of characters to construct the error message.
+C             Here is an example showing the use of both writing to
+C             an internal file and catenating character strings.
+C
+C                   CHARACTER*5 CHARN, CHARL
+C                   WRITE (CHARN,10) N
+C                   WRITE (CHARL,10) LDA
+C                10 FORMAT(I5)
+C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
+C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
+C                  *   CHARL, 3, 1)
+C
+C             There are two subtleties worth mentioning.  One is that
+C             the // for character catenation is used to construct the
+C             error message so that no single character constant is
+C             continued to the next line.  This avoids confusion as to
+C             whether there are trailing blanks at the end of the line.
+C             The second is that by catenating the parts of the message
+C             as an actual argument rather than encoding the entire
+C             message into one large character variable, we avoid
+C             having to know how long the message will be in order to
+C             declare an adequate length for that large character
+C             variable.  XERMSG calls XERPRN to print the message using
+C             multiple lines if necessary.  If the message is very long,
+C             XERPRN will break it into pieces of 72 characters (as
+C             requested by XERMSG) for printing on multiple lines.
+C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
+C             so that the total line length could be 76 characters.
+C             Note also that XERPRN scans the error message backwards
+C             to ignore trailing blanks.  Another feature is that
+C             the substring '$$' is treated as a new line sentinel
+C             by XERPRN.  If you want to construct a multiline
+C             message without having to count out multiples of 72
+C             characters, just use '$$' as a separator.  '$$'
+C             obviously must occur within 72 characters of the
+C             start of each line to have its intended effect since
+C             XERPRN is asked to wrap around at 72 characters in
+C             addition to looking for '$$'.
+C
+C    NERR     An integer value that is chosen by the library routine's
+C             author.  It must be in the range -99 to 999 (three
+C             printable digits).  Each distinct error should have its
+C             own error number.  These error numbers should be described
+C             in the machine readable documentation for the routine.
+C             The error numbers need be unique only within each routine,
+C             so it is reasonable for each routine to start enumerating
+C             errors from 1 and proceeding to the next integer.
+C
+C    LEVEL    An integer value in the range 0 to 2 that indicates the
+C             level (severity) of the error.  Their meanings are
+C
+C            -1  A warning message.  This is used if it is not clear
+C                that there really is an error, but the user's attention
+C                may be needed.  An attempt is made to only print this
+C                message once.
+C
+C             0  A warning message.  This is used if it is not clear
+C                that there really is an error, but the user's attention
+C                may be needed.
+C
+C             1  A recoverable error.  This is used even if the error is
+C                so serious that the routine cannot return any useful
+C                answer.  If the user has told the error package to
+C                return after recoverable errors, then XERMSG will
+C                return to the Library routine which can then return to
+C                the user's routine.  The user may also permit the error
+C                package to terminate the program upon encountering a
+C                recoverable error.
+C
+C             2  A fatal error.  XERMSG will not return to its caller
+C                after it receives a fatal error.  This level should
+C                hardly ever be used; it is much better to allow the
+C                user a chance to recover.  An example of one of the few
+C                cases in which it is permissible to declare a level 2
+C                error is a reverse communication Library routine that
+C                is likely to be called repeatedly until it integrates
+C                across some interval.  If there is a serious error in
+C                the input such that another step cannot be taken and
+C                the Library routine is called again without the input
+C                error having been corrected by the caller, the Library
+C                routine will probably be called forever with improper
+C                input.  In this case, it is reasonable to declare the
+C                error to be fatal.
+C
+C    Each of the arguments to XERMSG is input; none will be modified by
+C    XERMSG.  A routine may make multiple calls to XERMSG with warning
+C    level messages; however, after a call to XERMSG with a recoverable
+C    error, the routine should return to the user.  Do not try to call
+C    XERMSG with a second recoverable error after the first recoverable
+C    error because the error package saves the error number.  The user
+C    can retrieve this error number by calling another entry point in
+C    the error handling package and then clear the error number when
+C    recovering from the error.  Calling XERMSG in succession causes the
+C    old error number to be overwritten by the latest error number.
+C    This is considered harmless for error numbers associated with
+C    warning messages but must not be done for error numbers of serious
+C    errors.  After a call to XERMSG with a recoverable error, the user
+C    must be given a chance to call NUMXER or XERCLR to retrieve or
+C    clear the error number.
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
+C***REVISION HISTORY  (YYMMDD)
+C   880101  DATE WRITTEN
+C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
+C           THERE ARE TWO BASIC CHANGES.
+C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
+C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
+C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
+C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
+C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
+C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
+C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
+C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
+C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
+C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
+C               OF LOWER CASE.
+C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
+C           THE PRINCIPAL CHANGES ARE
+C           1.  CLARIFY COMMENTS IN THE PROLOGUES
+C           2.  RENAME XRPRNT TO XERPRN
+C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
+C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
+C               CHARACTER FOR NEW RECORDS.
+C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+C           CLEAN UP THE CODING.
+C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
+C           PREFIX.
+C   891013  REVISED TO CORRECT COMMENTS.
+C   891214  Prologue converted to Version 4.0 format.  (WRB)
+C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
+C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
+C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
+C           XERCTL to XERCNT.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERMSG
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+      CHARACTER*8 XLIBR, XSUBR
+      CHARACTER*72  TEMP
+      CHARACTER*20  LFIRST
+C***FIRST EXECUTABLE STATEMENT  XERMSG
+      LKNTRL = J4SAVE (2, 0, .FALSE.)
+      MAXMES = J4SAVE (4, 0, .FALSE.)
+C
+C       LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
+C       MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
+C          SHOULD BE PRINTED.
+C
+C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
+C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
+C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
+C
+      IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
+     *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
+         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
+     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
+     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
+         CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
+         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
+         RETURN
+      ENDIF
+C
+C       RECORD THE MESSAGE.
+C
+      I = J4SAVE (1, NERR, .TRUE.)
+      CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
+C
+C       HANDLE PRINT-ONCE WARNING MESSAGES.
+C
+      IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN
+C
+C       ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
+C
+      XLIBR  = LIBRAR
+      XSUBR  = SUBROU
+      LFIRST = MESSG
+      LERR   = NERR
+      LLEVEL = LEVEL
+      CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
+C
+      LKNTRL = MAX(-2, MIN(2,LKNTRL))
+      MKNTRL = ABS(LKNTRL)
+C
+C       SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
+C       ZERO AND THE ERROR IS NOT FATAL.
+C
+      IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30
+      IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30
+      IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30
+      IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30
+C
+C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
+C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
+C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
+C       IS NOT ZERO.
+C
+      IF (LKNTRL .NE. 0) THEN
+         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
+         I = MIN(LEN(SUBROU), 16)
+         TEMP(22:21+I) = SUBROU(1:I)
+         TEMP(22+I:33+I) = ' IN LIBRARY '
+         LTEMP = 33 + I
+         I = MIN(LEN(LIBRAR), 16)
+         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
+         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
+         LTEMP = LTEMP + I + 1
+         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+      ENDIF
+C
+C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
+C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
+C       FROM EACH OF THE FOLLOWING THREE OPTIONS.
+C       1.  LEVEL OF THE MESSAGE
+C              'INFORMATIVE MESSAGE'
+C              'POTENTIALLY RECOVERABLE ERROR'
+C              'FATAL ERROR'
+C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
+C              'PROG CONTINUES'
+C              'PROG ABORTED'
+C       3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
+C           MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
+C           WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
+C              'TRACEBACK REQUESTED'
+C              'TRACEBACK NOT REQUESTED'
+C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
+C       EXCEED 74 CHARACTERS.
+C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
+C
+      IF (LKNTRL .GT. 0) THEN
+C
+C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
+C
+         IF (LEVEL .LE. 0) THEN
+            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
+            LTEMP = 20
+         ELSEIF (LEVEL .EQ. 1) THEN
+            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
+            LTEMP = 30
+         ELSE
+            TEMP(1:12) = 'FATAL ERROR,'
+            LTEMP = 12
+         ENDIF
+C
+C       THEN WHETHER THE PROGRAM WILL CONTINUE.
+C
+         IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
+     *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
+            TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
+            LTEMP = LTEMP + 14
+         ELSE
+            TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
+            LTEMP = LTEMP + 16
+         ENDIF
+C
+C       FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
+C
+         IF (LKNTRL .GT. 0) THEN
+            TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
+            LTEMP = LTEMP + 20
+         ELSE
+            TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
+            LTEMP = LTEMP + 24
+         ENDIF
+         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+      ENDIF
+C
+C       NOW SEND OUT THE MESSAGE.
+C
+      CALL XERPRN (' *  ', -1, MESSG, 72)
+C
+C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
+C          TRACEBACK.
+C
+      IF (LKNTRL .GT. 0) THEN
+         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
+         DO 10 I=16,22
+            IF (TEMP(I:I) .NE. ' ') GO TO 20
+   10    CONTINUE
+C
+   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
+         CALL FDUMP
+      ENDIF
+C
+C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
+C
+      IF (LKNTRL .NE. 0) THEN
+         CALL XERPRN (' *  ', -1, ' ', 72)
+         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
+         CALL XERPRN ('    ',  0, ' ', 72)
+      ENDIF
+C
+C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
+C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
+C
+   30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
+C
+C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
+C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
+C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
+C
+      IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN
+         IF (LEVEL .EQ. 1) THEN
+            CALL XERPRN
+     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
+         ELSE
+            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
+         ENDIF
+         CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
+         CALL XERHLT (' ')
+      ELSE
+         CALL XERHLT (MESSG)
+      ENDIF
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xerprn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xerprn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xerprn.F	(revision 222)
@@ -0,0 +1,228 @@
+*DECK XERPRN
+      SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
+C***BEGIN PROLOGUE  XERPRN
+C***SUBSIDIARY
+C***PURPOSE  Print error messages processed by XERMSG.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERPRN-A)
+C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
+C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
+C***DESCRIPTION
+C
+C This routine sends one or more lines to each of the (up to five)
+C logical units to which error messages are to be sent.  This routine
+C is called several times by XERMSG, sometimes with a single line to
+C print and sometimes with a (potentially very long) message that may
+C wrap around into multiple lines.
+C
+C PREFIX  Input argument of type CHARACTER.  This argument contains
+C         characters to be put at the beginning of each line before
+C         the body of the message.  No more than 16 characters of
+C         PREFIX will be used.
+C
+C NPREF   Input argument of type INTEGER.  This argument is the number
+C         of characters to use from PREFIX.  If it is negative, the
+C         intrinsic function LEN is used to determine its length.  If
+C         it is zero, PREFIX is not used.  If it exceeds 16 or if
+C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
+C         used.  If NPREF is positive and the length of PREFIX is less
+C         than NPREF, a copy of PREFIX extended with blanks to length
+C         NPREF will be used.
+C
+C MESSG   Input argument of type CHARACTER.  This is the text of a
+C         message to be printed.  If it is a long message, it will be
+C         broken into pieces for printing on multiple lines.  Each line
+C         will start with the appropriate prefix and be followed by a
+C         piece of the message.  NWRAP is the number of characters per
+C         piece; that is, after each NWRAP characters, we break and
+C         start a new line.  In addition the characters '$$' embedded
+C         in MESSG are a sentinel for a new line.  The counting of
+C         characters up to NWRAP starts over for each new line.  The
+C         value of NWRAP typically used by XERMSG is 72 since many
+C         older error messages in the SLATEC Library are laid out to
+C         rely on wrap-around every 72 characters.
+C
+C NWRAP   Input argument of type INTEGER.  This gives the maximum size
+C         piece into which to break MESSG for printing on multiple
+C         lines.  An embedded '$$' ends a line, and the count restarts
+C         at the following character.  If a line break does not occur
+C         on a blank (it would split a word) that word is moved to the
+C         next line.  Values of NWRAP less than 16 will be treated as
+C         16.  Values of NWRAP greater than 132 will be treated as 132.
+C         The actual line length will be NPREF + NWRAP after NPREF has
+C         been adjusted to fall between 0 and 16 and NWRAP has been
+C         adjusted to fall between 16 and 132.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  I1MACH, XGETUA
+C***REVISION HISTORY  (YYMMDD)
+C   880621  DATE WRITTEN
+C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
+C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
+C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
+C           SLASH CHARACTER IN FORMAT STATEMENTS.
+C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
+C           LINES TO BE PRINTED.
+C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
+C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
+C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
+C   891214  Prologue converted to Version 4.0 format.  (WRB)
+C   900510  Added code to break messages between words.  (RWC)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERPRN
+      CHARACTER*(*) PREFIX, MESSG
+      INTEGER NPREF, NWRAP
+      CHARACTER*148 CBUFF
+      INTEGER IU(5), NUNIT
+      CHARACTER*2 NEWLIN
+      PARAMETER (NEWLIN = '$$')
+C***FIRST EXECUTABLE STATEMENT  XERPRN
+      CALL XGETUA(IU,NUNIT)
+C
+C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
+C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
+C       ERROR MESSAGE UNIT.
+C
+      N = I1MACH(4)
+      DO 10 I=1,NUNIT
+         IF (IU(I) .EQ. 0) IU(I) = N
+   10 CONTINUE
+C
+C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
+C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
+C       THE REST OF THIS ROUTINE.
+C
+      IF ( NPREF .LT. 0 ) THEN
+         LPREF = LEN(PREFIX)
+      ELSE
+         LPREF = NPREF
+      ENDIF
+      LPREF = MIN(16, LPREF)
+      IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
+C
+C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
+C       TIME FROM MESSG TO PRINT ON ONE LINE.
+C
+      LWRAP = MAX(16, MIN(132, NWRAP))
+C
+C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
+C
+      LENMSG = LEN(MESSG)
+      N = LENMSG
+      DO 20 I=1,N
+         IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
+         LENMSG = LENMSG - 1
+   20 CONTINUE
+   30 CONTINUE
+C
+C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
+C
+      IF (LENMSG .EQ. 0) THEN
+         CBUFF(LPREF+1:LPREF+1) = ' '
+         DO 40 I=1,NUNIT
+            WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
+   40    CONTINUE
+         RETURN
+      ENDIF
+C
+C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
+C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
+C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
+C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
+C
+C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
+C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
+C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
+C       OF THE SECOND ARGUMENT.
+C
+C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
+C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
+C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
+C       POSITION NEXTC.
+C
+C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
+C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
+C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
+C                       WHICHEVER IS LESS.
+C
+C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
+C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
+C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
+C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
+C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
+C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
+C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
+C                       SHOULD BE INCREMENTED BY 2.
+C
+C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
+C
+C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
+C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
+C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
+C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
+C                       AT THE END OF A LINE.
+C
+      NEXTC = 1
+   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
+      IF (LPIECE .EQ. 0) THEN
+C
+C       THERE WAS NO NEW LINE SENTINEL FOUND.
+C
+         IDELTA = 0
+         LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
+         IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
+            DO 52 I=LPIECE+1,2,-1
+               IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
+                  LPIECE = I-1
+                  IDELTA = 1
+                  GOTO 54
+               ENDIF
+   52       CONTINUE
+         ENDIF
+   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC = NEXTC + LPIECE + IDELTA
+      ELSEIF (LPIECE .EQ. 1) THEN
+C
+C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
+C       DON'T PRINT A BLANK LINE.
+C
+         NEXTC = NEXTC + 2
+         GO TO 50
+      ELSEIF (LPIECE .GT. LWRAP+1) THEN
+C
+C       LPIECE SHOULD BE SET DOWN TO LWRAP.
+C
+         IDELTA = 0
+         LPIECE = LWRAP
+         DO 56 I=LPIECE+1,2,-1
+            IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
+               LPIECE = I-1
+               IDELTA = 1
+               GOTO 58
+            ENDIF
+   56    CONTINUE
+   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC = NEXTC + LPIECE + IDELTA
+      ELSE
+C
+C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
+C       WE SHOULD DECREMENT LPIECE BY ONE.
+C
+         LPIECE = LPIECE - 1
+         CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC  = NEXTC + LPIECE + 2
+      ENDIF
+C
+C       PRINT
+C
+      DO 60 I=1,NUNIT
+         WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
+   60 CONTINUE
+C
+      IF (NEXTC .LE. LENMSG) GO TO 50
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xersve.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xersve.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xersve.F	(revision 222)
@@ -0,0 +1,155 @@
+*DECK XERSVE
+      SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
+     +   ICOUNT)
+C***BEGIN PROLOGUE  XERSVE
+C***SUBSIDIARY
+C***PURPOSE  Record that an error has occurred.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3
+C***TYPE      ALL (XERSVE-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C *Usage:
+C
+C        INTEGER  KFLAG, NERR, LEVEL, ICOUNT
+C        CHARACTER * (len) LIBRAR, SUBROU, MESSG
+C
+C        CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
+C
+C *Arguments:
+C
+C        LIBRAR :IN    is the library that the message is from.
+C        SUBROU :IN    is the subroutine that the message is from.
+C        MESSG  :IN    is the message to be saved.
+C        KFLAG  :IN    indicates the action to be performed.
+C                      when KFLAG > 0, the message in MESSG is saved.
+C                      when KFLAG=0 the tables will be dumped and
+C                      cleared.
+C                      when KFLAG < 0, the tables will be dumped and
+C                      not cleared.
+C        NERR   :IN    is the error number.
+C        LEVEL  :IN    is the error severity.
+C        ICOUNT :OUT   the number of times this message has been seen,
+C                      or zero if the table has overflowed and does not
+C                      contain this message specifically.  When KFLAG=0,
+C                      ICOUNT will not be altered.
+C
+C *Description:
+C
+C   Record that this error occurred and possibly dump and clear the
+C   tables.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  I1MACH, XGETUA
+C***REVISION HISTORY  (YYMMDD)
+C   800319  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900413  Routine modified to remove reference to KFLAG.  (WRB)
+C   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
+C           sequence, use IF-THEN-ELSE, make number of saved entries
+C           easily changeable, changed routine name from XERSAV to
+C           XERSVE.  (RWC)
+C   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XERSVE
+      PARAMETER (LENTAB=10)
+      INTEGER LUN(5)
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+      CHARACTER*8  LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
+      CHARACTER*20 MESTAB(LENTAB), MES
+      DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
+      SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
+      DATA KOUNTX/0/, NMSG/0/
+C***FIRST EXECUTABLE STATEMENT  XERSVE
+C
+      IF (KFLAG.LE.0) THEN
+C
+C        Dump the table.
+C
+         IF (NMSG.EQ.0) RETURN
+C
+C        Print to each unit.
+C
+         CALL XGETUA (LUN, NUNIT)
+         DO 20 KUNIT = 1,NUNIT
+            IUNIT = LUN(KUNIT)
+            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
+C
+C           Print the table header.
+C
+            WRITE (IUNIT,9000)
+C
+C           Print body of table.
+C
+            DO 10 I = 1,NMSG
+               WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
+     *            NERTAB(I),LEVTAB(I),KOUNT(I)
+   10       CONTINUE
+C
+C           Print number of other errors.
+C
+            IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX
+            WRITE (IUNIT,9030)
+   20    CONTINUE
+C
+C        Clear the error tables.
+C
+         IF (KFLAG.EQ.0) THEN
+            NMSG = 0
+            KOUNTX = 0
+         ENDIF
+      ELSE
+C
+C        PROCESS A MESSAGE...
+C        SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
+C        OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
+C
+         LIB = LIBRAR
+         SUB = SUBROU
+         MES = MESSG
+         DO 30 I = 1,NMSG
+            IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND.
+     *         MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND.
+     *         LEVEL.EQ.LEVTAB(I)) THEN
+                  KOUNT(I) = KOUNT(I) + 1
+                  ICOUNT = KOUNT(I)
+                  RETURN
+            ENDIF
+   30    CONTINUE
+C
+         IF (NMSG.LT.LENTAB) THEN
+C
+C           Empty slot found for new message.
+C
+            NMSG = NMSG + 1
+            LIBTAB(I) = LIB
+            SUBTAB(I) = SUB
+            MESTAB(I) = MES
+            NERTAB(I) = NERR
+            LEVTAB(I) = LEVEL
+            KOUNT (I) = 1
+            ICOUNT    = 1
+         ELSE
+C
+C           Table is full.
+C
+            KOUNTX = KOUNTX+1
+            ICOUNT = 0
+         ENDIF
+      ENDIF
+      RETURN
+C
+C     Formats.
+C
+ 9000 FORMAT ('0          ERROR MESSAGE SUMMARY' /
+     +   ' LIBRARY    SUBROUTINE MESSAGE START             NERR',
+     +   '     LEVEL     COUNT')
+ 9010 FORMAT (1X,A,3X,A,3X,A,3I10)
+ 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
+ 9030 FORMAT (1X)
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xgetua.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xgetua.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/bibio/xgetua.F	(revision 222)
@@ -0,0 +1,51 @@
+*DECK XGETUA
+      SUBROUTINE XGETUA (IUNITA, N)
+C***BEGIN PROLOGUE  XGETUA
+C***PURPOSE  Return unit number(s) to which error messages are being
+C            sent.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XGETUA-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        XGETUA may be called to determine the unit number or numbers
+C        to which error messages are being sent.
+C        These unit numbers may have been set by a call to XSETUN,
+C        or a call to XSETUA, or may be a default value.
+C
+C     Description of Parameters
+C      --Output--
+C        IUNIT - an array of one to five unit numbers, depending
+C                on the value of N.  A value of zero refers to the
+C                default unit, as defined by the I1MACH machine
+C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
+C                defined by XGETUA.  The values of IUNIT(N+1),...,
+C                IUNIT(5) are not defined (for N .LT. 5) or altered
+C                in any way by XGETUA.
+C        N     - the number of units to which copies of the
+C                error messages are being sent.  N will be in the
+C                range from 1 to 5.
+C
+C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
+C                 Error-handling Package, SAND82-0800, Sandia
+C                 Laboratories, 1982.
+C***ROUTINES CALLED  J4SAVE
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  XGETUA
+      DIMENSION IUNITA(5)
+C***FIRST EXECUTABLE STATEMENT  XGETUA
+      N = J4SAVE(5,0,.FALSE.)
+      DO 30 I=1,N
+         INDEX = I+4
+         IF (I.EQ.1) INDEX = 3
+         IUNITA(I) = J4SAVE(INDEX,0,.FALSE.)
+   30 CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/abort_gcm.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/abort_gcm.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/abort_gcm.F	(revision 222)
@@ -0,0 +1,47 @@
+!
+! $Id: abort_gcm.F 1425 2010-09-02 13:45:23Z 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
+#include "iniprint.h"
+ 
+C
+C Stops the simulation cleanly, closing files and printing various
+C comments
+C
+C  Input: modname = name of calling program
+C         message = stuff to print
+C         ierr    = severity of situation ( = 0 normal )
+
+      character(len=*) modname
+      integer ierr
+      character(len=*) message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+      call histclo
+      call restclo
+#endif
+      call getin_dump
+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'
+        stop
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+        stop 1
+      endif
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/addfi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/addfi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/addfi.F	(revision 222)
@@ -0,0 +1,192 @@
+!
+! $Id: addfi.F 1446 2010-10-22 09:27:25Z emillour $
+!
+      SUBROUTINE addfi(pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+
+      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  (unit/s)
+c      pdtsfi(ip1jmp1)        |
+c
+c      Output :
+c      --------
+c      pucov
+c      pvcov
+c      ph
+c      pts
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      REAL,INTENT(IN) :: pdt ! time step for the integration (s)
+c
+      REAL,INTENT(INOUT) :: pvcov(ip1jm,llm) ! covariant meridional wind
+      REAL,INTENT(INOUT) :: pucov(ip1jmp1,llm) ! covariant zonal wind
+      REAL,INTENT(INOUT) :: pteta(ip1jmp1,llm) ! potential temperature
+      REAL,INTENT(INOUT) :: pq(ip1jmp1,llm,nqtot) ! tracers
+      REAL,INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
+c respective tendencies (.../s) to add
+      REAL,INTENT(IN) :: pdvfi(ip1jm,llm)
+      REAL,INTENT(IN) :: pdufi(ip1jmp1,llm)
+      REAL,INTENT(IN) :: pdqfi(ip1jmp1,llm,nqtot)
+      REAL,INTENT(IN) :: pdhfi(ip1jmp1,llm)
+      REAL,INTENT(IN) :: pdpfi(ip1jmp1)
+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
+c
+c-----------------------------------------------------------------------
+
+      DO k = 1,llm
+         DO j = 1,ip1jmp1
+            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO  k    = 1, llm
+       DO  ij   = 1, iim
+         xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+         xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+       ENDDO
+       tpn      = SSUM(iim,xpn,1)/ apoln
+       tps      = SSUM(iim,xps,1)/ apols
+
+       DO ij   = 1, iip1
+         pteta(   ij   ,k)  = tpn
+         pteta(ij+ip1jm,k)  = tps
+       ENDDO
+      ENDDO
+!***********************
+! Correction on teta due to surface pressure changes
+      DO k = 1,llm
+        DO j = 1,ip1jmp1
+           pteta(j,k)= pteta(j,k)*(1+pdpfi(j)*pdt/pps(j))**kappa
+        ENDDO
+      ENDDO
+!***********************
+
+      DO k = 1,llm
+         DO j = iip2,ip1jm
+            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO k = 1,llm
+         DO j = 1,ip1jm
+            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+c
+      DO j = 1,ip1jmp1
+         pps(j) = pps(j) + pdpfi(j) * pdt
+      ENDDO
+ 
+      if (planet_type=="earth") then
+      ! earth case, special treatment for first 2 tracers (water)
+       DO iq = 1, 2
+         DO k = 1,llm
+            DO j = 1,ip1jmp1
+               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
+       ENDDO
+
+       DO iq = 3, nqtot
+         DO k = 1,llm
+            DO j = 1,ip1jmp1
+               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
+       ENDDO
+      else
+      ! general case, treat all tracers equally)
+       DO iq = 1, nqtot
+         DO k = 1,llm
+            DO j = 1,ip1jmp1
+               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
+       ENDDO
+      endif ! of if (planet_type=="earth")
+
+      DO  ij   = 1, iim
+        xpn(ij) = aire(   ij   ) * pps(  ij     )
+        xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+      ENDDO
+      tpn      = SSUM(iim,xpn,1)/apoln
+      tps      = SSUM(iim,xps,1)/apols
+
+      DO ij   = 1, iip1
+        pps (   ij     )  = tpn
+        pps ( ij+ip1jm )  = tps
+      ENDDO
+
+
+      DO iq = 1, nqtot
+        DO  k    = 1, llm
+          DO  ij   = 1, iim
+            xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+            xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+          ENDDO
+          tpn      = SSUM(iim,xpn,1)/apoln
+          tps      = SSUM(iim,xps,1)/apols
+
+          DO ij   = 1, iip1
+            pq (   ij   ,k,iq)  = tpn
+            pq (ij+ip1jm,k,iq)  = tps
+          ENDDO
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/advect.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/advect.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/advect.F	(revision 222)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l
+
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+      DO  l=1,llm
+         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         = 1, iip1
+            uav(ij      ,l) = 0.
+            uav(ip1jm+ij,l) = 0.
+         ENDDO
+      ENDDO
+
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+
+      DO  l=1,llm
+         DO    ij   = 2, ip1jm
+          vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         DO    ij   = 1,ip1jm,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         DO    ij   = 1, ip1jm-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         DO    ij       = 1, ip1jm, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+c
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+
+      DO 5   ij   = 1, ip1jmp1
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+
+      DO 6 ij = iip2 ,ip1jm-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .....  correction pour  du(iip1,j,l)  ........
+c     .....     du(iip1,j,l)= du(1,j,l)   .....
+
+CDIR$ IVDEP
+      DO   7  ij   = iip1 +iip1, ip1jm, iip1
+      du( ij, l  ) = du( ij -iim, l  )
+      du( ij,l+1 ) = du( ij -iim,l+1 )
+   7  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+
+      DO 8 ij = 1, ip1jm
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+
+        DO 15 ij = 1, ip1jmp1
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta(ij, l ) = dteta(ij, l )  -  ww
+         dteta(ij,l+1) = dteta(ij,l+1)  +  ww
+  15    CONTINUE
+
+      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
+
+  20  CONTINUE
+ 
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/advtrac.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/advtrac.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/advtrac.F90	(revision 222)
@@ -0,0 +1,398 @@
+! $Id: advtrac.F90 1549 2011-07-05 08:41:12Z lguez $
+
+SUBROUTINE advtrac(pbaru,pbarv , p,  masse,q,iapptrac,teta, flxw, pk)
+  !     Auteur :  F. Hourdin
+  !
+  !     Modif. P. Le Van     (20/12/97)
+  !            F. Codron     (10/99)
+  !            D. Le Croller (07/2001)
+  !            M.A Filiberti (04/2002)
+  !
+  USE infotrac, ONLY: nqtot, iadv
+  USE control_mod, ONLY: iapp_tracvl, day_step
+
+
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comconst.h"
+  include "comvert.h"
+  include "comdissip.h"
+  include "comgeom2.h"
+  include "logic.h"
+  include "temps.h"
+  include "ener.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !-------------------------------------------------------------------
+  !     Arguments
+  !-------------------------------------------------------------------
+  INTEGER,INTENT(OUT) :: iapptrac
+  REAL,INTENT(IN) :: pbaru(ip1jmp1,llm)
+  REAL,INTENT(IN) :: pbarv(ip1jm,llm)
+  REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot)
+  REAL,INTENT(IN) :: masse(ip1jmp1,llm)
+  REAL,INTENT(IN) :: p( ip1jmp1,llmp1 )
+  REAL,INTENT(IN) :: teta(ip1jmp1,llm)
+  REAL,INTENT(IN) :: pk(ip1jmp1,llm)
+  REAL,INTENT(OUT) :: flxw(ip1jmp1,llm)
+  !-------------------------------------------------------------------
+  !     Ajout PPM
+  !--------------------------------------------------------
+  REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm)
+  !-------------------------------------------------------------
+  !     Variables locales
+  !-------------------------------------------------------------
+
+  REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+  REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+  REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) 
+  REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu
+  INTEGER iadvtr
+  INTEGER ij,l,iq,iiq
+  REAL zdpmin, zdpmax
+  EXTERNAL  minmax
+  SAVE iadvtr, massem, pbaruc, pbarvc
+  DATA iadvtr/0/
+  !----------------------------------------------------------
+  !     Rajouts pour PPM
+  !----------------------------------------------------------
+  INTEGER indice,n
+  REAL dtbon ! Pas de temps adaptatif pour que CFL<1
+  REAL CFLmaxz,aaa,bbb ! CFL maximum
+  REAL psppm(iim,jjp1) ! pression  au sol
+  REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm)
+  REAL qppm(iim*jjp1,llm,nqtot)
+  REAL fluxwppm(iim,jjp1,llm)
+  REAL apppm(llmp1), bpppm(llmp1)
+  LOGICAL dum,fill
+  DATA fill/.true./
+  DATA dum/.true./
+
+  integer,save :: countcfl=0
+  real cflx(ip1jmp1,llm)
+  real cfly(ip1jm,llm)
+  real cflz(ip1jmp1,llm)
+  real, save :: cflxmax(llm),cflymax(llm),cflzmax(llm)
+
+  IF(iadvtr.EQ.0) THEN
+     CALL initial0(ijp1llm,pbaruc)
+     CALL initial0(ijmllm,pbarvc)
+  ENDIF
+
+  !   accumulation des flux de masse horizontaux
+  DO l=1,llm
+     DO ij = 1,ip1jmp1
+        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+     ENDDO
+     DO ij = 1,ip1jm
+        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(iadvtr.EQ.0) THEN
+
+     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+     !cc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+     !
+  ENDIF
+
+  iadvtr   = iadvtr+1
+  iapptrac = iadvtr
+
+
+  !   Test pour savoir si on advecte a ce pas de temps
+  IF ( iadvtr.EQ.iapp_tracvl ) THEN
+
+     !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( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+     ! ... Flux de masse diaganostiques traceurs
+     flxw = wg / REAL(iapp_tracvl)
+
+     !  test sur l'eventuelle creation de valeurs negatives de la masse
+     DO l=1,llm-1
+        DO ij = iip2+1,ip1jm
+           zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l) &
+                - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
+                +       wg(ij,l+1)  - wg(ij,l)
+        ENDDO
+        CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+        DO ij = iip2,ip1jm
+           zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+        ENDDO
+
+
+        CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+
+        IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+           PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin, &
+                '   MAX:', zdpmax
+        ENDIF
+
+     ENDDO
+
+
+     !-------------------------------------------------------------------
+     ! Calcul des criteres CFL en X, Y et Z
+     !-------------------------------------------------------------------
+
+     if (countcfl == 0. ) then
+        cflxmax(:)=0.
+        cflymax(:)=0.
+        cflzmax(:)=0.
+     endif
+
+     countcfl=countcfl+iapp_tracvl
+     cflx(:,:)=0.
+     cfly(:,:)=0.
+     cflz(:,:)=0.
+     do l=1,llm
+        do ij=iip2,ip1jm-1
+           if (pbarug(ij,l)>=0.) then
+              cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l)
+           else
+              cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l)
+           endif
+        enddo
+     enddo
+     do l=1,llm
+        do ij=iip2,ip1jm-1,iip1
+           cflx(ij+iip1,l)=cflx(ij,l)
+        enddo
+     enddo
+
+     do l=1,llm
+        do ij=1,ip1jm
+           if (pbarvg(ij,l)>=0.) then
+              cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l)
+           else
+              cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l)
+           endif
+        enddo
+     enddo
+
+     do l=2,llm
+        do ij=1,ip1jm
+           if (wg(ij,l)>=0.) then
+              cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l)
+           else
+              cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1)
+           endif
+        enddo
+     enddo
+
+     do l=1,llm
+        cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l)))
+        cflymax(l)=max(cflymax(l),maxval(cfly(:,l)))
+        cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l)))
+     enddo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+     ! Par defaut, on sort le diagnostic des CFL tous les jours.
+     ! Si on veut le sortir a chaque pas d'advection en cas de plantage 
+     !     if (countcfl==iapp_tracvl) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+     if (countcfl==day_step) then
+        do l=1,llm
+           write(lunout,*) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), &
+                cflzmax(l)
+        enddo
+        countcfl=0
+     endif
+
+     !-------------------------------------------------------------------
+     !   Advection proprement dite (Modification Le Croller (07/2001)
+     !-------------------------------------------------------------------
+
+     !----------------------------------------------------
+     !        Calcul des moyennes basées sur la masse
+     !----------------------------------------------------
+     call massbar(massem,massebx,masseby)          
+
+     !-----------------------------------------------------------
+     !     Appel des sous programmes d'advection
+     !-----------------------------------------------------------
+     do iq=1,nqtot
+        !        call clock(t_initial)
+        if(iadv(iq) == 0) cycle 
+        !   ----------------------------------------------------------------
+        !   Schema de Van Leer I MUSCL
+        !   ----------------------------------------------------------------
+        if(iadv(iq).eq.10) THEN
+           call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
+
+           !   ----------------------------------------------------------------
+           !   Schema "pseudo amont" + test sur humidite specifique
+           !    pour la vapeur d'eau. F. Codron
+           !   ----------------------------------------------------------------
+        else if(iadv(iq).eq.14) then
+           !
+           CALL vlspltqs( q(1,1,1), 2., massem, wg , &
+                pbarug,pbarvg,dtvr,p,pk,teta )
+           !   ----------------------------------------------------------------
+           !   Schema de Frederic Hourdin
+           !   ----------------------------------------------------------------
+        else if(iadv(iq).eq.12) then
+           !            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           do indice=1,n
+              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+           end do
+        else if(iadv(iq).eq.13) then
+           !            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           do indice=1,n
+              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+           end do
+           !   ----------------------------------------------------------------
+           !   Schema de pente SLOPES
+           !   ----------------------------------------------------------------
+        else if (iadv(iq).eq.20) then
+           call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+           !   ----------------------------------------------------------------
+           !   Schema de Prather
+           !   ----------------------------------------------------------------
+        else if (iadv(iq).eq.30) then
+           !            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg, &
+                n,dtbon)
+
+           !   ----------------------------------------------------------------
+           !   Schemas PPM Lin et Rood
+           !   ----------------------------------------------------------------
+        else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. &
+             iadv(iq).LE.18)) then
+
+           !        Test sur le flux horizontal
+           !        Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           !        Test sur le flux vertical
+           CFLmaxz=0.
+           do l=2,llm
+              do ij=iip2,ip1jm
+                 aaa=wg(ij,l)*dtvr/massem(ij,l)
+                 CFLmaxz=max(CFLmaxz,aaa)
+                 bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+                 CFLmaxz=max(CFLmaxz,bbb)
+              enddo
+           enddo
+           if (CFLmaxz.GE.1) then
+              write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+           endif
+
+           !-----------------------------------------------------------
+           !        Ss-prg interface LMDZ.4->PPM3d
+           !-----------------------------------------------------------
+
+           call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
+                apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
+                unatppm,vnatppm,psppm)
+
+           do indice=1,n
+              !----------------------------------------------------------------
+              !                         VL (version PPM) horiz. et PPM vert.
+              !----------------------------------------------------------------
+              if (iadv(iq).eq.11) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+
+                 !-------------------------------------------------------------
+                 !                           Monotonic PPM
+                 !-------------------------------------------------------------
+              else if (iadv(iq).eq.16) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+                 !-------------------------------------------------------------
+
+                 !-------------------------------------------------------------
+                 !                           Semi Monotonic PPM
+                 !-------------------------------------------------------------
+              else if (iadv(iq).eq.17) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+                 !-------------------------------------------------------------
+
+                 !-------------------------------------------------------------
+                 !                         Positive Definite PPM
+                 !-------------------------------------------------------------
+              else if (iadv(iq).eq.18) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+                 !-------------------------------------------------------------
+              endif
+           enddo
+           !-----------------------------------------------------------------
+           !               Ss-prg interface PPM3d-LMDZ.4
+           !-----------------------------------------------------------------
+           call interpost(q(1,1,iq),qppm(1,1,iq))
+        endif
+        !----------------------------------------------------------------------
+
+        !-----------------------------------------------------------------
+        ! On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
+        ! et Nord j=1
+        !-----------------------------------------------------------------
+
+        !                  call traceurpole(q(1,1,iq),massem)
+
+        ! calcul du temps cpu pour un schema donne
+
+        !                  call clock(t_final)
+        !ym                  tps_cpu=t_final-t_initial
+        !ym                  cpuadv(iq)=cpuadv(iq)+tps_cpu
+
+     end DO
+
+
+     !------------------------------------------------------------------
+     !   on reinitialise a zero les flux de masse cumules
+     !---------------------------------------------------
+     iadvtr=0
+
+  ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+END SUBROUTINE advtrac
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/bilan_dyn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/bilan_dyn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/bilan_dyn.F	(revision 222)
@@ -0,0 +1,945 @@
+!
+! $Id: bilan_dyn.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE bilan_dyn (dt_app,dt_cum,
+     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,
+     s  ducovdyn,ducovdis,ducovspg,ducovphy)
+c si besoin des traceurs:
+c      SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum,
+c     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac,
+c     s  ducovdyn,ducovdis,ducovspg,ducovphy)
+
+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 control_mod, ONLY: planet_type 
+      USE cpdet_mod, only: tpot2t
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.h"
+#include "iniprint.h"
+
+c====================================================================
+c
+c   Sous-programme consacre à des diagnostics dynamiques de base
+c
+c 
+c   De facon generale, les moyennes des scalaires Q sont ponderees par
+c   la masse.
+c
+c   Les flux de masse sont eux simplement moyennes.
+c
+c====================================================================
+
+c   Arguments :
+c   ===========
+
+c      integer ntrac
+      real dt_app,dt_cum
+      real ps(iip1,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+      real flux_u(iip1,jjp1,llm)
+      real flux_v(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+      real phi(iip1,jjp1,llm)
+      real ucov(iip1,jjp1,llm)
+      real vcov(iip1,jjm,llm)
+c      real trac(iip1,jjp1,llm,ntrac)
+c Tendances en m/s2 :
+      real ducovdyn(iip1,jjp1,llm)
+      real ducovdis(iip1,jjp1,llm)
+      real ducovspg(iip1,jjp1,llm)
+      real ducovphy(iip1,jjp1,llm)
+
+c   Local :
+c   =======
+
+      integer icum,ncum
+      save icum,ncum
+
+      integer i,j,l,iQ,num
+      real zz,zqy,zfactv(jjm,llm),zfactw(jjm,llm)
+      character*2 strd2
+      real ww
+
+      logical first
+      save first
+      data first/.true./
+
+      integer i_sortie
+      save i_sortie
+      data i_sortie/1/
+
+      real time
+      integer itau
+      save time,itau
+      data time,itau/0.,0/
+
+! facteur = -1. pour Venus
+      real    fact_geovenus
+      save    fact_geovenus
+
+c   variables dynamiques intermédiaires
+c -----------------------------------
+      REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+      REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL vorpot(iip1,jjm,llm)
+      REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
+      real temp(iip1,jjp1,llm)
+      real dudyn(iip1,jjp1,llm)
+      real dudis(iip1,jjp1,llm)
+      real duspg(iip1,jjp1,llm)
+      real duphy(iip1,jjp1,llm)
+
+c CHAMPS SCALAIRES Q ADVECTES
+c ----------------------------
+      integer nQ
+c avec tous les composes, ca fait trop.... Je les enleve
+c     parameter (nQ=6+nqmx)
+      parameter (nQ=6)
+
+      character*6,save :: nom(nQ)
+      character*6,save :: unites(nQ)
+
+      integer itemp,igeop,iecin,iang,iu,iun
+      save itemp,igeop,iecin,iang,iu,iun
+      data itemp,igeop,iecin,iang,iu,iun/1,2,3,4,5,6/
+
+c   champ contenant les scalaires advectés.
+      real Q(iip1,jjp1,llm,nQ)
+    
+c   champs cumulés
+      real ps_cum(iip1,jjp1)
+      real masse_cum(iip1,jjp1,llm)
+      real flux_u_cum(iip1,jjp1,llm)
+      real flux_v_cum(iip1,jjm,llm)
+      real flux_w_cum(iip1,jjp1,llm)
+      real Q_cum(iip1,jjp1,llm,nQ)
+      real flux_uQ_cum(iip1,jjp1,llm,nQ)
+      real flux_vQ_cum(iip1,jjm,llm,nQ)
+      real flux_wQ_cum(iip1,jjp1,llm,nQ)
+      real dQ(iip1,jjp1,llm,nQ)
+
+      save ps_cum,masse_cum,flux_u_cum,flux_v_cum
+      save Q_cum,flux_uQ_cum,flux_vQ_cum
+      save flux_w_cum,flux_wQ_cum
+
+c   champs de transport en moyenne zonale
+      integer ntr,itr
+      parameter (ntr=5)
+
+      character*10,save :: znom(ntr,nQ)
+      character*20,save :: znoml(ntr,nQ)
+      character*10,save :: zunites(ntr,nQ)
+      character*10,save :: znom2(ntr,nQ)
+      character*20,save :: znom2l(ntr,nQ)
+      character*10,save :: zunites2(ntr,nQ)
+      character*10,save :: znom3(nQ)
+      character*20,save :: znom3l(nQ)
+      character*10,save :: zunites3(nQ)
+
+      integer iave,itot,immc,itrs,istn
+      data iave,itot,immc,itrs,istn/1,2,3,4,5/
+      character*3 ctrs(ntr)
+      data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+      real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+      real zwQ(jjm,llm,ntr,nQ),zwQtmp(jjm,llm)
+      real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+      real zawQ(jjm,llm,ntr,nQ)
+      real zdQ(jjm,llm,nQ)
+      real zmasse(jjm,llm),zavmasse(jjm),zawmasse(llm)
+      real psbar(jjm)
+
+      real zv(jjm,llm),zw(jjp1,llm),psi(jjm,llm+1)
+
+c TENDANCES POUR MOMENT CINETIQUE
+c -------------------------------
+
+      integer ntdc,itdc
+      parameter (ntdc=4)
+
+      integer itdcdyn,itdcdis,itdcspg,itdcphy
+      data    itdcdyn,itdcdis,itdcspg,itdcphy/1,2,3,4/
+
+      character*6,save :: nomtdc(ntdc)
+
+c   champ contenant les tendances du moment cinetique.
+      real    tdc(iip1,jjp1,llm,ntdc)
+      real    ztdc(jjm,llm,ntdc)   ! moyenne zonale
+    
+c   champs cumulés
+      real tdc_cum(iip1,jjp1,llm,ntdc)
+      save tdc_cum
+
+c   integrations completes
+      real mtot,mctot,dmctot(ntdc)
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      character*10 infile
+
+      integer fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      integer ndex3d(jjm*llm)
+      real    ztmp3d(jjm,llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      integer zan, dayref
+C
+      real rlong(jjm),rlatg(jjm)
+
+
+
+c=====================================================================
+c   Initialisation
+c=====================================================================
+
+      ndex3d=0
+
+      if (first) then
+
+        if (planet_type.eq."venus") then 
+            fact_geovenus = -1.
+        else
+            fact_geovenus = 1.
+        endif
+
+        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-2*dt_app) then
+         if (abs((ncum+1)*dt_app-dt_cum).lt.1.e-2*dt_app) then
+           ncum = ncum+1
+         elseif (abs((ncum-1)*dt_app-dt_cum).lt.1.e-2*dt_app) then
+           ncum = ncum-1
+         else
+           WRITE(lunout,*)
+     .            'Pb : le pas de cumule doit etre multiple du pas'
+           WRITE(lunout,*)'dt_app=',dt_app
+           WRITE(lunout,*)'dt_cum=',dt_cum
+           WRITE(lunout,*)'ncum*dt_app=',ncum*dt_app
+           WRITE(lunout,*)'ncum=',ncum
+           stop
+         endif
+        endif
+
+c VARIABLES ADVECTEES:
+
+        nom(itemp)='temp'
+        nom(igeop)='gz'
+        nom(iecin)='ecin'
+        nom(iang)='ang'
+        nom(iu)='u'
+        nom(iun)='un'
+
+        unites(itemp)='K'
+        unites(igeop)='m2/s2'
+        unites(iecin)='m2/s2'
+        unites(iang)='ang'
+        unites(iu)='m/s'
+        unites(iun)='un'
+
+c avec tous les composes, ca fait trop.... Je les enleve
+c       do num=1,ntrac
+c        write(strd2,'(i2.2)') num
+c        nom(6+num)='trac'//strd2
+c        unites(6+num)='kg/kg'
+c       enddo
+
+c TENDANCES MOMENT CIN:
+        
+        nomtdc(itdcdyn) ='dmcdyn' 
+        nomtdc(itdcdis) ='dmcdis' 
+        nomtdc(itdcspg) ='dmcspg' 
+        nomtdc(itdcphy) ='dmcphy' 
+
+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)
+c     tau0 = itau_dyn
+      tau0 = 0
+      itau = tau0
+      
+      rlong=0.
+      rlatg=rlatv*180./pi*fact_geovenus
+       
+      call histbeg(infile, 1, rlong, jjm, rlatg,
+     .             1, 1, 1, jjm,
+     .             tau0, zjulian, dt_cum, thoriid, fileid)
+
+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)
+           znom2(itr,iQ)   =ctrs(itr)//'w'//nom(iQ)
+           znom2l(itr,iQ)  ='transport: w * '//nom(iQ)//' '//ctrs(itr)
+           zunites2(itr,iQ)='Pa/s * '//unites(iQ)
+            endif
+         enddo
+               znom3(iQ)='d'//nom(iQ)
+               znom3l(iQ)='convergence: '//nom(iQ)
+               zunites3(iQ)=unites(iQ)//' /s'
+c          print*,'DEBUG:',znom3(iQ),znom3l(iQ),zunites3(iQ)
+      enddo
+
+c   Declarations des champs avec dimension verticale
+
+      if (1.eq.0) then  ! on les sort, ou pas...
+
+c     do iQ=1,nQ
+c !!!! JE NE SORS ICI QUE temp et ang POUR CAUSE DE PLACE !
+      do iQ=1,4,3
+         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,jjm,thoriid,llm,1,llm,zvertiid,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+c transport vertical:
+         do itr=2,ntr
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'var ',itr,iQ
+     .      ,znom2(itr,iQ),znom2l(itr,iQ),zunites2(itr,iQ)
+            call histdef(fileid,znom2(itr,iQ),znom2l(itr,iQ),
+     .        zunites2(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+     .        32,'ins(X)',dt_cum,dt_cum)
+         enddo
+
+c Declarations pour convergences
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'var ',iQ
+     .      ,znom3(iQ),znom3l(iQ),zunites3(iQ)
+            call histdef(fileid,znom3(iQ),znom3l(iQ),
+     .        zunites3(iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+     .        32,'ins(X)',dt_cum,dt_cum)
+
+c   Declarations pour les fonctions de courant
+c   Non sorties ici...
+c          call histdef(fileid,'psi'//nom(iQ)
+c     .      ,'stream fn. '//znoml(itot,iQ),
+c     .      zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+c     .      32,'ave(X)',dt_cum,dt_cum)
+
+      enddo ! iQ
+
+      endif ! 1=1 sortie ou non...
+
+c   Declarations pour les champs de transport d'air
+      call histdef(fileid, 'masse', 'masse',
+     .             'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'v', 'v',
+     .             'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'w', 'w',
+     .             'Pa/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ins(X)', dt_cum, dt_cum)
+
+c   Declarations pour la fonction de courant
+          call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
+     .      1,jjm,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+
+
+c   Declarations pour les tendances de moment cinetique
+      do itdc=1,ntdc
+      call histdef(fileid, nomtdc(itdc), nomtdc(itdc),
+     .             'ang/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ins(X)', dt_cum, dt_cum)
+      enddo
+
+c   Declaration des champs 1D de transport en latitude
+c     do iQ=1,nQ
+c !!!! JE NE SORS ICI QUE temp et ang POUR CAUSE DE PLACE !
+      do iQ=1,4,3
+         do itr=2,ntr
+            call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99,
+     .        32,'ave(X)',dt_cum,dt_cum)
+c JE VIRE LE VERTICAL POUR L'INSTANT
+c           call histdef(fileid,'a'//znom2(itr,iQ),znom2l(itr,iQ),
+c    .        zunites2(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+c    .        32,'ins(X)',dt_cum,dt_cum)
+         enddo
+      enddo
+
+               CALL histend(fileid)
+
+
+      endif  ! first
+
+
+c=====================================================================
+c   Calcul des champs dynamiques
+c   ----------------------------
+
+c   énergie cinétique
+      ucont(:,:,:)=0
+      CALL covcont(llm,ucov,vcov,ucont,vcont)
+      CALL enercin(vcov,ucov,vcont,ucont,ecin)
+
+c   moment cinétique et tendances
+      dudyn = 0.
+      dudis = 0.
+      duspg = 0.
+      duphy = 0.
+      do l=1,llm
+         unat(:,:,l)=ucont(:,:,l)*cu(:,:)
+         dudyn(:,2:jjm,l) = ducovdyn(:,2:jjm,l)/cu(:,2:jjm)
+         dudis(:,2:jjm,l) = ducovdis(:,2:jjm,l)/cu(:,2:jjm)
+         duspg(:,2:jjm,l) = ducovspg(:,2:jjm,l)/cu(:,2:jjm)
+         duphy(:,2:jjm,l) = ducovphy(:,2:jjm,l)/cu(:,2:jjm)
+         do j=1,jjp1
+          ang(:,j,l)= rad*cos(rlatu(j))*
+     .     ( unat(:,j,l) + rad*cos(rlatu(j))*omeg )
+          tdc(:,j,l,1) = rad*cos(rlatu(j))*dudyn(:,j,l)
+          tdc(:,j,l,2) = rad*cos(rlatu(j))*dudis(:,j,l)
+          tdc(:,j,l,3) = rad*cos(rlatu(j))*duspg(:,j,l)
+          tdc(:,j,l,4) = rad*cos(rlatu(j))*duphy(:,j,l)
+         enddo
+      enddo
+c Normalisation: 
+      ang = ang / (2./3. *rad*rad*omeg)
+      do itdc=1,ntdc
+        tdc(:,:,:,itdc)=tdc(:,:,:,itdc) / (2./3. *rad*rad*omeg)
+      enddo
+
+! ADAPTATION GCM POUR CP(T)
+      call tpot2t(ip1jmp1*llm,teta,temp,pk)
+      Q(:,:,:,itemp) = temp(:,:,:)
+      Q(:,:,:,igeop) =phi(:,:,:)
+      Q(:,:,:,iecin) =ecin(:,:,:)
+      Q(:,:,:,iang)  =ang(:,:,:)
+      Q(:,:,:,iu)    =unat(:,:,:)
+      Q(:,:,:,iun)   =1.
+c avec tous les composes, ca fait trop.... Je les enleve
+c     do num=1,ntrac
+c      Q(:,:,:,6+num)=trac(:,:,:,num)
+c     enddo
+
+c   calcul du flux de masse vertical (+ vers le bas)
+      call convmas(flux_u,flux_v,convm)
+      CALL vitvert(convm,w)
+
+c=====================================================================
+c   Cumul
+c=====================================================================
+c
+      if(icum.EQ.0) then
+         ps_cum      = 0.
+         masse_cum   = 0.
+         flux_u_cum  = 0.
+         flux_v_cum  = 0.
+         flux_w_cum  = 0.
+         Q_cum       = 0.
+         flux_vQ_cum = 0.
+         flux_uQ_cum = 0.
+         flux_wQ_cum = 0.
+         tdc_cum     = 0.
+      endif
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+      icum=icum+1
+
+c   accumulation des flux de masse horizontaux
+      ps_cum          = ps_cum     + ps
+      masse_cum       = masse_cum  + masse
+      flux_u_cum      = flux_u_cum + flux_u
+      flux_v_cum      = flux_v_cum + flux_v
+      flux_w_cum      = flux_w_cum + w
+      do iQ=1,nQ
+      Q_cum(:,:,:,iQ) = Q_cum(:,:,:,iQ) + Q(:,:,:,iQ)*masse(:,:,:)
+      enddo
+      do itdc=1,ntdc
+      tdc_cum(:,:,:,itdc) =
+     .       tdc_cum(:,:,:,itdc) + tdc(:,:,:,itdc)*masse(:,:,:)
+      enddo
+
+c=====================================================================
+c  FLUX ET TENDANCES
+c=====================================================================
+
+c   Flux longitudinal
+c   -----------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=1,jjp1
+               do i=1,iim
+                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
+     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+               enddo
+               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+            enddo
+         enddo
+      enddo
+
+c    flux méridien
+c    -------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=1,jjm
+               do i=1,iip1
+                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
+     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+               enddo
+            enddo
+         enddo
+      enddo
+
+c   Flux vertical
+c   -------------
+      do iQ=1,nQ
+         do l=2,llm
+            do j=1,jjp1
+               do i=1,iip1
+                  flux_wQ_cum(i,j,l,iQ)=flux_wQ_cum(i,j,l,iQ)
+     s            +w(i,j,l)*0.5*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
+               enddo
+            enddo
+         enddo
+         flux_wQ_cum(:,:,1,iQ)=0.0e0
+      enddo
+
+c    tendances
+c    ---------
+
+c   convergence horizontale
+      call  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+c   calcul de la vitesse verticale
+      call convmas(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert(convm,w)
+
+c  ajustement tendances (vitesse verticale)
+      do iQ=1,nQ
+         do l=1,llm-1
+            do j=1,jjp1
+               do i=1,iip1
+                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+               enddo
+            enddo
+         enddo
+      enddo
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+
+c=====================================================================
+c   PAS DE TEMPS D'ECRITURE
+c=====================================================================
+      if (icum.eq.ncum) then
+c=====================================================================
+
+      time=time+dt_cum
+      itau=itau+1
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Pas d ecriture'
+
+c   Normalisation
+      do iQ=1,nQ
+         Q_cum(:,:,:,iQ) = Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
+         dQ(:,:,:,iQ)    = dQ(:,:,:,iQ)   /masse_cum(:,:,:)
+      enddo
+      do itdc=1,ntdc
+         tdc_cum(:,:,:,itdc) = tdc_cum(:,:,:,itdc)/masse_cum(:,:,:)
+      enddo
+
+      zz=1./REAL(ncum)
+      ps_cum      = ps_cum      *zz
+      masse_cum   = masse_cum   *zz
+      flux_u_cum  = flux_u_cum  *zz
+      flux_v_cum  = flux_v_cum  *zz
+      flux_w_cum  = flux_w_cum  *zz
+      flux_uQ_cum = flux_uQ_cum *zz
+      flux_vQ_cum = flux_vQ_cum *zz
+      flux_wQ_cum = flux_wQ_cum *zz
+
+c Integration complete
+      mtot  = 0.
+      mctot  = 0.
+      dmctot = 0.
+      do l=1,llm
+       do j=2,jjm
+        do i=1,iim
+          mtot  = mtot  + masse_cum(i,j,l)
+          mctot = mctot + Q_cum(i,j,l,iang)*masse_cum(i,j,l)
+        enddo
+       enddo
+      enddo
+      mctot = mctot/mtot
+      do itdc=1,ntdc
+      do l=1,llm
+       do j=2,jjm
+        do i=1,iim
+          dmctot(itdc) = dmctot(itdc) 
+     .               + tdc_cum(i,j,l,itdc)*masse_cum(i,j,l)/mtot
+        enddo
+       enddo
+      enddo
+      enddo
+
+c=====================================================================
+c   Transport méridien
+c=====================================================================
+
+c   cumul zonal des masses des mailles
+c   ----------------------------------
+      zv=0.
+      zw=0.
+      zmasse=0.
+      call massbar(masse_cum,massebx,masseby)
+
+c moy zonale de la ps cumulee
+         do j=1,jjm
+            psbar(j)=0.
+            do i=1,iim
+               psbar(j)=psbar(j)+ps_cum(i,j)/iim
+            enddo
+         enddo
+
+      do l=1,llm
+         do j=1,jjm
+            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)
+               zw(j,l)=zw(j,l)+flux_w_cum(i,j,l)
+            enddo
+            zfactv(j,l)=cv(1,j)/zmasse(j,l)
+            zfactw(j,l)=((ap(l)-ap(l+1))+psbar(j)*(bp(l)-bp(l+1)))
+     .                    /zmasse(j,l) 
+         enddo
+            do i=1,iim
+               zw(jjp1,l)=zw(jjp1,l)+flux_w_cum(i,jjp1,l)
+            enddo
+      enddo
+
+c     print*,'3OK'
+c   --------------------------------------------------------------
+c   calcul de la moyenne zonale du transport :
+c   ------------------------------------------
+c
+c                                     --
+c TOT : la circulation totale       [ vq ]
+c
+c                                      -     -
+c MMC : mean meridional circulation [ v ] [ q ]
+c
+c                                     ----      --       - -
+c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+c
+c                                     - * - *       - -       -     -
+c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+c
+c                                              - -
+c    on utilise aussi l'intermediaire TMP :  [ v q ]
+c
+c    la variable zfactv transforme un transport meridien cumule
+c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+c    la variable zfactw transforme un transport vertical cumule
+c    en kg/s * unte-du-champ-transporte en Pa/s * unite-du-champ-transporte
+c
+c   --------------------------------------------------------------
+
+
+c   ----------------------------------------
+c   Transport dans le plan latitude-altitude
+c   ----------------------------------------
+
+      zvQ=0.
+      zwQ=0.
+      zdQ=0.
+      psiQ=0.
+
+      do iQ=1,nQ
+
+c   transport meridien
+         zvQtmp=0.
+         do l=1,llm
+            do j=1,jjm
+c              print*,'j,l,iQ=',j,l,iQ
+c   Calcul des moyennes zonales du transport total et de zvQtmp
+               do i=1,iim
+                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
+     s                            +flux_vQ_cum(i,j,l,iQ)
+                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
+     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
+     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+               enddo
+c              print*,'aOK'
+c   Decomposition
+               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+            enddo
+         enddo
+c   fonction de courant meridienne pour la quantite Q
+         do l=llm,1,-1
+            do j=1,jjm
+             psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)/zfactv(j,l)
+            enddo
+         enddo
+!!      enddo
+
+c   transport vertical
+         zwQtmp=0.
+         do l=1,llm
+            do j=1,jjm
+c              print*,'j,l,iQ=',j,l,iQ
+c   Calcul des moyennes zonales du transport vertical total et de zwQtmp
+               do i=1,iim
+                  zwQ(j,l,itot,iQ)=zwQ(j,l,itot,iQ)
+     s                            +flux_wQ_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))
+                  zwQtmp(j,l)=zwQtmp(j,l)+flux_w_cum(i,j,l)*zqy
+     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+                  zwQ(j,l,iave,iQ)=zwQ(j,l,iave,iQ)+zqy
+               enddo
+c   Decomposition
+               zwQ(j,l,iave,iQ)=zwQ(j,l,iave,iQ)/zmasse(j,l)
+               zwQ(j,l,itot,iQ)=zwQ(j,l,itot,iQ)*zfactw(j,l)
+               zwQtmp(j,l)=zwQtmp(j,l)*zfactw(j,l)
+               zwQ(j,l,immc,iQ)=zw(j,l)*zwQ(j,l,iave,iQ)*zfactw(j,l)
+               zwQ(j,l,itrs,iQ)=zwQ(j,l,itot,iQ)-zwQtmp(j,l)
+               zwQ(j,l,istn,iQ)=zwQtmp(j,l)-zwQ(j,l,immc,iQ)
+            enddo
+         enddo
+
+c   convergence
+c   Calcul moyenne zonale de la convergence totale
+         do l=1,llm
+            do j=1,jjm
+c              print*,'j,l,iQ=',j,l,iQ
+               do i=1,iim
+                  zdQ(j,l,iQ)=zdQ(j,l,iQ) +
+     .                   ( dQ(i,j,l,iQ)   * masse_cum(i,j,l)
+     .                   + dQ(i,j+1,l,iQ) * masse_cum(i,j+1,l))
+     .                 / ( masse_cum(i,j,l)+masse_cum(i,j+1,l))
+               enddo
+            enddo
+         enddo
+      enddo ! of do iQ=1,nQ
+
+c   fonction de courant pour la circulation meridienne moyenne
+      psi=0.
+      do l=llm,1,-1
+         do j=1,jjm
+            psi(j,l)= psi(j,l+1)+zv(j,l)
+            zv(j,l) = zv(j,l)*zfactv(j,l)
+            zw(j,l) = 0.5*(zw(j,l)+zw(j+1,l))*zfactw(j,l)
+         enddo
+      enddo
+
+c   Calcul moyenne zonale des tendances moment cin.
+      ztdc=0.
+      do itdc=1,ntdc
+         do l=1,llm
+            do j=1,jjm
+               do i=1,iim
+                  ztdc(j,l,itdc)=ztdc(j,l,itdc) +
+     .            ( tdc_cum(i,j,l,itdc)   * masse_cum(i,j,l)
+     .            + tdc_cum(i,j+1,l,itdc) * masse_cum(i,j+1,l))
+     .          / ( masse_cum(i,j,l)+masse_cum(i,j+1,l))
+               enddo
+            enddo
+         enddo
+      enddo
+
+c     print*,'4OK'
+
+c--------------------------------------
+c--------------------------------------
+c   sorties proprement dites
+c--------------------------------------
+c--------------------------------------
+
+      if (i_sortie.eq.1) then
+
+c sortie des integrations completes dans le listing
+      write(*,'(A12,5(1PE11.4,X))') "BILANMCDYN  ",mctot,dmctot
+
+c sorties dans fichier dynzon
+
+      if (1.eq.0) then  ! on les sort, ou pas...
+
+c avec tous les composes, ca fait trop.... Je les enleve
+c      do iQ=1,nQ
+c      do iQ=1,6
+c !!!! JE NE SORS ICI QUE temp et ang POUR CAUSE DE PLACE !
+      do iQ=1,4,3
+
+         ztmp3d(:,:)= zvQ(:,:,1,iQ) ! valeur moyenne
+            call histwrite(fileid,znom(1,iQ),itau,ztmp3d
+     s      ,jjm*llm,ndex3d)
+       do itr=2,ntr
+         ztmp3d(:,:)= zvQ(:,:,itr,iQ)*fact_geovenus ! transport horizontal
+            call histwrite(fileid,znom(itr,iQ),itau,ztmp3d
+     s      ,jjm*llm,ndex3d)
+       enddo
+
+       do itr=2,ntr
+         ztmp3d(:,:)=zwQ(:,:,itr,iQ)
+            call histwrite(fileid,znom2(itr,iQ),itau,ztmp3d
+     s      ,jjm*llm,ndex3d)
+       enddo
+       
+         ztmp3d(:,:)= zdQ(:,:,iQ)
+            call histwrite(fileid,znom3(iQ),itau,ztmp3d
+     s      ,jjm*llm,ndex3d)
+
+c        ztmp3d(:,:)= psiQ(:,1:llm,iQ)*fact_geovenus
+c        call histwrite(fileid,'psi'//nom(iQ),itau,ztmp3d
+c    s      ,jjm*llm,ndex3d)
+      enddo
+
+      endif ! 1=1 sortie ou non...
+
+      ztmp3d=zmasse
+      call histwrite(fileid,'masse',itau,ztmp3d
+     s   ,jjm*llm,ndex3d)
+      
+      ztmp3d= zv*fact_geovenus
+      call histwrite(fileid,'v',itau,ztmp3d
+     s   ,jjm*llm,ndex3d)
+      ztmp3d(:,:)=zw(1:jjm,:)
+      call histwrite(fileid,'w',itau,ztmp3d
+     s   ,jjm*llm,ndex3d)
+      ztmp3d= psi(:,1:llm)*1.e-9*fact_geovenus
+      call histwrite(fileid,'psi',itau,ztmp3d,jjm*llm,ndex3d)
+
+      do itdc=1,ntdc
+         ztmp3d(:,:)= ztdc(:,:,itdc)
+         call histwrite(fileid,nomtdc(itdc),itau,ztmp3d
+     s    ,jjm*llm,ndex3d)
+      enddo
+
+      endif ! i_sortie
+
+
+c   -----------------
+c   Moyenne verticale
+c   -----------------
+
+      zavmasse=0.
+      do l=1,llm
+         zavmasse(:)=zavmasse(:)+zmasse(:,l)
+      enddo
+      zavQ=0.
+
+c avec tous les composes, ca fait trop.... Je les enleve
+c      do iQ=1,nQ
+c      do iQ=1,6
+c !!!! JE NE SORS ICI QUE temp et ang POUR CAUSE DE PLACE !
+      do iQ=1,4,3
+         do itr=2,ntr
+            do l=1,llm
+               zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l)
+            enddo
+            zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zavmasse(:)
+      if (i_sortie.eq.1) then
+         ztmp3d=0.0
+         ztmp3d(:,1)= zavQ(:,itr,iQ)*fact_geovenus
+         call histwrite(fileid,'a'//znom(itr,iQ),itau,ztmp3d
+     .      ,jjm*llm,ndex3d)     
+      endif
+         enddo
+      enddo
+
+c   ------------------
+c   Moyenne meridienne
+c   ------------------
+
+      zawmasse=0.
+      do j=1,jjm
+           do l=1,llm
+         zawmasse(l)=zawmasse(l)+zmasse(j,l)
+           enddo
+      enddo
+      zawQ=0.
+
+c avec tous les composes, ca fait trop.... Je les enleve
+c      do iQ=1,nQ
+c      do iQ=1,6
+c !!!! JE NE SORS ICI QUE temp et ang POUR CAUSE DE PLACE !
+      do iQ=1,4,3
+         do itr=2,ntr
+           do l=1,llm
+            do j=1,jjm
+          zawQ(1,l,itr,iQ)=zawQ(1,l,itr,iQ)+zwQ(j,l,itr,iQ)*zmasse(j,l)
+            enddo
+            zawQ(1,l,itr,iQ)=zawQ(1,l,itr,iQ)/zawmasse(l)
+           enddo
+      if (i_sortie.eq.1) then
+         ztmp3d=0.0
+           do l=1,llm
+         ztmp3d(1,l)=zawQ(1,l,itr,iQ)
+           enddo
+c JE VIRE LE VERTICAL POUR L'INSTANT
+c        call histwrite(fileid,'a'//znom2(itr,iQ),itau,ztmp3d
+c    .      ,jjm*llm,ndex3d)     
+      endif
+         enddo
+      enddo
+
+      call histsync(fileid)
+
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/caladvtrac.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/caladvtrac.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/caladvtrac.F	(revision 222)
@@ -0,0 +1,113 @@
+!
+! $Id: caladvtrac.F 1446 2010-10-22 09:27:25Z emillour $
+!
+c
+c
+            SUBROUTINE caladvtrac(q,pbaru,pbarv ,
+     *                   p ,masse, dq ,  teta,
+     *                   flxw, pk)
+c
+      USE infotrac, ONLY : nqtot
+      USE control_mod, ONLY : iapp_tracvl,planet_type
+ 
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron  
+c
+c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+c=======================================================================
+c
+c       Shema de  Van Leer
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+c   Arguments:
+c   ----------
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqtot)
+      real :: dq(ip1jmp1,llm,nqtot)
+      REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm)
+      REAL               :: flxw(ip1jmp1,llm)
+
+c  ..................................................................
+c
+c  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
+c
+c  ..................................................................
+c
+c   Local:
+c   ------
+
+      EXTERNAL  advtrac,minmaxq, qminimum
+      INTEGER ij,l, iq, iapptrac
+      REAL finmasse(ip1jmp1,llm), dtvrtrac
+
+cc
+c
+! Earth-specific stuff for the first 2 tracers (water)
+      if (planet_type.eq."earth") then
+C initialisation
+        dq(:,:,1:2)=q(:,:,1:2)
+       
+c  test des valeurs minmax
+cc        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
+cc        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
+      endif ! of if (planet_type.eq."earth")
+c   advection
+
+        CALL advtrac( pbaru,pbarv, 
+     *       p,  masse,q,iapptrac, teta,
+     .       flxw, pk)
+
+c
+
+      IF( iapptrac.EQ.iapp_tracvl ) THEN
+        if (planet_type.eq."earth") then
+! Earth-specific treatment for the first 2 tracers (water)
+c
+cc          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
+cc          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
+
+cc     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
+c
+          DO l = 1, llm
+           DO ij = 1, ip1jmp1
+             finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+           ENDDO
+          ENDDO
+          
+          CALL qminimum( q, 2, finmasse )
+
+          CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
+          CALL filtreg ( finmasse ,  jjp1,  llm, -2, 2, .TRUE., 1 )
+c
+c   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
+c   ********************************************************************
+c
+          dtvrtrac = iapp_tracvl * dtvr
+c
+           DO iq = 1 , 2
+            DO l = 1 , llm
+             DO ij = 1,ip1jmp1
+             dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l)
+     *                               /  dtvrtrac
+             ENDDO
+            ENDDO
+           ENDDO
+c
+        endif ! of if (planet_type.eq."earth")
+      ELSE
+        if (planet_type.eq."earth") then
+! Earth-specific treatment for the first 2 tracers (water)
+          dq(:,:,1:2)=0.
+        endif ! of if (planet_type.eq."earth")
+      ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )
+
+      END
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/caldyn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/caldyn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/caldyn.F	(revision 222)
@@ -0,0 +1,145 @@
+!
+! $Id: $
+!
+      SUBROUTINE caldyn
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,tsurpk,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+!   Arguments:
+!   ----------
+
+      LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics
+      INTEGER,INTENT(IN) :: itau ! time step index
+      REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
+      REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
+      REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
+      REAL,INTENT(IN) :: ps(ip1jmp1) ! surface pressure
+      REAL,INTENT(IN) :: phis(ip1jmp1) ! geopotential at the surface
+      REAL,INTENT(IN) :: pk(ip1jmp1,llm) ! Exner at mid-layer
+      REAL,INTENT(IN) :: pkf(ip1jmp1,llm) ! filtered Exner
+      REAL,INTENT(IN) :: tsurpk(ip1jmp1,llm) ! cpp * temperature / pk
+      REAL,INTENT(IN) :: phi(ip1jmp1,llm) ! geopotential
+      REAL,INTENT(OUT) :: masse(ip1jmp1,llm) ! air mass
+      REAL,INTENT(OUT) :: dv(ip1jm,llm) ! tendency on vcov
+      REAL,INTENT(OUT) :: du(ip1jmp1,llm) ! tendency on ucov
+      REAL,INTENT(OUT) :: dteta(ip1jmp1,llm) ! tenddency on teta
+      REAL,INTENT(OUT) :: dp(ip1jmp1) ! tendency on ps
+      REAL,INTENT(OUT) :: w(ip1jmp1,llm) ! vertical velocity
+      REAL,INTENT(OUT) :: pbaru(ip1jmp1,llm) ! mass flux in the zonal direction
+      REAL,INTENT(OUT) :: pbarv(ip1jm,llm) ! mass flux in the meridional direction
+      REAL,INTENT(IN) :: time ! current time
+
+!   Local:
+!   ------
+
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
+      REAL vorpot(ip1jm,llm)
+      REAL ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+      REAL massebxy(ip1jm,llm)
+      REAL temp(ip1jmp1,llm)
+
+      INTEGER   ij,l
+
+!-----------------------------------------------------------------------
+!   Compute dynamical tendencies:
+!--------------------------------
+
+      ! compute contravariant winds ucont() and vcont
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      ! compute pressure p()
+      CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+      ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
+      CALL psextbar (   ps   , psexbarxy                            )
+      ! compute mass in each atmospheric mesh: masse()
+      CALL massdair (    p   , masse                                )
+      ! compute X and Y-averages of mass, massebx() and masseby()
+      CALL massbar  (   masse, massebx , masseby                    )
+      ! compute XY-average of mass, massebxy()
+      call massbarxy(   masse, massebxy                             )
+      ! compute mass fluxes pbaru() and pbarv()
+      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      ! compute dteta() , horizontal converging flux of theta
+      CALL dteta1   (   teta , pbaru   , pbarv, dteta               )
+      ! compute convm(), horizontal converging flux of mass
+      CALL convmas  (   pbaru, pbarv   , convm                      )
+
+      ! compute pressure variation due to mass convergence
+      DO ij =1, ip1jmp1
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+
+      ! compute vertical velocity w()
+      CALL vitvert ( convm  , w                                  )
+      ! compute potential vorticity vorpot()
+      CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
+      ! compute rotation induced du() and dv()
+      CALL dudv1   ( vorpot , pbaru , pbarv     , du     , dv    )
+      ! compute kinetic energy ecin()
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      ! compute Bernouilli function bern()
+      CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
+      ! compute and add du() and dv() contributions from Bernouilli and pressure
+      CALL dudv2   ( tsurpk , pkf   , bern      , du     , dv    )
+
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+      ENDDO
+      ENDDO
+
+      ! compute vertical advection contributions to du(), dv() and dteta()
+      CALL advect( 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 
+
+      DO l = 1, llm
+         DO ij = 1, ip1jm, 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
+
+!-----------------------------------------------------------------------
+!   Output some control variables:
+!---------------------------------
+
+      IF( conser )  THEN
+        CALL sortvarc
+     $ (itau,ucov,tsurpk,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov)
+
+      ENDIF
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/calfis.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/calfis.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/calfis.F	(revision 222)
@@ -0,0 +1,958 @@
+!
+! $Id: calfis.F 1407 2010-07-07 10:31:52Z fairhead $
+!
+C
+C
+      SUBROUTINE calfis(lafin,
+     $                  jD_cur, jH_cur,
+     $                  pucov,
+     $                  pvcov,
+     $                  pteta,
+     $                  pq,
+     $                  pmasse,
+     $                  pps,
+     $                  pp,
+     $                  ppk,
+     $                  pphis,
+     $                  pphi,
+     $                  pducov,
+     $                  pdvcov,
+     $                  pdteta,
+     $                  pdq,
+     $                  flxw,
+     $                  pdufi,
+     $                  pdvfi,
+     $                  pdhfi,
+     $                  pdqfi,
+     $                  pdpsfi)
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+      USE infotrac, ONLY: nqtot, niadv, tname
+      USE control_mod, ONLY: planet_type, nsplit_phys
+      USE write_field
+      USE cpdet_mod, only: t2tpot,tpot2t
+ 
+! used only for zonal averages
+      USE moyzon_mod
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   1. rearrangement des tableaux et transformation
+c      variables dynamiques  >  variables physiques
+c   2. calcul des termes physiques
+c   3. retransformation des tendances physiques en tendances dynamiques
+c
+c   remarques:
+c   ----------
+c
+c    - les vents sont donnes dans la physique par leurs composantes 
+c      naturelles.
+c    - la variable thermodynamique de la physique est une variable
+c      intensive :   T 
+c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+c    - les deux seules variables dependant de la geometrie necessaires
+c      pour la physique sont la latitude pour le rayonnement et 
+c      l'aire de la maille quand on veut integrer une grandeur 
+c      horizontalement.
+c    - les points de la physique sont les points scalaires de la 
+c      la dynamique; numerotation:
+c          1 pour le pole nord
+c          (jjm-1)*iim pour l'interieur du domaine
+c          ngridmx pour le pole sud
+c      ---> ngridmx=2+(jjm-1)*iim
+c
+c     Input :
+c     -------
+c       pucov           covariant zonal velocity
+c       pvcov           covariant meridional velocity 
+c       pteta           potential temperature
+c       pps             surface pressure
+c       pmasse          masse d'air dans chaque maille
+c       pts             surface temperature  (K)
+c       callrad         clef d'appel au rayonnement
+c
+c    Output :
+c    --------
+c        pdufi          tendency for the natural zonal velocity (ms-1)
+c        pdvfi          tendency for the natural meridional velocity 
+c        pdhfi          tendency for the potential temperature (K/s)
+c        pdtsfi         tendency for the surface temperature
+c
+c        pdtrad         radiative tendencies  \  both input
+c        pfluxrad       radiative fluxes      /  and output
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "logic.h"
+
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+
+c    Arguments :
+c    -----------
+      LOGICAL,INTENT(IN) ::  lafin ! .true. for the very last call to physics
+      REAL,INTENT(IN) :: jD_cur, jH_cur
+      REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
+      REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
+      REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
+      REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
+      REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
+      REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
+      REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
+
+      REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
+      REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
+      REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
+! commentaire SL: pdq ne sert que pour le calcul de pcvgq,
+! qui lui meme ne sert a rien dans la routine telle qu'elle est
+! ecrite, et que j'ai donc commente....
+      REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
+      ! NB: pdq is only used to compute pcvgq which is in fact not used...
+
+      REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
+      REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
+      REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
+      REAL,INTENT(IN) :: flxw(iip1,jjp1,llm)  ! Vertical mass flux on dynamics grid
+
+      ! tendencies (in */s) from the physics
+      REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
+      REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
+      REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
+      REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
+      REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
+
+
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq,iiq
+      REAL zpsrf(ngridmx)
+      REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm)
+      REAL zphi(ngridmx,llm),zphis(ngridmx)
+
+      REAL zufi(ngridmx,llm), zvfi(ngridmx,llm)
+      REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
+! ADAPTATION GCM POUR CP(T)
+      REAL zteta(ngridmx,llm)
+      REAL zpk(ngridmx,llm)
+
+! RQ SL 13/10/10:
+! Ces calculs ne servent pas. 
+! Si necessaire, decommenter ces variables et les calculs...
+!      REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
+!      REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
+
+      REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
+      REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
+      REAL zdpsrf(ngridmx)
+
+      REAL zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
+      REAL zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
+      REAL jH_cur_split,zdt_split
+      LOGICAL debut_split,lafin_split
+      INTEGER isplit
+
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+      save unskap
+
+      REAL flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
+      
+      REAL SSUM
+
+      LOGICAL,SAVE :: firstcal=.true., debut=.true.
+!      REAL rdayvrai
+
+      LOGICAL tracerdyn ! for generic/mars physics call ; possibly to get rid of
+
+! For Titan only right now: 
+! to allow for 2D computation of microphys and chemistry
+      LOGICAL,save :: flag_moyzon
+      REAL,allocatable,save :: tmpvar(:,:)
+      REAL,allocatable,save :: tmpvarp1(:,:)
+      REAL,allocatable,save :: tmpvarbar(:)
+      REAL,allocatable,save :: tmpvarbarp1(:)
+      real :: zz1,zz2
+
+c-----------------------------------------------------------------------
+
+c    1. Initialisations :
+c    --------------------
+
+
+      IF ( firstcal )  THEN
+        debut = .TRUE.
+        IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         write(lunout,*) 'STOP dans calfis'
+         write(lunout,*)
+     &   'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         write(lunout,*) '  ngridmx  jjm   iim   '
+         write(lunout,*) ngridmx,jjm,iim
+         STOP
+        ENDIF
+
+        unskap   = 1./ kappa
+
+        flag_moyzon = .false.
+        if(moyzon_ch.or.moyzon_mu) then
+         flag_moyzon = .true.
+         allocate(tmpvar(iip1,llm))
+         allocate(tmpvarp1(iip1,llmp1))
+         allocate(tmpvarbar(llm))
+         allocate(tmpvarbarp1(llmp1))
+        endif
+
+        if (flag_moyzon) call moyzon_init(ngridmx,llm,nqtot)
+
+c----------------------------------------------
+c moyennes globales pour le profil de pression
+       if(planet_type.eq."titan".or.planet_type.eq."venus") then
+        ALLOCATE(plevmoy(llm+1))
+        ALLOCATE(playmoy(llm))
+        ALLOCATE(tmoy(llm))
+        ALLOCATE(tetamoy(llm))
+        ALLOCATE(pkmoy(llm))
+        ALLOCATE(phimoy(0:llm))
+        ALLOCATE(zlevmoy(llm+1))
+        ALLOCATE(zlaymoy(llm))
+        plevmoy=0.
+        do l=1,llmp1
+         do i=1,iip1
+          do j=1,jjp1
+            plevmoy(l)=plevmoy(l)+pp(i,j,l)/(iip1*jjp1)
+          enddo
+         enddo
+        enddo
+        tetamoy=0.
+        pkmoy=0.
+        phimoy=0.
+        do i=1,iip1
+         do j=1,jjp1
+            phimoy(0)=phimoy(0)+pphis(i,j)/(iip1*jjp1)
+         enddo
+        enddo
+        do l=1,llm
+         do i=1,iip1
+          do j=1,jjp1
+            tetamoy(l)=tetamoy(l)+pteta(i,j,l)/(iip1*jjp1)
+            pkmoy(l)=pkmoy(l)+ppk(i,j,l)/(iip1*jjp1)
+            phimoy(l)=phimoy(l)+pphi(i,j,l)/(iip1*jjp1)
+          enddo
+         enddo
+        enddo
+        playmoy(:) = preff * (pkmoy(:)/cpp) ** unskap
+        call tpot2t(llm,tetamoy,tmoy,pkmoy)
+c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE:
+        zlaymoy(:) = g*rad*rad/(g*rad-phimoy(:))-rad
+        zlevmoy(1) = phimoy(0)/g
+        DO l=2,llm
+            zz1=(playmoy(l-1)+plevmoy(l))/(playmoy(l-1)-plevmoy(l))
+            zz2=(plevmoy(l)  +playmoy(l))/(plevmoy(l)  -playmoy(l))
+            zlevmoy(l)=(zz1*zlaymoy(l-1)+zz2*zlaymoy(l))/(zz1+zz2)
+        ENDDO
+        zlevmoy(llmp1)=zlaymoy(llm)+(zlaymoy(llm)-zlevmoy(llm))
+c-------------------
+c + lat index
+        allocate(klat(ngridmx))
+        klat=0
+        klat(1)  = 1
+        ig0  = 2
+        DO j = 2,jjm
+         do i=0,iim-1
+          klat(ig0+i) = j
+         enddo
+         ig0 = ig0+iim
+        ENDDO
+        klat(ngridmx)  = jjp1
+       endif   ! planet_type=titan
+c----------------------------------------------
+      ELSE
+        debut = .FALSE.
+      ENDIF ! of IF (firstcal)
+
+
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+       
+      zpsrf(1) = pps(1,1)
+
+      ig0  = 2
+      DO j = 2,jjm
+         CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
+         ig0 = ig0+iim
+      ENDDO
+
+      zpsrf(ngridmx) = pps(1,jjp1)
+
+c   42. pression intercouches et fonction d'Exner:
+
+c   -----------------------------------------------------------------
+c     .... zplev  definis aux (llm +1) interfaces des couches  ....
+c     .... zplay  definis aux (  llm )    milieux des couches  .... 
+c   -----------------------------------------------------------------
+
+c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+
+! ADAPTATION GCM POUR CP(T)
+      DO l = 1, llm
+        zpk(   1,l ) = ppk(1,1,l)
+        zteta( 1,l ) = pteta(1,1,l)
+        zplev( 1,l ) = pp(1,1,l)
+        ig0 = 2
+          DO j = 2, jjm
+             DO i =1, iim
+              zpk(   ig0,l ) = ppk(i,j,l)
+              zteta( ig0,l ) = pteta(i,j,l)
+              zplev( ig0,l ) = pp(i,j,l)
+              ig0 = ig0 +1
+             ENDDO
+          ENDDO
+        zpk(   ngridmx,l ) = ppk(1,jjp1,l)
+        zteta( ngridmx,l ) = pteta(1,jjp1,l)
+        zplev( ngridmx,l ) = pp(1,jjp1,l)
+      ENDDO
+        zplev( 1,llmp1 ) = pp(1,1,llmp1)
+        ig0 = 2
+          DO j = 2, jjm
+             DO i =1, iim
+              zplev( ig0,llmp1 ) = pp(i,j,llmp1)
+              ig0 = ig0 +1
+             ENDDO
+          ENDDO
+        zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1)
+
+      if (flag_moyzon) then
+        tmpvarp1(:,:) = pp(:,1,:)
+        call moyzon(llmp1,tmpvarp1,tmpvarbarp1)
+        zplevbar(1,:) = tmpvarbarp1
+        tmpvar(:,:) = ppk(:,1,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zpkbar(1,:) = tmpvarbar
+        tmpvar(:,:) = pteta(:,1,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        ztetabar(1,:) = tmpvarbar
+        call tpot2t(llm,ztetabar(1,:),ztfibar(1,:),zpkbar(1,:))
+        ig0 = 2
+         do j = 2, jjm
+          tmpvarp1(:,:) = pp(:,j,:)
+          call moyzon(llmp1,tmpvarp1,tmpvarbarp1)
+          zplevbar(ig0,:) = tmpvarbarp1
+          tmpvar(:,:) = ppk(:,j,:)
+          call moyzon(llm,tmpvar,tmpvarbar)
+          zpkbar(ig0,:) = tmpvarbar
+          tmpvar(:,:) = pteta(:,j,:)
+          call moyzon(llm,tmpvar,tmpvarbar)
+          ztetabar(ig0,:) = tmpvarbar
+          call tpot2t(llm,ztetabar(ig0,:),ztfibar(ig0,:),zpkbar(ig0,:))
+          ig0 = ig0+1
+          do i=2,iim
+            zplevbar(ig0,:) = zplevbar(ig0-1,:)
+            zpkbar(ig0,:)   = zpkbar(ig0-1,:)
+            ztetabar(ig0,:) = ztetabar(ig0-1,:)
+            ztfibar(ig0,:)  = ztfibar(ig0-1,:)
+            ig0 = ig0+1
+          enddo
+         enddo
+        tmpvarp1(:,:) = pp(:,jjp1,:)
+        call moyzon(llmp1,tmpvarp1,tmpvarbarp1)
+        zplevbar(ngridmx,:) = tmpvarbarp1
+        tmpvar(:,:) = ppk(:,jjp1,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zpkbar(ngridmx,:) = tmpvarbar
+        tmpvar(:,:) = pteta(:,jjp1,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        ztetabar(ngridmx,:) = tmpvarbar
+        call tpot2t(llm,ztetabar(ngridmx,:),
+     .                  ztfibar(ngridmx,:),zpkbar(ngridmx,:))
+      endif
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+
+! ADAPTATION GCM POUR CP(T)
+         call tpot2t(ngridmx*llm,zteta,ztfi,zpk)
+
+      DO l=1,llm
+
+         pksurcp     =  ppk(1,1,l) / cpp
+         zplay(1,l)  =  preff * pksurcp ** unskap
+!         pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
+         ig0         = 2
+
+         DO j = 2, jjm
+            DO i = 1, iim
+              pksurcp        = ppk(i,j,l) / cpp
+              zplay(ig0,l)   = preff * pksurcp ** unskap
+!              pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
+              ig0            = ig0 + 1
+            ENDDO
+         ENDDO
+
+         pksurcp       = ppk(1,jjp1,l) / cpp
+         zplay(ig0,l)  = preff * pksurcp ** unskap
+!         pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
+
+      ENDDO
+
+      if (flag_moyzon) then
+        zplaybar(:,:) = preff * (zpkbar(:,:)/cpp)**unskap
+      endif
+
+c   43.bis traceurs (tous intensifs) 
+c   ---------------
+
+      DO iq=1,nqtot
+         DO l=1,llm
+            zqfi(1,l,iq) = pq(1,1,l,iq)
+            ig0          = 2
+            DO j=2,jjm
+               DO i = 1, iim
+                  zqfi(ig0,l,iq)  = pq(i,j,l,iq)
+                  ig0             = ig0 + 1
+               ENDDO
+            ENDDO
+            zqfi(ig0,l,iq) = pq(1,jjp1,l,iq)
+         ENDDO
+      ENDDO  ! boucle sur traceurs
+
+      if (flag_moyzon) then
+       DO iq=1,nqtot
+! RQ: REVOIR A QUOI CA SERT... ET VERIFIER...
+!       iiq=niadv(iq) 
+! en fait, iiq=iq...
+! FIN RQ
+        tmpvar(:,:) = pq(:,1,:,iq)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zqfibar(1,:,iq) = tmpvarbar
+        ig0 = 2
+         do j = 2, jjm
+          tmpvar(:,:) = pq(:,j,:,iq)
+          call moyzon(llm,tmpvar,tmpvarbar)
+          zqfibar(ig0,:,iq) = tmpvarbar
+          ig0 = ig0+1
+          do i=2,iim
+            zqfibar(ig0,:,iq) = zqfibar(ig0-1,:,iq)
+            ig0 = ig0+1
+          enddo
+         enddo
+        tmpvar(:,:) = pq(:,jjp1,:,iq)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zqfibar(ngridmx,:,iq) = tmpvarbar
+       ENDDO ! of DO iq=1,nqtot
+      endif
+
+! DEBUG
+!     do ig0=1,ngridmx
+!       write(*,'(6(e13.5,1x))') zqfibar(ig0,1,10),zqfi(ig0,1,10),
+!    .                         zqfibar(ig0,llm/2,10),zqfi(ig0,llm/2,10), 
+!    .                           zqfibar(ig0,llm,10),zqfi(ig0,llm,10) 
+!     enddo
+!     stop
+
+!-----------------
+! RQ SL 13/10/10:
+! Ces calculs ne servent pas. 
+! Si necessaire, decommenter ces variables et les calculs...
+!
+!   convergence dynamique pour les traceurs "EAU"
+! Earth-specific treatment of first 2 tracers (water)
+!      if (planet_type=="earth") then
+!       DO iq=1,2
+!        DO l=1,llm
+!           pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
+!           ig0          = 2
+!           DO j=2,jjm
+!              DO i = 1, iim
+!                 pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
+!                 ig0             = ig0 + 1
+!              ENDDO
+!           ENDDO
+!           pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
+!        ENDDO
+!       ENDDO
+!      endif ! of if (planet_type=="earth")
+!----------------
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
+      DO l=1,llm
+         DO ig=1,ngridmx
+           zphi(ig,l)=zphi(ig,l)-zphis(ig)
+         ENDDO
+      ENDDO
+
+      if (flag_moyzon) then
+        tmpvar(:,1) = pphis(:,1)
+        call moyzon(1,tmpvar(:,1),tmpvarbar(1))
+        zphisbar(1) = tmpvarbar(1)
+        tmpvar(:,:) = pphi(:,1,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zphibar(1,:) = tmpvarbar
+        ig0 = 2
+         do j = 2, jjm
+          tmpvar(:,1) = pphis(:,j)
+          call moyzon(1,tmpvar(:,1),tmpvarbar(1))
+          zphisbar(ig0) = tmpvarbar(1)
+          tmpvar(:,:) = pphi(:,j,:)
+          call moyzon(llm,tmpvar,tmpvarbar)
+          zphibar(ig0,:) = tmpvarbar
+          ig0 = ig0+1
+          do i=2,iim
+            zphisbar(ig0)  = zphisbar(ig0-1)
+            zphibar(ig0,:) = zphibar(ig0-1,:)
+            ig0 = ig0+1
+          enddo
+         enddo
+        tmpvar(:,1) = pphis(:,jjp1)
+        call moyzon(1,tmpvar(:,1),tmpvarbar(1))
+        zphisbar(ngridmx) = tmpvarbar(1)
+        tmpvar(:,:) = pphi(:,jjp1,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zphibar(ngridmx,:) = tmpvarbar
+      endif
+
+c   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
+c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux 
+c    de masse est calclue dans advtrac.F  
+c      DO l=1,llm
+c        pvervel(1,l)=pw(1,1,l) * g /apoln
+c        ig0=2
+c       DO j=2,jjm
+c           DO i = 1, iim
+c              pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
+c              ig0 = ig0 + 1
+c           ENDDO
+c       ENDDO
+c        pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
+c      ENDDO
+
+c
+c   45. champ u:
+c   ------------
+
+      DO 50 l=1,llm
+
+         DO 25 j=2,jjm
+            ig0 = 1+(j-2)*iim
+            zufi(ig0+1,l)= 0.5 * 
+     $      ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
+!            pcvgu(ig0+1,l)= 0.5 * 
+!     $      ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
+            DO 10 i=2,iim
+               zufi(ig0+i,l)= 0.5 *
+     $         ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
+!               pcvgu(ig0+i,l)= 0.5 *
+!     $         ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
+10         CONTINUE
+25      CONTINUE
+
+50    CONTINUE
+
+
+c   46.champ v:
+c   -----------
+
+      DO l=1,llm
+         DO j=2,jjm
+            ig0=1+(j-2)*iim
+            DO i=1,iim
+               zvfi(ig0+i,l)= 0.5 *
+     $         ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
+c               pcvgv(ig0+i,l)= 0.5 *
+c     $         ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
+            ENDDO
+         ENDDO
+      ENDDO
+
+
+c   47. champs de vents aux pole nord   
+c   ------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      DO l=1,llm
+
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
+         DO i=2,iim
+            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
+         ENDDO
+
+         DO i=1,iim
+            zcos(i)   = COS(rlonv(i))*z1(i)
+            zcosbis(i)= COS(rlonv(i))*z1bis(i)
+            zsin(i)   = SIN(rlonv(i))*z1(i)
+            zsinbis(i)= SIN(rlonv(i))*z1bis(i)
+         ENDDO
+
+         zufi(1,l)  = SSUM(iim,zcos,1)/pi
+!         pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
+         zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+!         pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
+
+      ENDDO
+
+
+c   48. champs de vents aux pole sud:
+c   ---------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      DO l=1,llm
+
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
+         DO i=2,iim
+            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
+         ENDDO
+
+         DO i=1,iim
+            zcos(i)    = COS(rlonv(i))*z1(i)
+            zcosbis(i) = COS(rlonv(i))*z1bis(i)
+            zsin(i)    = SIN(rlonv(i))*z1(i)
+            zsinbis(i) = SIN(rlonv(i))*z1bis(i)
+         ENDDO
+
+         zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
+!         pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
+         zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
+!         pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
+
+      ENDDO
+c
+c On change de grille, dynamique vers physiq, pour le flux de masse verticale
+      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+! Appel de la physique: pose probleme quand on tourne 
+! SANS physique, car physiq.F est dans le repertoire phy[]... 
+! Il faut une cle CPP_PHYS
+
+! Le fait que les arguments de physiq soient differents selon les planetes 
+! ne pose pas de probleme a priori.
+
+!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
+      zdt_split=dtphys/nsplit_phys
+      zdufic(:,:)=0.
+      zdvfic(:,:)=0.
+      zdtfic(:,:)=0.
+      zdqfic(:,:,:)=0.
+
+#ifdef CPP_PHYS
+
+      do isplit=1,nsplit_phys
+
+         jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
+         debut_split=debut.and.isplit==1
+         lafin_split=lafin.and.isplit==nsplit_phys
+
+      if (planet_type.eq."earth") then
+         CALL physiq (ngridmx,
+     .             llm,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_split,
+     .             zdt_split,
+     .             zplev,
+     .             zplay,
+     .             zphi,
+     .             zphis,
+     .             presnivs,
+     .             zufi,
+     .             zvfi,
+     .             ztfi,
+     .             zqfi,
+     .             flxwfi,
+     .             zdufi,
+     .             zdvfi,
+     .             zdtfi,
+     .             zdqfi,
+     .             zdpsrf,
+     .             pducov)
+
+      else if ( planet_type=="generic" ) then
+
+         CALL physiq (ngridmx,     !! ngrid
+     .             llm,            !! nlayer
+     .             nqtot,          !! nq
+     .             tname,          !! tracer names from dynamical core (given in infotrac)
+     .             debut_split,    !! firstcall 
+     .             lafin_split,    !! lastcall
+     .             jD_cur,         !! pday. see leapfrog
+     .             jH_cur_split,   !! ptime "fraction of day"
+     .             zdt_split,      !! ptimestep
+     .             zplev,          !! pplev
+     .             zplay,          !! pplay
+     .             zphi,           !! pphi
+     .             zufi,           !! pu
+     .             zvfi,           !! pv
+     .             ztfi,           !! pt
+     .             zqfi,           !! pq
+     .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
+     .             zdufi,          !! pdu
+     .             zdvfi,          !! pdv
+     .             zdtfi,          !! pdt
+     .             zdqfi,          !! pdq
+     .             zdpsrf,         !! pdpsrf
+     .             tracerdyn)      !! tracerdyn <-- utilite ???
+
+      else if ( planet_type=="mars" ) then
+
+        CALL physiq (ngridmx,    ! ngrid
+     .             llm,          ! nlayer
+     .             nqtot,        ! nq
+     .             debut_split,  ! firstcall
+     .             lafin_split,  ! lastcall
+     .             jD_cur,       ! pday
+     .             jH_cur_split, ! ptime
+     .             zdt_split,    ! ptimestep
+     .             zplev,        ! pplev
+     .             zplay,        ! pplay
+     .             zphi,         ! pphi
+     .             zufi,         ! pu
+     .             zvfi,         ! pv
+     .             ztfi,         ! pt
+     .             zqfi,         ! pq
+     .             flxwfi,       ! pw
+     .             zdufi,        ! pdu
+     .             zdvfi,        ! pdv
+     .             zdtfi,        ! pdt
+     .             zdqfi,        ! pdq
+     .             zdpsrf,       ! pdpsrf
+     .             tracerdyn)    ! tracerdyn (somewhat obsolete)
+
+      else if ((planet_type=="titan").or.(planet_type=="venus")) then
+
+         CALL physiq (ngridmx,
+     .             llm,
+     .             nqtot,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_split,
+     .             zdt_split,
+     .             zplev,
+     .             zplay,
+     .             zpk,
+     .             zphi,
+     .             zphis,
+     .             presnivs,
+     .             zufi,
+     .             zvfi,
+     .             ztfi,
+     .             zqfi,
+     .             flxwfi,
+     .             zdufi,
+     .             zdvfi,
+     .             zdtfi,
+     .             zdqfi,
+     .             zdpsrf)
+
+      else ! unknown "planet_type"
+
+        write(lunout,*) "calfis_p: error, unknown planet_type: ",
+     &                  trim(planet_type)
+        stop
+
+      endif ! planet_type
+
+         zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
+         zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
+         ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
+         zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
+
+         zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
+         zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
+         zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
+         zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
+
+      enddo ! of do isplit=1,nsplit_phys
+
+! ATTENTION...
+      if (flag_moyzon.and.(nsplit_phys.ne.1)) then
+       print*,"WARNING ! flag_moyzon + nsplit_phys"
+       print*,"zqfibar n'est pas implemente au cours des iterations"
+       print*,"Donc a revoir..."
+       stop
+      endif
+
+#endif
+! #endif of #ifdef CPP_PHYS
+
+      zdufi(:,:)=zdufic(:,:)/nsplit_phys
+      zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
+      zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
+      zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
+
+
+500   CONTINUE
+
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+
+      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
+c
+c   62. enthalpie potentielle
+c   ---------------------
+
+! ADAPTATION GCM POUR CP(T)
+      call t2tpot(ngridmx*llm,ztfi,zteta,zpk)
+
+         DO i=1,iip1
+      pdhfi(i,1,:) = (zteta(1,:) - pteta(i,1,:))/dtphys
+      pdhfi(i,jjp1,:) = (zteta(ngridmx,:) - pteta(i,jjp1,:))/dtphys
+         ENDDO
+
+         DO j=2,jjm
+            ig0=1+(j-2)*iim
+            DO i=1,iim
+      pdhfi(i,j,:) = (zteta(ig0+i,:) - pteta(i,j,:))/dtphys
+            ENDDO
+               pdhfi(iip1,j,:) =  pdhfi(1,j,:)
+         ENDDO
+
+
+c   62. humidite specifique
+c   ---------------------
+! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+!      DO iq=1,nqtot
+!         DO l=1,llm
+!            DO i=1,iip1
+!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
+!               pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
+!            ENDDO
+!            DO j=2,jjm
+!               ig0=1+(j-2)*iim
+!               DO i=1,iim
+!                  pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
+!               ENDDO
+!               pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
+!            ENDDO
+!         ENDDO
+!      ENDDO
+
+c   63. traceurs (tous en intensifs)
+c   ------------
+C     initialisation des tendances
+      pdqfi(:,:,:,:)=0.
+C
+       DO iq=1,nqtot
+         iiq=niadv(iq)
+         DO l=1,llm
+            DO i=1,iip1
+               pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
+               pdqfi(i,jjp1,l,iiq) = zdqfi(ngridmx,l,iq)
+            ENDDO
+            DO j=2,jjm
+               ig0=1+(j-2)*iim
+               DO i=1,iim
+                  pdqfi(i,j,l,iiq) = zdqfi(ig0+i,l,iq)
+               ENDDO
+               pdqfi(iip1,j,l,iiq) = pdqfi(1,j,l,iq)
+            ENDDO
+         ENDDO
+       ENDDO
+
+c   65. champ u:
+c   ------------
+
+      DO l=1,llm
+
+         DO i=1,iip1
+            pdufi(i,1,l)    = 0.
+            pdufi(i,jjp1,l) = 0.
+         ENDDO
+
+         DO j=2,jjm
+            ig0=1+(j-2)*iim
+            DO i=1,iim-1
+               pdufi(i,j,l)=
+     $         0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
+            ENDDO
+            pdufi(iim,j,l)=
+     $      0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
+            pdufi(iip1,j,l)=pdufi(1,j,l)
+         ENDDO
+
+      ENDDO
+
+
+c   67. champ v:
+c   ------------
+
+      DO l=1,llm
+
+         DO j=2,jjm-1
+            ig0=1+(j-2)*iim
+            DO i=1,iim
+               pdvfi(i,j,l)=
+     $         0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
+            ENDDO
+            pdvfi(iip1,j,l) = pdvfi(1,j,l)
+         ENDDO
+      ENDDO
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      v = U * cos(long) + V * SIN(long)
+
+      DO l=1,llm
+
+         DO i=1,iim
+            pdvfi(i,1,l)=
+     $      zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
+            pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i))
+     $      +zdvfi(ngridmx,l)*SIN(rlonv(i))
+            pdvfi(i,1,l)=
+     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+            pdvfi(i,jjm,l)=
+     $      0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
+          ENDDO
+
+         pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+         pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+ 
+      firstcal = .FALSE.
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/ce0l.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/ce0l.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/ce0l.F90	(revision 222)
@@ -0,0 +1,110 @@
+!
+! $Id: ce0l.F90 1984 2014-02-18 09:59:29Z emillour $
+!
+!-------------------------------------------------------------------------------
+!
+PROGRAM ce0l
+!-------------------------------------------------------------------------------
+! Purpose: Calls etat0, creates initial states and limit_netcdf
+!
+!     interbar=.T. for barycentric interpolation inter_barxy
+!     extrap  =.T. for data extrapolation, like for the SSTs when file does not
+!                  contain ocean points only.
+!     oldice  =.T. for old-style ice, obtained using grille_m (grid_atob).
+!     masque is created in etat0, passed to limit to ensure consistancy.
+!-------------------------------------------------------------------------------
+  USE control_mod
+#ifdef CPP_EARTH
+! This prog. is designed to work for Earth
+  USE dimphy
+  USE comgeomphy
+  USE infotrac
+  USE indice_sol_mod
+
+#ifdef CPP_IOIPSL
+  USE ioipsl, ONLY: ioconf_calendar
+#endif
+
+#endif
+  IMPLICIT NONE
+#ifndef CPP_EARTH
+#include "iniprint.h"
+  WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
+#else
+!-------------------------------------------------------------------------------
+! Local variables:
+  LOGICAL, PARAMETER :: interbar=.TRUE., extrap=.FALSE., oldice=.FALSE.
+#include "dimensions.h"
+#include "paramet.h"
+!#include "indicesol.h"
+#include "iniprint.h"
+#include "temps.h"
+#include "logic.h"
+  INTEGER, PARAMETER            :: longcles=20
+  REAL,    DIMENSION(longcles)  :: clesphy0
+  REAL,    DIMENSION(iip1,jjp1) :: masque
+  CHARACTER(LEN=15)             :: calnd
+  REAL,    DIMENSION(iip1,jjp1) :: phis ! geopotentiel au sol
+!-------------------------------------------------------------------------------
+  CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+  WRITE(lunout,*)'---> klon=',klon
+  CALL InitComgeomphy
+
+#ifdef CPP_IOIPSL
+  SELECT CASE(calend)
+    CASE('earth_360d');CALL ioconf_calendar('360d');      calnd='a 360 jours/an'
+    CASE('earth_365d');CALL ioconf_calendar('noleap');    calnd='a 365 jours/an'
+    CASE('earth_366d');CALL ioconf_calendar('366d');      calnd='bissextile'
+    CASE('gregorian'); CALL ioconf_calendar('gregorian'); calnd='gregorien'
+    CASE('standard');  CALL ioconf_calendar('gregorian'); calnd='gregorien'
+    CASE('julian');    CALL ioconf_calendar('julian');    calnd='julien'
+    CASE('proleptic_gregorian'); CALL ioconf_calendar('gregorian')
+  !--- DC Bof...  => IOIPSL a mettre a jour: proleptic_gregorian /= gregorian
+    CASE DEFAULT
+      CALL abort_gcm('ce0l','Mauvais choix de calendrier',1)
+  END SELECT
+  WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre '//TRIM(calnd)
+#endif
+
+  IF (type_trac == 'inca') THEN
+#ifdef INCA
+    CALL init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday)
+    CALL init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0)
+    WRITE(lunout,*)'nbtr =' , nbtr 
+#endif
+  END IF
+
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,*) '  ***  etat0_netcdf ***  '
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) ' interbar = ',interbar
+  CALL etat0_netcdf(interbar,masque,phis,ok_etat0)
+
+  IF(ok_limit) THEN
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,*) '  ***  Limit_netcdf ***  '
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,'(//)')
+  CALL limit_netcdf(interbar,extrap,oldice,masque)
+  END IF
+
+  
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  ***************************  '
+  WRITE(lunout,*) '  ***  grilles_gcm_netcdf ***  '
+  WRITE(lunout,*) '  ***************************  '
+  WRITE(lunout,'(//)')
+  CALL grilles_gcm_netcdf_sub(masque,phis)
+
+#endif
+! of #ifndef CPP_EARTH #else
+
+END PROGRAM ce0l
+!
+!-------------------------------------------------------------------------------
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/conf_gcm.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/conf_gcm.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/conf_gcm.F	(revision 222)
@@ -0,0 +1,964 @@
+!
+! $Id: conf_gcm.F 1418 2010-07-19 15:11:24Z jghattas $
+!
+!
+!
+      SUBROUTINE conf_gcm( tapedef, etatinit )
+!
+      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 infotrac, ONLY : type_trac
+      use assert_m, only: assert
+      use sponge_mod, only: callsponge,mode_sponge,nsponge,tetasponge
+
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!     Auteurs :   L. Fairhead , P. Le Van  .
+!
+!     Arguments :
+!
+!     tapedef   :
+!     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+!     -metres  du zoom  avec  celles lues sur le fichier start .
+!
+       LOGICAL etatinit
+       INTEGER tapedef
+
+!   Declarations :
+!   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "iniprint.h"
+#include "temps.h"
+#include "comconst.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! #include "clesphys.h"
+!
+!
+!   local:
+!   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy, tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      LOGICAL use_filtre_fft
+!
+!  -------------------------------------------------------------------
+!
+!       .........     Version  du 29/04/97       ..........
+!
+!   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+!      tetatemp   ajoutes  pour la dissipation   .
+!
+!   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+!
+!  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+!    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+!
+!   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+!         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+!                de limit.dat ( dic)                        ...........
+!           Sinon  etatinit = . FALSE .
+!
+!   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+!    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+!   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+!    lectba .  
+!   Ces parmetres definissant entre autres la grille et doivent etre
+!   pareils et coherents , sinon il y aura  divergence du gcm .
+!
+!-----------------------------------------------------------------------
+!   initialisations:
+!   ----------------
+
+!Config  Key  = lunout
+!Config  Desc = unite de fichier pour les impressions
+!Config  Def  = 6
+!Config  Help = unite de fichier pour les impressions 
+!Config         (defaut sortie standard = 6)
+      lunout=6
+      CALL getin('lunout', lunout)
+      IF (lunout /= 5 .and. lunout /= 6) THEN
+        OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',                     &
+     &          STATUS='unknown',FORM='formatted')
+      ENDIF
+
+!Config  Key  = prt_level
+!Config  Desc = niveau d'impressions de débogage
+!Config  Def  = 0
+!Config  Help = Niveau d'impression pour le débogage
+!Config         (0 = minimum d'impression)
+      prt_level = 0
+      CALL getin('prt_level',prt_level)
+
+!-----------------------------------------------------------------------
+!  Parametres de controle du run:
+!-----------------------------------------------------------------------
+!Config  Key  = planet_type
+!Config  Desc = planet type ("earth", "mars", "venus", ...)
+!Config  Def  = earth
+!Config  Help = this flag sets the type of atymosphere that is considered
+      planet_type="earth"
+      CALL getin('planet_type',planet_type)
+
+!Config  Key  = calend
+!Config  Desc = type de calendrier utilise
+!Config  Def  = earth_360d
+!Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
+!Config         
+      calend = 'earth_360d'
+      CALL getin('calend', calend)
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = raz_date
+!Config  Desc = Remise a zero de la date initiale
+!Config  Def  = 0 (pas de remise a zero)
+!Config  Help = Remise a zero de la date initiale 
+!Config         0 pas de remise a zero, on garde la date du fichier restart
+!Config         1 prise en compte de la date de gcm.def avec remise a zero
+!Config         des compteurs de pas de temps
+      raz_date = 0
+      CALL getin('raz_date', raz_date)
+
+!Config  Key  = resetvarc
+!Config  Desc = Reinit des variables de controle
+!Config  Def  = n
+!Config  Help = Reinit des variables de controle
+      resetvarc = .false.
+      CALL getin('resetvarc',resetvarc)
+
+!Config  Key  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+      ! alternative to specifying nday (see also 'less1day' and 'fractday'
+      ! options below: sopecify numbre of dynamic steps to run:
+      ndynstep = -9999 ! default value ; if ndynstep <0 then option not used.
+      call getin('ndynstep',ndynstep)
+      
+!Config  Key  = starttime
+!Config  Desc = Heure de depart de la simulation
+!Config  Def  = 0
+!Config  Help = Heure de depart de la simulation
+!Config         en jour
+      starttime = 0
+      CALL getin('starttime',starttime)
+      
+      ! Mars: time of start for run in "start.nc" (when there are multiple time
+      !       steps stored in the file)
+      timestart=-9999 ! default value; if <0, use last stored time
+      call getin("timestart",timestart)
+      
+!Config  Key  = less1day
+!Config  Desc = Possibilite d'integrer moins d'un jour
+!Config  Def  = n
+!Config  Help = Possibilite d'integrer moins d'un jour
+      less1day = .false.
+      CALL getin('less1day',less1day)
+
+!Config  Key  = fractday
+!Config  Desc = integration sur une fraction de jour
+!Config  Def  = 0.01
+!Config  Help = integration sur une fraction de jour
+      fractday = 0.01
+      CALL getin('fractday',fractday)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = nsplit_phys
+!Config  Desc = nombre de subdivisions par pas physique
+!Config  Def  = 1 
+!Config  Help = nombre de subdivisions par pas physique
+       nsplit_phys = 1 
+       CALL getin('nsplit_phys',nsplit_phys)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps)
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+!Config  Key  = iapp_tracvl
+!Config  Desc = frequence du groupement des flux 
+!Config  Def  = iperiod
+!Config  Help = frequence du groupement des flux (en pas de temps) 
+       iapp_tracvl = iperiod
+       CALL getin('iapp_tracvl',iapp_tracvl)
+
+!Config  Key  = iconser
+!Config  Desc = periode de sortie des variables de controle
+!Config  Def  = 240  
+!Config  Help = periode de sortie des variables de controle
+!Config         (En pas de temps)
+       iconser = 240  
+       CALL getin('iconser', iconser)
+
+!Config  Key  = iecri
+!Config  Desc = periode d'ecriture du fichier histoire
+!Config  Def  = 1
+!Config  Help = periode d'ecriture du fichier histoire (en jour) 
+       iecri = 1
+       CALL getin('iecri',iecri)
+
+
+!Config  Key  = periodav
+!Config  Desc = periode de stockage fichier histmoy
+!Config  Def  = 1
+!Config  Help = periode de stockage fichier histmoy (en jour) 
+       periodav = 1.
+       CALL getin('periodav',periodav)
+
+!Config  Key  = output_grads_dyn
+!Config  Desc = output dynamics diagnostics in 'dyn.dat' file
+!Config  Def  = n
+!Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
+       output_grads_dyn=.false.
+       CALL getin('output_grads_dyn',output_grads_dyn)
+
+!Config  Key  = dissip_period
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 0
+!Config  Help = periode de la dissipation 
+!Config  dissip_period=0 => la valeur sera calcule dans inidissip       
+!Config  dissip_period>0 => on prend cette valeur
+       dissip_period = 0
+       call getin('idissip',dissip_period) ! old Mars/Genreic model parameter
+       ! if there is a "dissip_period" in run.def, it overrides "idissip"
+       CALL getin('dissip_period',dissip_period)
+
+!cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+!cc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+! For Earth model only:
+! Parametres controlant la variation sur la verticale des constantes de
+! dissipation.
+! Pour le moment actifs uniquement dans la version a 39 niveaux
+! avec ok_strato=y
+
+       dissip_factz=4.
+       dissip_deltaz=10.
+       dissip_zref=30.
+       CALL getin('dissip_factz',dissip_factz )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_zref',dissip_zref )
+
+! For other planets:
+! Parametres controlant la variation sur la verticale des constantes de
+! dissipation.
+! Actifs uniquement avec ok_strato=y
+
+       dissip_fac_mid=2.
+       dissip_fac_up=10.
+       dissip_deltaz=10.! Intervalle (km) pour le changement mid / up
+       dissip_hdelta=5. ! scale height (km) dans la zone de la transition(m)
+       dissip_pupstart=1.e3  ! pression (Pa) au bas la transition mid / up
+       CALL getin('dissip_fac_mid',dissip_fac_mid )
+       CALL getin('dissip_fac_up',dissip_fac_up )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_hdelta',dissip_hdelta )
+       CALL getin('dissip_pupstart',dissip_pupstart )
+
+! top_bound sponge: only active if iflag_top_bound!=0
+!                   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
+       iflag_top_bound=0
+       CALL getin('iflag_top_bound',iflag_top_bound)
+
+! mode_top_bound : fields towards which sponge relaxation will be done:
+!                  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
+       mode_top_bound=3
+       CALL getin('mode_top_bound',mode_top_bound)
+
+! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
+       tau_top_bound=1.e-5
+       CALL getin('tau_top_bound',tau_top_bound)
+
+! the other possible sponge layer (sponge_mod)
+       callsponge=.false. ! default value; don't use the sponge
+       call getin("callsponge",callsponge)
+       ! check that user is not trying to use both sponge models
+       if ((iflag_top_bound.ge.1).and.callsponge) then
+         write(lunout,*)'Bad choice of options:'
+         write(lunout,*)' iflag_top_bound=',iflag_top_bound
+         write(lunout,*)' and callsponge=.true.'
+         write(lunout,*)'But both sponge models should not be',
+     &                  ' used simultaneously!'
+         stop
+       endif
+       
+! nsponge: number of atmospheric layers over which the sponge extends
+       nsponge=3 ! default value
+       call getin("nsponge",nsponge)
+
+! mode_sponge: (quenching is towards ... over the upper nsponge layers)
+!      0: (h=hmean,u=v=0)
+!      1: (h=hmean,u=umean,v=0)
+!      2: (h=hmean,u=umean,v=vmean)"
+       mode_sponge=2 ! default value
+       call getin("mode_sponge",mode_sponge)
+
+! tetasponge: characteristic time scale (seconds) at topmost layer
+!            (time scale then doubles with decreasing layer index)."
+       tetasponge=50000.0
+       call getin("tetasponge",tetasponge)
+
+! FOR TITAN: tidal forces
+       tidal=.TRUE.
+       CALL getin('tidal',tidal)
+
+!Config  Key  = coefdis
+!Config  Desc = coefficient pour gamdissip
+!Config  Def  = 0
+!Config  Help = coefficient pour gamdissip  
+       coefdis = 0.
+       CALL getin('coefdis',coefdis)
+
+!Config  Key  = purmats
+!Config  Desc = Schema d'integration
+!Config  Def  = n
+!Config  Help = Choix du schema d'integration temporel.
+!Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+       purmats = .FALSE.
+       CALL getin('purmats',purmats)
+
+!Config  Key  = ok_guide
+!Config  Desc = Guidage
+!Config  Def  = n
+!Config  Help = Guidage
+       ok_guide = .FALSE.
+       CALL getin('ok_guide',ok_guide)
+
+!    ...............................................................
+
+!Config  Key  =  read_start
+!Config  Desc = Initialize model using a 'start.nc' file
+!Config  Def  = y
+!Config  Help = y: intialize dynamical fields using a 'start.nc' file
+!               n: fields are initialized by 'iniacademic' routine
+       read_start= .true.
+       CALL getin('read_start',read_start)
+
+!Config  Key  = iflag_phys
+!Config  Desc = Avec ls physique 
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       iflag_phys = 1
+       CALL getin('iflag_phys',iflag_phys)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+!Config  Key  = iflag_trac
+!Config  Desc = traceurs presents ou non
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans traceurs
+!Config         
+       iflag_trac = 1 
+       CALL getin('iflag_trac',iflag_trac)
+
+!Config  Key  = ip_ebil_dyn
+!Config  Desc = PRINT level for energy conserv. diag.
+!Config  Def  = 0
+!Config  Help = PRINT level for energy conservation diag. ;
+!               les options suivantes existent :
+!Config         0 pas de print
+!Config         1 pas de print
+!Config         2 print,
+       ip_ebil_dyn = 0
+       CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = type_trac
+!Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
+!Config  Def  = lmdz
+!Config  Help = 
+!Config         'lmdz' = pas de couplage, pur LMDZ
+!Config         'inca' = model de chime INCA 
+!Config         'repr' = model de chime REPROBUS
+      type_trac = 'lmdz'
+      CALL getin('type_trac',type_trac)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+!Config  Key  = ok_dynzon 
+!Config  Desc = calcul et sortie des transports
+!Config  Def  = n 
+!Config  Help = Permet de mettre en route le calcul des transports
+!Config          
+      ok_dynzon = .FALSE.
+      CALL getin('ok_dynzon',ok_dynzon) 
+
+!Config  Key  = ok_dyn_ins
+!Config  Desc = sorties instantanees dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ins = .FALSE. 
+      CALL getin('ok_dyn_ins',ok_dyn_ins) 
+
+!Config  Key  = ok_dyn_ave
+!Config  Desc = sorties moyennes dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ave = .FALSE. 
+      CALL getin('ok_dyn_ave',ok_dyn_ave) 
+
+!Config  Key  = use_filtre_fft
+!Config  Desc = flag d'activation des FFT pour le filtre
+!Config  Def  = false
+!Config  Help = permet d'activer l'utilisation des FFT pour effectuer
+!Config         le filtrage aux poles.
+! Le filtre fft n'est pas implemente dans dyn3d 
+      use_filtre_fft=.FALSE.
+      CALL getin('use_filtre_fft',use_filtre_fft)
+
+      IF (use_filtre_fft) THEN
+        write(lunout,*)'STOP !!!'
+        write(lunout,*)'use_filtre_fft n est pas implemente dans dyn3d'
+        STOP 1
+      ENDIF
+      
+!Config key = ok_strato
+!Config  Desc = activation de la version strato
+!Config  Def  = .FALSE.
+!Config  Help = active la version stratosphérique de LMDZ de F. Lott
+
+      ok_strato=.TRUE.
+      CALL getin('ok_strato',ok_strato)
+
+! NB: vert_prof_dissip is Earth-specific; should not impact other models
+      if (planet_type=="earth") then
+       vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
+       CALL getin('vert_prof_dissip', vert_prof_dissip)
+       call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1,
+     $     "bad value for vert_prof_dissip")
+      else
+       vert_prof_dissip=0 ! default for planets !
+       if (planet_type=="mars") then
+         vert_prof_dissip=1 ! use fac_mid & fac_up & startalt & delta
+       endif
+      endif
+
+!Config  Key  = ok_gradsfile
+!Config  Desc = activation des sorties grads du guidage
+!Config  Def  = n
+!Config  Help = active les sorties grads du guidage
+
+       ok_gradsfile = .FALSE.
+       CALL getin('ok_gradsfile',ok_gradsfile)
+
+!Config  Key  = ok_limit
+!Config  Desc = creation des fichiers limit dans create_etat0_limit
+!Config  Def  = y
+!Config  Help = production du fichier limit.nc requise
+
+       ok_limit = .TRUE.
+       CALL getin('ok_limit',ok_limit)
+
+!Config  Key  = ok_etat0
+!Config  Desc = creation des fichiers etat0 dans create_etat0_limit
+!Config  Def  = y
+!Config  Help = production des fichiers start.nc, startphy.nc requise
+
+      ok_etat0 = .TRUE.
+      CALL getin('ok_etat0',ok_etat0)
+
+!----------------------------------------
+! Parameters for zonal averages in the case of Titan
+      moyzon_mu = .false.
+      moyzon_ch = .false.
+      if (planet_type=="titan") then
+       CALL getin('moyzon_mu', moyzon_mu)
+       CALL getin('moyzon_ch', moyzon_ch)
+      endif
+!----------------------------------------
+
+!----------------------------------------
+!cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+!     .........   (  modif  le 17/04/96 )   .........
+!
+! ZOOM PARAMETERS ... the ones read in start.nc prevail anyway ! (SL, 2012)
+!
+!----------------------------------------
+      IF( etatinit ) then
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)                                                        &
+     &       'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)                                                        &
+     &       'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
+!
+!    alphax et alphay sont les anciennes formulat. des grossissements
+!
+!
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+c
+c----------------------------------------
+       else ! etatinit=false
+c----------------------------------------
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clonn = 0.
+       CALL getin('clon',clonn)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clatt = 0.
+       CALL getin('clat',clatt)
+
+c
+c
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def',     &
+     &    ' est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismxx = 1.0
+       CALL getin('grossismx',grossismxx)
+
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ',       &
+     &  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismyy = 1.0
+       CALL getin('grossismy',grossismyy)
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ',        &
+     & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)                                                        &
+     &       'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)                                                        &
+     &       'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
+!
+!    alphax et alphay sont les anciennes formulat. des grossissements
+!
+!
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+         IF( fxyhypbb )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** fxyhypb lu sur le fichier start est ',     &
+     &       'F alors  qu il est  T  sur  run.def  ***'
+              STOP
+         ENDIF
+      ELSE
+         IF( .NOT.fxyhypbb )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' ***  fxyhypb lu sur le fichier start est ',     &
+     &        'T alors  qu il est  F  sur  run.def  ****  '
+              STOP
+         ENDIF
+      ENDIF
+!
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ',         &
+     &  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomyy = 0.0
+       CALL getin('dzoomy',dzoomyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ',          &
+     & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+      
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       tauxx = 3.0
+       CALL getin('taux',tauxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de taux passee par ',           &
+     & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = tauyy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauyy = 3.0
+       CALL getin('tauy',tauyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de tauy passee par ',           &
+     & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+cc
+      IF( .NOT.fxyhypb  )  THEN
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinuss = .TRUE.
+       CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+          IF( ysinuss )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est F',     &
+     &       ' alors  qu il est  T  sur  run.def  ***'
+            STOP
+          ENDIF
+        ELSE
+          IF( .NOT.ysinuss )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est T',     &
+     &        ' alors  qu il est  F  sur  run.def  ****  '
+              STOP
+          ENDIF
+        ENDIF
+      ENDIF ! of IF( .NOT.fxyhypb  )
+
+      endif ! etatinit
+!----------------------------------------
+
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres lus via run.def '
+      write(lunout,*)' planet_type = ', planet_type
+      write(lunout,*)' calend = ', calend
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      if (ndynstep.ne.-9999) write(lunout,*)' ndynstep = ', ndynstep
+      if (less1day) write(lunout,*)' fractday = ', fractday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' nsplit_phys = ', nsplit_phys
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+      write(lunout,*)' dissip_period = ', dissip_period
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' read_start = ', read_start
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' iflag_trac = ', iflag_trac
+      write(lunout,*)' clon = ', clon
+      write(lunout,*)' clat = ', clat
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypb = ', fxyhypb
+      write(lunout,*)' dzoomx = ', dzoomx
+      write(lunout,*)' dzoomy = ', dzoomy
+      write(lunout,*)' taux = ', taux
+      write(lunout,*)' tauy = ', tauy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' type_trac = ', type_trac
+      write(lunout,*)' config_inca = ', config_inca
+      write(lunout,*)' ok_dynzon = ', ok_dynzon
+      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
+      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+      write(lunout,*)' ok_strato = ', ok_strato
+      write(lunout,*)' ok_gradsfile = ', ok_gradsfile
+      write(lunout,*)' ok_limit = ', ok_limit
+      write(lunout,*)' ok_etat0 = ', ok_etat0
+      if (planet_type=="titan") then
+       write(lunout,*)' moyzon_mu = ', moyzon_mu
+       write(lunout,*)' moyzon_ch = ', moyzon_ch
+      endif
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dissip.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dissip.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dissip.F	(revision 222)
@@ -0,0 +1,148 @@
+!
+! $Id: $
+!
+      SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh )
+c
+      IMPLICIT NONE
+
+
+c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+c                                 (  10/01/98  )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation horizontale
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comdissnew.h"
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
+      REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
+      REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
+      REAL,INTENT(IN) :: p(ip1jmp1,llmp1) ! pressure
+      ! tendencies (.../s) on covariant winds and potential temperature
+      REAL,INTENT(OUT) :: dv(ip1jm,llm)
+      REAL,INTENT(OUT) :: du(ip1jmp1,llm)
+      REAL,INTENT(OUT) :: dh(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
+      REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
+      REAL te1dt(llm),te2dt(llm),te3dt(llm)
+      REAL deltapres(ip1jmp1,llm)
+
+      INTEGER l,ij
+
+      REAL  SSUM
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      DO l=1,llm
+         te1dt(l) = tetaudiv(l) * dtdiss
+         te2dt(l) = tetaurot(l) * dtdiss
+         te3dt(l) = tetah(l)    * dtdiss
+      ENDDO
+      du=0.
+      dv=0.
+      dh=0.
+
+c-----------------------------------------------------------------------
+c   Calcul de la dissipation:
+c   -------------------------
+
+c   Calcul de la partie   grad  ( div ) :
+c   -------------------------------------
+
+
+      IF(lstardis) THEN
+         CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+         CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ENDIF
+
+      DO l=1,llm
+
+         DO ij = 1, iip1
+            gdx(     ij ,l) = 0.
+            gdx(ij+ip1jm,l) = 0.
+         ENDDO
+
+         DO ij = iip2,ip1jm
+            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+         ENDDO
+
+       ENDDO
+
+c   calcul de la partie   n X grad ( rot ):
+c   ---------------------------------------
+
+      IF(lstardis) THEN
+         CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+         CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry )
+      ENDIF
+
+
+      DO l=1,llm
+         DO ij = 1, iip1
+            grx(ij,l) = 0.
+         ENDDO
+
+         DO ij = iip2,ip1jm
+            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+         ENDDO
+         DO ij =  1, ip1jm
+            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+         ENDDO
+      ENDDO
+
+c   calcul de la partie   div ( grad ):
+c   -----------------------------------
+
+        
+      IF(lstardis) THEN
+
+       DO l = 1, llm
+          DO ij = 1, ip1jmp1
+            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+          ENDDO
+       ENDDO
+
+         CALL divgrad2( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+         CALL divgrad ( llm,teta, niterh, gdx        )
+      ENDIF
+
+      DO l = 1,llm
+         DO ij = 1,ip1jmp1
+            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dteta1.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dteta1.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dteta1.F	(revision 222)
@@ -0,0 +1,68 @@
+!
+! $Header$
+!
+      SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+c
+c   ********************************************************************
+c   ... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dteta 	          sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dteta( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
+
+c
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm - 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 = iip1+ iip1, ip1jm, iip1
+      hbxu( ij, l ) = hbxu( ij - iim, l )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+        CALL  convflu ( hbxu, hbyv, llm, dteta )
+
+
+c    stockage dans  dh de la convergence horizont. filtree' du  flux
+c                  ....                           ...........
+c           d'enthalpie potentielle .
+
+      CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1)
+
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dudv1.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dudv1.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dudv1.F	(revision 222)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv )
+      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( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) ,
+     *     pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm )
+      INTEGER  l,ij
+c
+c
+      DO 10 l = 1,llm
+c
+      DO 2  ij = iip2, ip1jm - 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
+      DO 3 ij = 1, ip1jm - 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 = 1, ip1jm, iip1
+      dv( ij,l ) = dv( ij + iim, l )
+   4  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dudv2.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dudv2.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/dudv2.F	(revision 222)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      SUBROUTINE dudv2 ( teta, pkf, bern, du, dv  )
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *****************************************************************
+c   ..... calcul du terme de pression (gradient de p/densite )   et
+c          du terme de ( -gradient de la fonction de Bernouilli ) ...
+c   *****************************************************************
+c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+c
+c
+c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+c    du et dv          sont des arguments de sortie pour le s-pg  ....
+c
+c=======================================================================
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ),
+     *         du( ip1jmp1,llm ),  dv( ip1jm,llm )
+      INTEGER  l,ij
+c
+c
+      DO 5 l = 1,llm
+c
+      DO 2  ij  = iip2, ip1jm - 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 = iip1+ iip1, ip1jm, iip1
+      du( ij,l ) = du( ij - iim,l )
+   3  CONTINUE
+c
+c
+      DO 4 ij  = 1,ip1jm
+      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
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/fluxstokenc.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/fluxstokenc.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/fluxstokenc.F	(revision 222)
@@ -0,0 +1,173 @@
+!
+! $Id: fluxstokenc.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     . time_step,itau )
+#ifdef CPP_IOIPSL
+! This routine is designed to work with ioipsl
+
+       USE IOIPSL
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "tracstoke.h"
+#include "temps.h"
+#include "iniprint.h"
+
+      REAL time_step,t_wrt, t_ops
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+      REAL phis(ip1jmp1)
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
+
+      REAL pbarvst(iip1,jjp1,llm),zistdyn
+	real dtcum
+
+      INTEGER iadvtr,ndex(1) 
+      integer nscal
+      real tst(1),ist(1),istp(1)
+      INTEGER ij,l,irec,i,j,itau
+      INTEGER, SAVE :: fluxid, fluxvid,fluxdid
+ 
+      SAVE iadvtr, massem,pbaruc,pbarvc,irec
+      SAVE phic,tetac
+      logical first
+      save first
+      data first/.true./
+      DATA iadvtr/0/
+
+
+c AC initialisations
+      pbarug(:,:)   = 0.
+      pbarvg(:,:,:) = 0.
+      wg(:,:)       = 0.
+      
+
+      if(first) then
+
+	CALL initfluxsto( 'fluxstoke',
+     .  time_step,istdyn* time_step,istdyn* time_step,
+     .  fluxid,fluxvid,fluxdid) 
+	
+	ndex(1) = 0
+        call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
+        call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
+	
+	ndex(1) = 0
+        nscal = 1
+        tst(1) = time_step
+        call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
+        ist(1)=istdyn
+        call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
+        istp(1)= istphy
+        call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
+	
+	first = .false.
+
+      endif
+
+
+      IF(iadvtr.EQ.0) THEN
+         CALL initial0(ijp1llm,phic)
+         CALL initial0(ijp1llm,tetac)
+         CALL initial0(ijp1llm,pbaruc)
+         CALL initial0(ijmllm,pbarvc)
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(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 = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.istdyn ) THEN
+c    normalisation
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
+            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
+            phic(ij,l) = phic(ij,l)/REAL(istdyn)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
+         ENDDO
+      ENDDO
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+        do l=1,llm
+           do j=1,jjm
+              do i=1,iip1
+                 pbarvst(i,j,l)=pbarvg(i,j,l)
+              enddo
+           enddo
+           do i=1,iip1
+              pbarvst(i,jjp1,l)=0.
+           enddo
+        enddo
+
+         iadvtr=0
+	write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
+	
+	call histwrite(fluxid, 'masse', itau, massem,
+     .               iip1*jjp1*llm, ndex)
+	
+	call histwrite(fluxid, 'pbaru', itau, pbarug,
+     .               iip1*jjp1*llm, ndex)
+	
+	call histwrite(fluxvid, 'pbarv', itau, pbarvg,
+     .               iip1*jjm*llm, ndex)
+	
+        call histwrite(fluxid, 'w' ,itau, wg, 
+     .             iip1*jjp1*llm, ndex) 
+	
+	call histwrite(fluxid, 'teta' ,itau, tetac, 
+     .             iip1*jjp1*llm, ndex) 
+	
+	call histwrite(fluxid, 'phi' ,itau, phic, 
+     .             iip1*jjp1*llm, ndex) 
+	
+C
+
+      ENDIF ! if iadvtr.EQ.istdyn
+
+#else
+      write(lunout,*)
+     & 'fluxstokenc: Needs IOIPSL to function'
+#endif
+! of #ifdef CPP_IOIPSL
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/friction.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/friction.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/friction.F	(revision 222)
@@ -0,0 +1,136 @@
+!
+! $Id: friction.F 1437 2010-09-30 08:29:10Z emillour $
+!
+c=======================================================================
+      SUBROUTINE friction(ucov,vcov,pdt)
+
+      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
+      
+      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 "comconst.h"
+#include "iniprint.h"
+#include "academic.h"
+
+! arguments:
+      REAL,INTENT(out) :: ucov( iip1,jjp1,llm )
+      REAL,INTENT(out) :: vcov( iip1,jjm,llm )
+      REAL,INTENT(in) :: pdt ! time step
+
+! local variables:
+
+      REAL modv(iip1,jjp1),zco,zsi
+      REAL vpn,vps,upoln,upols,vpols,vpoln
+      REAL u2(iip1,jjp1),v2(iip1,jjm)
+      INTEGER  i,j,l
+      REAL,PARAMETER :: cfric=1.e-5
+      LOGICAL,SAVE :: firstcall=.true.
+      INTEGER,SAVE :: friction_type=1
+      CHARACTER(len=20) :: modname="friction"
+      CHARACTER(len=80) :: abort_message
+      
+      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
+
+      if (friction_type.eq.0) then
+c   calcul des composantes au carre du vent naturel
+      do j=1,jjp1
+         do i=1,iip1
+            u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+         enddo
+      enddo
+      do j=1,jjm
+         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
+      do j=2,jjm
+         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
+      upoln=0.
+      vpoln=0.
+      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))
+         vpn=vcov(i,1,1)/cv(i,1)
+         vps=vcov(i,jjm,1)/cv(i,jjm)
+         upoln=upoln+zco*vpn
+         vpoln=vpoln+zsi*vpn
+         upols=upols+zco*vps
+         vpols=vpols+zsi*vps
+      enddo
+      vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+      vps=sqrt(upols*upols+vpols*vpols)/pi
+      do i=1,iip1
+c        modv(i,1)=vpn
+c        modv(i,jjp1)=vps
+         modv(i,1)=modv(i,2)
+         modv(i,jjp1)=modv(i,jjm)
+      enddo
+
+c   calcul du frottement au sol.
+      do j=2,jjm
+         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
+      do j=1,jjm
+         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
+      endif ! of if (friction_type.eq.0)
+
+      if (friction_type.eq.1) then
+        do l=1,llm
+          ucov(:,:,l)=ucov(:,:,l)*(1.-pdt*kfrict(l))
+          vcov(:,:,l)=vcov(:,:,l)*(1.-pdt*kfrict(l))
+        enddo
+      endif
+      
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/gcm.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/gcm.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/gcm.F	(revision 222)
@@ -0,0 +1,582 @@
+!
+! $Id: gcm.F 1446 2010-10-22 09:27:25Z emillour $
+!
+c
+c
+      PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      USE ioipsl_getincom
+#endif
+
+
+#ifdef CPP_XIOS
+    ! ug Pour les sorties XIOS
+	USE wxios
+#endif
+
+      USE filtreg_mod
+      USE infotrac
+      USE control_mod, only: planet_type,nday,day_step,iperiod,iphysiq,
+     &                       raz_date,anneeref,starttime,dayref,
+     &                       ok_dyn_ins,ok_dyn_ave,iecri,periodav,
+     &                       less1day,fractday,ndynstep,nsplit_phys
+      use cpdet_mod, only: ini_cpdet
+
+#ifdef INCA
+! Only INCA needs these informations (from the Earth's physics)
+      USE indice_sol_mod
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! A nettoyer. On ne veut qu'une ou deux routines d'interface 
+! dynamique -> physique pour l'initialisation
+! Ehouarn: the following are needed with (parallel) physics:
+#ifdef CPP_PHYS
+      USE dimphy
+      USE comgeomphy
+#endif
+#ifdef INCA
+      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+#endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+c  ... Possibilite de choisir le schema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+!!!!!!!!!!!#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+!#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "tracstoke.h"
+#ifdef INCA
+! Only INCA needs these informations (from the Earth's physics)
+!#include "indicesol.h"
+#endif
+
+
+      REAL zdtvr
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+      REAL w(ip1jmp1,llm)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL time_0
+
+      LOGICAL lafin
+      INTEGER ij,iq,l,i,j
+
+
+      real time_step, t_wrt, t_ops
+
+      LOGICAL first
+
+      LOGICAL call_iniphys
+      data call_iniphys/.true./
+
+c+jld variables test conservation energie
+c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+      REAL dhecdt(ip1jmp1,llm)
+c      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+c      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+      CHARACTER (len=15) :: ztit
+c-jld 
+
+
+      character (len=80) :: dynhist_file, dynhistave_file
+      character (len=20) :: modname
+      character (len=80) :: abort_message
+! locales pour gestion du temps
+      INTEGER :: an, mois, jour
+      REAL :: heure
+
+
+c-----------------------------------------------------------------------
+c    variables pour l'initialisation de la physique :
+c    ------------------------------------------------
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx)
+      REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      abort_message = 'last timestep reached'
+      modname = 'gcm'
+      descript = 'Run GCM LMDZ'
+      lafin    = .FALSE.
+      dynhist_file = 'dyn_hist.nc'
+      dynhistave_file = 'dyn_hist_ave.nc'
+
+
+
+c----------------------------------------------------------------------
+c  lecture des fichiers gcm.def ou run.def
+c  ---------------------------------------
+c
+! Ehouarn: dump possibility of using defrun
+!#ifdef CPP_IOIPSL
+      CALL conf_gcm( 99, .TRUE. )
+!#else
+!      CALL defrun( 99, .TRUE. , clesphy0 )
+!#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Initialisation de XIOS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef CPP_XIOS
+	CALL wxios_init("LMDZ")
+#endif
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02
+! A nettoyer. On ne veut qu'une ou deux routines d'interface 
+! dynamique -> physique pour l'initialisation
+#ifdef CPP_PHYS
+      CALL init_phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+      call initcomgeomphy
+#endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+c
+c Initialisations pour Cp(T) Venus
+      call ini_cpdet
+c
+c-----------------------------------------------------------------------
+c   Choix du calendrier
+c   -------------------
+
+c      calend = 'earth_365d'
+
+#ifdef CPP_IOIPSL
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360d')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+      else if (calend == 'earth_365d') then
+        call ioconf_calendar('noleap')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+      else if (calend == 'earth_366d') then
+        call ioconf_calendar('gregorian')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
+      else if (calend == 'titan') then
+!        call ioconf_calendar('titan')
+        write(lunout,*)'CALENDRIER CHOISI: Titan'
+        abort_message = 'A FAIRE...'
+        call abort_gcm(modname,abort_message,1)
+      else if (calend == 'venus') then
+!        call ioconf_calendar('venus')
+        write(lunout,*)'CALENDRIER CHOISI: Venus'
+        abort_message = 'A FAIRE...'
+        call abort_gcm(modname,abort_message,1)
+      else
+        abort_message = 'Mauvais choix de calendrier'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#endif
+c-----------------------------------------------------------------------
+
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+      call init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday, 
+     $        nbsrf, is_oce,is_sic,is_ter,is_lic)
+      call init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0)
+#endif
+      END IF
+c
+c
+c------------------------------------
+c   Initialisation partie parallele
+c------------------------------------
+
+c
+c
+c-----------------------------------------------------------------------
+c   Initialisation des traceurs
+c   ---------------------------
+c  Choix du nombre de traceurs et du schema pour l'advection
+c  dans fichier traceur.def, par default ou via INCA
+      call infotrac_init
+
+c Allocation de la tableau q : champs advectes   
+      allocate(q(ip1jmp1,llm,nqtot))
+
+c-----------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+
+c  lecture du fichier start.nc
+      if (read_start) then
+      ! we still need to run iniacademic to initialize some
+      ! constants & fields, if we run the 'newtonian' or 'SW' cases:
+        if (iflag_phys.ne.1) then
+          CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+        endif
+
+        CALL dynetat0("start.nc",vcov,ucov,
+     &              teta,q,masse,ps,phis, time_0)
+       
+        ! Load relaxation fields (simple nudging). AS 09/2013
+        ! ---------------------------------------------------
+        if (planet_type.eq."generic") then
+         if (ok_guide) then
+           CALL relaxetat0("relax.nc")
+         endif
+        endif
+ 
+c       write(73,*) 'ucov',ucov
+c       write(74,*) 'vcov',vcov
+c       write(75,*) 'teta',teta
+c       write(76,*) 'ps',ps
+c       write(77,*) 'q',q
+
+      endif ! of if (read_start)
+
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+         call init_inca_dim(klon,llm,iim,jjm,
+     $        rlonu,rlatu,rlonv,rlatv)
+#endif
+      END IF
+
+
+c le cas echeant, creation d un etat initial
+      IF (prt_level > 9) WRITE(lunout,*)
+     .              'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
+      if (.not.read_start) then
+         CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+      endif
+
+
+c-----------------------------------------------------------------------
+c   Lecture des parametres de controle pour la simulation :
+c   -------------------------------------------------------
+c  on recalcule eventuellement le pas de temps
+
+      IF(MOD(day_step,iperiod).NE.0) THEN
+        abort_message = 
+     .  'Il faut choisir un nb de pas par jour multiple de iperiod'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      IF(MOD(day_step,iphysiq).NE.0) THEN
+        abort_message = 
+     * 'Il faut choisir un nb de pas par jour multiple de iphysiq'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      zdtvr    = daysec/REAL(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         WRITE(lunout,*)
+     .    'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+C
+C on remet le calendrier à zero si demande
+c
+      IF (start_time /= starttime) then
+        WRITE(lunout,*)' GCM: Attention l''heure de depart lue dans le'
+     &,' fichier restart ne correspond pas à celle lue dans le run.def'
+        IF (raz_date == 1) then
+          WRITE(lunout,*)'Je prends l''heure lue dans run.def'
+          start_time = starttime
+        ELSE
+          call abort_gcm("gcm", "'Je m''arrete'", 1)
+        ENDIF
+      ENDIF
+      IF (raz_date == 1) THEN
+        annee_ref = anneeref
+        day_ref = dayref
+        day_ini = dayref
+        itau_dyn = 0
+        itau_phy = 0
+        time_0 = 0.
+        write(lunout,*)
+     .   'GCM: On reinitialise a la date lue dans gcm.def'
+      ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
+        write(lunout,*)
+     .  'GCM: Attention les dates initiales lues dans le fichier'
+        write(lunout,*)
+     .  ' restart ne correspondent pas a celles lues dans '
+        write(lunout,*)' gcm.def'
+        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+        write(lunout,*)' Pas de remise a zero'
+      ENDIF
+
+c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+c        write(lunout,*)
+c     .  'GCM: Attention les dates initiales lues dans le fichier'
+c        write(lunout,*)
+c     .  ' restart ne correspondent pas a celles lues dans '
+c        write(lunout,*)' gcm.def'
+c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+c        if (raz_date .ne. 1) then
+c          write(lunout,*)
+c     .    'GCM: On garde les dates du fichier restart'
+c        else
+c          annee_ref = anneeref
+c          day_ref = dayref
+c          day_ini = dayref
+c          itau_dyn = 0
+c          itau_phy = 0
+c          time_0 = 0.
+c          write(lunout,*)
+c     .   'GCM: On reinitialise a la date lue dans gcm.def'
+c        endif
+c      ELSE
+c        raz_date = 0
+c      endif
+
+#ifdef CPP_IOIPSL
+      mois = 1
+      heure = 0.
+! Ce n'est defini pour l'instant que pour la Terre... 
+      if (planet_type.eq.'earth') then
+      call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
+      jH_ref = jD_ref - int(jD_ref)
+      jD_ref = int(jD_ref)
+
+      call ioconf_startdate(INT(jD_ref), jH_ref)
+
+      write(lunout,*)'DEBUG'
+      write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
+      write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
+      call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
+      write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
+      write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
+      else
+! A voir pour Titan et Venus
+        jD_ref=0
+        jH_ref=0
+      write(lunout,*)'A VOIR POUR VENUS ET TITAN: jD_ref, jH_ref'
+      write(lunout,*)jD_ref,jH_ref
+      endif ! planet_type
+#else
+! Ehouarn: we still need to define JD_ref and JH_ref
+! and since we don't know how many days there are in a year
+! we set JD_ref to 0 (this should be improved ...)
+      jD_ref=0
+      jH_ref=0
+#endif
+
+      if (iflag_phys.eq.1) then
+      ! these initialisations have already been done (via iniacademic)
+      ! if running in SW or Newtonian mode
+c-----------------------------------------------------------------------
+c   Initialisation des constantes dynamiques :
+c   ------------------------------------------
+        dtvr = zdtvr
+        CALL iniconst
+
+c-----------------------------------------------------------------------
+c   Initialisation de la geometrie :
+c   --------------------------------
+        CALL inigeom
+
+c-----------------------------------------------------------------------
+c   Initialisation du filtre :
+c   --------------------------
+        CALL inifilr
+      endif ! of if (iflag_phys.eq.1)
+c
+c-----------------------------------------------------------------------
+c   Initialisation de la dissipation :
+c   ----------------------------------
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
+
+c-----------------------------------------------------------------------
+c   Initialisation de la physique :
+c   -------------------------------
+
+      IF (call_iniphys.and.(iflag_phys==1.or.iflag_phys>=100)) THEN
+         latfi(1)=rlatu(1)
+         lonfi(1)=0.
+         zcufi(1) = cu(1)
+         zcvfi(1) = cv(1)
+         DO j=2,jjm
+            DO i=1,iim
+               latfi((j-2)*iim+1+i)= rlatu(j)
+               lonfi((j-2)*iim+1+i)= rlonv(i)
+               zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i)
+               zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i)
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)
+         lonfi(ngridmx)= 0.
+         zcufi(ngridmx) = cu(ip1jm+1)
+         zcvfi(ngridmx) = cv(ip1jm-iim)
+
+         ! build airefi(), mesh area on physics grid
+         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+         ! Poles are single points on physics grid
+         airefi(1)=airefi(1)*iim
+         airefi(ngridmx)=airefi(ngridmx)*iim
+
+! Initialisation de la physique: pose probleme quand on tourne 
+! SANS physique, car iniphysiq.F est dans le repertoire phy[]... 
+! Il faut une cle CPP_PHYS
+#ifdef CPP_PHYS
+         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys,
+     &                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp,
+     &                iflag_phys)
+#endif
+         call_iniphys=.false.
+      ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1))
+
+c  numero de stockage pour les fichiers de redemarrage:
+
+c-----------------------------------------------------------------------
+c   Initialisation des I/O :
+c   ------------------------
+
+      if (nday>=0) then ! standard case
+        day_end=day_ini+nday
+      else ! special case when nday <0, run -nday dynamical steps
+        day_end=day_ini-nday/day_step
+      endif
+      if (less1day) then
+        day_end=day_ini+floor(time_0+fractday)
+      endif
+      if (ndynstep.gt.0) then
+        day_end=day_ini+floor(time_0+float(ndynstep)/float(day_step))
+      endif
+      
+      WRITE(lunout,'(a,i7,a,i7)')
+     &             "run from day ",day_ini,"  to day",day_end
+
+#ifdef CPP_IOIPSL
+! Ce n'est defini pour l'instant que pour la Terre... 
+      if (planet_type.eq.'earth') then
+      call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
+      write (lunout,301)jour, mois, an
+      call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
+      write (lunout,302)jour, mois, an
+      else
+! A voir pour Titan et Venus
+      write(lunout,*)'A VOIR POUR VENUS/TITAN: separation en annees...'
+      endif ! planet_type
+
+ 301  FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
+ 302  FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
+#endif
+
+      if (planet_type=="mars") then
+        ! For Mars we transmit day_ini
+        CALL dynredem0("restart.nc", day_ini, phis)
+      else
+        CALL dynredem0("restart.nc", day_end, phis)
+      endif
+      ecripar = .TRUE.
+
+#ifdef CPP_IOIPSL
+      time_step = zdtvr
+      if (ok_dyn_ins) then
+        ! initialize output file for instantaneous outputs
+        ! t_ops = iecri * daysec ! do operations every t_ops
+        t_ops =((1.0*iecri)/day_step) * daysec  
+        t_wrt = daysec ! iecri * daysec ! write output every t_wrt
+        CALL inithist(day_ref,annee_ref,time_step,
+     &              t_ops,t_wrt)
+      endif
+
+      IF (ok_dyn_ave) THEN 
+        ! initialize output file for averaged outputs
+        t_ops = iperiod * time_step ! do operations every t_ops
+        t_wrt = periodav * daysec   ! write output every t_wrt
+        CALL initdynav(day_ref,annee_ref,time_step,
+     &       t_ops,t_wrt)
+      END IF
+      dtav = iperiod*dtvr/daysec
+#endif
+! #endif of #ifdef CPP_IOIPSL
+
+c  Choix des frequences de stokage pour le offline
+c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
+      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
+      istphy=istdyn/iphysiq     
+
+
+c
+c-----------------------------------------------------------------------
+c   Integration temporelle du modele :
+c   ----------------------------------
+
+c       write(78,*) 'ucov',ucov
+c       write(78,*) 'vcov',vcov
+c       write(78,*) 'teta',teta
+c       write(78,*) 'ps',ps
+c       write(78,*) 'q',q
+
+
+      CALL leapfrog(ucov,vcov,teta,ps,masse,phis,q,
+     .              time_0)
+
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/getparam.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/getparam.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/getparam.F90	(revision 222)
@@ -0,0 +1,106 @@
+!
+! $Id: getparam.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE getparam
+#ifdef CPP_IOIPSL
+   USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+   USE ioipsl_getincom
+#endif
+
+   INTERFACE getpar
+     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml
+   END INTERFACE
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    open(out_eff,file=fichier,status='unknown',form='formatted') 
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+    !
+    IMPLICIT NONE
+    !
+    close(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) comment
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/groupe.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/groupe.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/groupe.F	(revision 222)
@@ -0,0 +1,108 @@
+!
+! $Header$
+!
+      subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      implicit none
+
+c   sous-programme servant a fitlrer les champs de flux de masse aux
+c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+c   et a mesure qu'on se rapproche du pole.
+c
+c   en entree: pext, pbaru et pbarv
+c
+c   en sortie:  pbarum,pbarvm et wm.
+c
+c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+c   pas besoin de w en entree.
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "comvert.h"
+
+      integer ngroup
+      parameter (ngroup=3)
+
+
+      real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
+      real pext(iip1,jjp1,llm)
+
+      real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
+      real wm(iip1,jjp1,llm)
+
+      real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm)
+
+      real uu
+
+      integer i,j,l
+
+      logical firstcall,groupe_ok
+      save firstcall,groupe_ok
+
+      data firstcall/.true./
+      data groupe_ok/.true./
+
+      if (iim==1) then
+         groupe_ok=.false.
+      endif
+
+      if (firstcall) then
+         if (groupe_ok) then
+           if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre de point'
+         endif
+         firstcall=.false.
+      endif
+
+
+c   Champs 1D
+
+      call convflu(pbaru,pbarv,llm,zconvm)
+
+      call scopy(ijp1llm,zconvm,1,zconvmm,1)
+      call scopy(ijmllm,pbarv,1,pbarvm,1)
+
+      if (groupe_ok) then
+      call groupeun(jjp1,llm,zconvmm)
+      call groupeun(jjm,llm,pbarvm)
+
+c   Champs 3D
+      do l=1,llm
+         do j=2,jjm
+            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
+
+      else
+         pbarum(:,:,:)=pbaru(:,:,:)
+         pbarvm(:,:,:)=pbarv(:,:,:)
+      endif
+
+c    integration de la convergence de masse de haut  en bas ......
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iip1
+               zconvmm(i,j,l)=zconvmm(i,j,l)
+            enddo
+         enddo
+      enddo
+      do  l = llm-1,1,-1
+          do j=1,jjp1
+             do i=1,iip1
+                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+             enddo
+          enddo
+      enddo
+
+      CALL vitvert(zconvmm,wm)
+
+      return
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/groupeun.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/groupeun.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/groupeun.F	(revision 222)
@@ -0,0 +1,200 @@
+!
+! $Header$
+!
+      SUBROUTINE groupeun(jjmax,llmax,q)
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      INTEGER jjmax,llmax
+      REAL q(iip1,jjmax,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 Ã  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)
+
+      LOGICAL, SAVE :: first = .TRUE.
+      INTEGER,SAVE :: i_index(iim,ngroup)
+      INTEGER      :: offset
+      REAL         :: qsum(iim/ngroup)
+
+      IF (first) THEN
+         CALL INIT_GROUPEUN(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  = j1-jd
+            j_finish = 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  = j1-jd
+            j_finish = 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(airen_tab, aires_tab)
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      INTEGER ngroup
+      PARAMETER (ngroup=3)
+
+      REAL airen,airecn
+      REAL aires,airecs
+
+      INTEGER i,j,l,ig,j1,j2,i0,jd
+
+      INTEGER j_start, j_finish
+
+      REAL :: airen_tab(iip1,jjp1,0:1)
+      REAL :: aires_tab(iip1,jjp1,0:1)
+
+      DO jd=0, 1
+         j1=1+jd
+         j2=2
+         DO ig=1,ngroup
+            
+!     c     Concerne le pole nord
+            j_start = j1-jd
+            j_finish = j2-jd
+            DO j=j_start, j_finish
+               DO i0=1,iim,2**(ngroup-ig+1)
+                  airen=0.
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     airen = airen+aire(i,j)
+                  ENDDO
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     airen_tab(i,j,jd) = 
+     &                    aire(i,j) / airen
+                  ENDDO
+               ENDDO
+            ENDDO
+            
+!     c     Concerne le pole sud
+            j_start = j1-jd
+            j_finish = j2-jd
+            DO j=j_start, j_finish
+               DO i0=1,iim,2**(ngroup-ig+1)
+                  aires=0.
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     aires=aires+aire(i,jjp1-j+1)
+                  ENDDO
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     aires_tab(i,jjp1-j+1,jd) = 
+     &                    aire(i,jjp1-j+1) / aires
+                  ENDDO
+               ENDDO
+            ENDDO
+            
+            j1=j2+1
+            j2=j2+2**ig
+         ENDDO
+      ENDDO
+      
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/guide_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/guide_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/guide_mod.F90	(revision 222)
@@ -0,0 +1,1683 @@
+!
+! $Id$
+!
+MODULE guide_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam
+  USE Write_Field
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
+  use pres2lev_mod
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: guide_modele,invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+
+    USE control_mod
+
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'forÃ¯Â¿Âœage constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    
+! Sauvegarde du forÃ¯Â¿Âœage
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+        iguide_sav=day_step/iguide_sav
+    ELSE
+        iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage')
+    IF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele')
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_modele) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier apbp.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    else
+         if (guide_u) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+               if (rcod.NE.NF_NOERR) THEN
+                  print *,'Guide: probleme -> pas de fichier u.nc'
+                  CALL abort_gcm(modname,abort_message,1)
+               endif
+           endif
+         elseif (guide_v) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+               if (rcod.NE.NF_NOERR) THEN
+                  print *,'Guide: probleme -> pas de fichier v.nc'
+                  CALL abort_gcm(modname,abort_message,1)
+               endif
+           endif
+         elseif (guide_T) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+               if (rcod.NE.NF_NOERR) THEN
+                  print *,'Guide: probleme -> pas de fichier T.nc'
+                  CALL abort_gcm(modname,abort_message,1)
+               endif
+           endif
+         elseif (guide_Q) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+               if (rcod.NE.NF_NOERR) THEN
+                  print *,'Guide: probleme -> pas de fichier hur.nc'
+                  CALL abort_gcm(modname,abort_message,1)
+               endif
+           endif
+         endif
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        print *,'Guide: probleme lecture niveaux pression'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    print *,'Guide: nombre niveaux vert. nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='pb in allocation guide'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ip1jm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_P.OR.guide_modele) THEN
+        ALLOCATE(psnat1(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_P.OR.guide_modele) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+
+    USE control_mod
+ 
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+
+    ! Variables entree
+    INTEGER,                       INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+    
+    INTEGER       :: l
+
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+    IF (first) THEN
+        first=.FALSE.
+        CALL guide_init 
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
+            enddo
+        endif
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov=ugui2
+            IF (guide_v) vcov=ugui2
+            IF (guide_T) teta=tgui2
+            IF (guide_Q) q=qgui2
+            IF (guide_P) THEN
+                ps=psgui2
+                CALL pression(ip1jmp1,ap,bp,ps,p)
+                CALL massdair(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+        IF (guide_u) THEN
+            CALL writefield('unat',unat1)
+            CALL writefield('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
+        ENDIF
+        IF (guide_T) THEN
+            CALL writefield('tnat',tnat1)
+            CALL writefield('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/REAL(iguide_read)
+      ELSE
+          tau=REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+              write(*,*)'deuxieme passage de advreel a itau=',itau
+              stop
+          ELSE
+              IF (guide_v) vnat1=vnat2
+              IF (guide_u) unat1=unat2
+              IF (guide_T) tnat1=tnat2
+              IF (guide_Q) qnat1=qnat2
+              IF (guide_P.OR.guide_modele) psnat1=psnat2
+              step_rea=step_rea+1
+              itau_test=itau
+              print*,'Lecture fichiers guidage, pas ',step_rea, &
+                    'apres ',count_no_rea,' non lectures'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) CALL guide_out("SP",jjp1,1,ps)
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add=(1.-tau)*ugui1+tau*ugui2
+        else
+           f_add=(1.-tau)*ugui1+tau*ugui2-ucov
+        endif 
+        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1+tau*ugui2)
+        IF (f_out) CALL guide_out("u",jjp1,llm,ucov)
+        IF (f_out) CALL guide_out("ucov",jjp1,llm,f_add/factt)
+        ucov=ucov+f_add
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add=(1.-tau)*tgui1+tau*tgui2
+        else
+           f_add=(1.-tau)*tgui1+tau*tgui2-teta
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("teta",jjp1,llm,f_add/factt)
+        teta=teta+f_add
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2
+        else
+           f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2-ps
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
+        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
+        IF (f_out) CALL guide_out("ps",jjp1,1,f_add(1:ip1jmp1,1)/factt)
+        ps=ps+f_add(1:ip1jmp1,1)
+        CALL pression(ip1jmp1,ap,bp,ps,p)
+        CALL massdair(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add=(1.-tau)*qgui1+tau*qgui2
+        else
+           f_add=(1.-tau)*qgui1+tau*qgui2-q
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("q",jjp1,llm,f_add/factt)
+        q=q+f_add
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2
+        else
+           f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2-vcov
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
+        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
+        IF (f_out) CALL guide_out("v",jjm,llm,vcov)
+        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1+tau*vgui2)
+        IF (f_out) CALL guide_out("vcov",jjm,llm,f_add(1:ip1jm,:)/factt)
+        vcov=vcov+f_add(1:ip1jm,:)
+    endif
+  END SUBROUTINE guide_main
+
+!=======================================================================
+  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: hsize
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    do l=1,vsize
+        field(:,l)=alpha*field(:,l)*alpha_pcor(l)
+    enddo
+
+  END SUBROUTINE guide_addfield
+
+!=======================================================================
+  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    DO l=1,vsize
+    ! Compute zonal average
+        DO j=1,hsize
+            DO i=imin(typ),imax(typ)
+                ij=(j-1)*iip1+i
+                fieldm(j,l)=fieldm(j,l)+field(ij,l)
+            ENDDO
+        ENDDO 
+        fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+        DO j=1,hsize
+            DO i=1,iip1
+                ij=(j-1)*iip1+i
+                field(ij,l)=fieldm(j,l)
+            ENDDO
+        ENDDO
+    ENDDO
+
+  END SUBROUTINE guide_zonave
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+  
+  use exner_hyb_m, only: exner_hyb
+  use exner_milieu_m, only: exner_milieu
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comgeom2.h"
+  include "comconst.h"
+
+  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
+  REAL, DIMENSION (iip1,jjp1,llmp1)  :: p           ! pression intercouches 
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pbarx 
+  REAL, DIMENSION (iip1,jjm,llm)     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
+  REAL, DIMENSION (iip1,jjp1)        :: pks    
+  REAL                               :: prefkap,unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
+  !Variables intermediaires interpolation
+  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
+  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  
+    print *,'Guide: conversion variables guidage'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage
+! -----------------------------------------------------------------
+if (guide_modele) then
+    do i=1,iip1
+        do j=1,jjp1
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+            enddo
+        enddo
+    enddo
+else
+    do i=1,iip1
+        do j=1,jjp1
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)
+                plnc1(i,j,l)=apnc(l)
+           enddo
+        enddo
+    enddo
+
+endif
+    if (first) then
+        first=.FALSE.
+        print*,'Guide: verification ordre niveaux verticaux'
+        print*,'LMDZ :'
+        do l=1,llm
+            print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jjp1)*(bp(l)+bp(l+1))/2.
+        enddo
+        print*,'Fichiers guidage'
+        do l=1,nlevnc
+             print*,'PL(',l,')=',plnc2(1,1,l)
+        enddo
+        print *,'inversion de l''ordre: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+                print*,'U(',l,')=',unat2(1,1,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+                print*,'T(',l,')=',tnat2(1,1,l)
+            enddo
+        endif
+    endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+    CALL pression( ip1jmp1, ap, bp, psi, p )
+    if (pressure_exner) then
+      CALL exner_hyb(ip1jmp1,psi,p,pks,pk)
+    else
+      CALL exner_milieu(ip1jmp1,psi,p,pks,pk)
+    endif
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    unskap=1./kappa
+    prefkap =  preff  ** kappa
+    DO l = 1, llm
+        DO j=1,jjp1
+            DO i =1, iip1
+                pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+            ENDDO
+        ENDDO
+    ENDDO
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=1,jjp1
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+    call massbar(pext, pbarx, pbary )
+    do l=1,llm
+        do j=1,jjp1
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=1,jjm
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation champs guidage sur niveaux modele (+inversion N/S)
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=1,jjp1
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_u) THEN
+        CALL pres2lev(unat1,zu1,nlevnc,llm,plnc1,plunc,iip1,jjp1,invert_p)
+        CALL pres2lev(unat2,zu2,nlevnc,llm,plnc2,plunc,iip1,jjp1,invert_p)
+        do l=1,llm
+            do j=1,jjp1
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                ugui1(i,l)=0.
+                ugui1(ip1jm+i,l)=0.
+                ugui2(i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_T) THEN
+        CALL pres2lev(tnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p)
+        CALL pres2lev(tnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p)
+        do l=1,llm
+            do j=1,jjp1
+                IF (guide_teta) THEN
+		    do i=1,iim
+			ij=(j-1)*iip1+i
+			tgui1(ij,l)=zu1(i,j,l)
+			tgui2(ij,l)=zu2(i,j,l)
+		    enddo
+                ELSE
+		    do i=1,iim
+			ij=(j-1)*iip1+i
+			tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+			tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+		    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(i,l)=tgui2(1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+            enddo
+        enddo
+    ENDIF
+
+    IF (guide_v) THEN
+
+        CALL pres2lev(vnat1,zv1,nlevnc,llm,plnc1(:,:jjm,:),plvnc,iip1,jjm,invert_p)
+        CALL pres2lev(vnat2,zv2,nlevnc,llm,plnc2(:,:jjm,:),plvnc,iip1,jjm,invert_p)
+
+        do l=1,llm
+            do j=1,jjm
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_Q) THEN
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        CALL pres2lev(qnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p)
+        CALL pres2lev(qnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p)
+        do l=1,llm
+            do j=1,jjp1
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(i,l)=qgui2(1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+            enddo
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjp1*llm,teta*pk/cpp,plsnc,qsat)
+            qgui1=qgui1*qsat*0.01 !hum. rel. en %
+            qgui2=qgui2*qsat*0.01 
+        ENDIF
+    ENDIF
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom2.h"
+    include "serre.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                 print*,'ATTENTION modele peu zoome'
+                 print*,'ATTENTION on prend une constante de guidage cste'
+                 gamma=0.
+            else
+                gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+                print*,'gamma=',gamma
+                if (gamma.lt.1.e-5) then
+                  print*,'gamma =',gamma,'<1e-5'
+                  stop
+                endif
+                gamma=log(0.5)/log(gamma)
+                if (gamma4) then 
+                  gamma=min(gamma,4.)
+                endif
+                print*,'gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidQ
+    INTEGER, SAVE         :: varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read'
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Niveaux de pression si non constants
+         if (guide_modele) then
+             print *,'Lecture du guidage sur niveaux modele'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable BP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable UWND, fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable VWND, fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AIR, fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable RH, fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable SP, fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (.not.guide_modele) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_modele) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         else
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+         
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidQ
+    INTEGER, SAVE         :: varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjp1,llm) :: zu
+    REAL, DIMENSION (jjm,llm)  :: zv
+    INTEGER               :: i
+
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read2D'
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Niveaux de pression si non constants
+         if (guide_modele) then
+             print *,'Lecture du guidage sur niveaux modele'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable BP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable UWND, fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable VWND, fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AIR, fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable RH, fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable SP, fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (.not.guide_modele) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_modele) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         else
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
+#endif
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
+#endif
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
+#endif
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
+#endif
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
+#endif
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    
+    ! Variables entree
+    CHARACTER*(*), INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER       :: vid_au,vid_av
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid,l
+    REAL, DIMENSION (iip1,hsize,vsize) :: field2
+
+    print *,'Guide: output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_au,alpha_u)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_av,alpha_v)
+#else
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
+        ierr = NF_PUT_VAR_REAL(nid,vid_au,alpha_u)
+        ierr = NF_PUT_VAR_REAL(nid,vid_av,alpha_v)
+#endif
+! --------------------------------------------------------------------
+! CrÃ¯Â¿Âœation des variables sauvegardÃ¯Â¿Âœes
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Surface pressure (GCM)
+        dim3=(/id_lonv,id_latu,id_tim/)
+        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    IF (varname=="SP") timestep=timestep+1
+
+    ierr = NF_INQ_VARID(nid,varname,varid)
+    SELECT CASE (varname)
+    CASE ("SP","ps")
+        start=(/1,1,timestep,0/)
+        count=(/iip1,jjp1,1,0/)
+    CASE ("v","va","vcov")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+    CASE DEFAULT
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    END SELECT
+
+    SELECT CASE (varname)
+    CASE("u","ua")
+        DO l=1,llm ; field2(:,2:jjm,l)=field(:,2:jjm,l)/cu(:,2:jjm) ; ENDDO
+        field2(:,1,:)=0. ; field2(:,jjp1,:)=0.
+    CASE("v","va")
+        DO l=1,llm ; field2(:,:,l)=field(:,:,l)/cv(:,:) ; ENDDO
+    CASE DEFAULT
+        field2=field
+    END SELECT
+
+
+#ifdef NC_DOUBLE
+    ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field2)
+#else
+    ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field2)
+#endif
+
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_mod
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/ini_paramLMDZ_dyn.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/ini_paramLMDZ_dyn.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/ini_paramLMDZ_dyn.h	(revision 222)
@@ -0,0 +1,214 @@
+c
+      dt_cum = dtvr*day_step
+
+!      zan = annee_ref
+!      dayref = day_ref
+!      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+c
+       pi = 4.0 * ATAN(1.0)
+       degres = 180./pi
+       rlong = rlonu * degres
+       rlatg = rlatu * degres
+c
+      CALL histbeg("paramLMDZ_dyn.nc", 
+     .                 iip1,rlong, jjp1,rlatg,
+     .                 1,1,1,1,
+     .                 tau0, jD_ref+jH_ref , dt_cum,
+     .                 thoriid, nid_ctesGCM)
+c
+         CALL histdef(nid_ctesGCM, "prt_level", 
+     .        "Niveau impression debuggage dynamique",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dayref", 
+     .        "Jour de l etat initial ( = 350  si 20 Decembre par ex.)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "anneeref", 
+     .        "Annee de l etat initial",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "anneelim", 
+     .        "Annee du fichier limitxxxx.nc  si  ok_limitvrai =y",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "raz_date", 
+     .   "Remise a zero (raz) date init.: 0 pas de raz;1=date gcm.def",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "nday", 
+     .   "Nombre de jours d integration",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "day_step", 
+     .   "nombre de pas par jour pour dt = 1 min",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iperiod", 
+     .   "periode pour le pas Matsuno (en pas de temps)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iapp_tracvl", 
+     .   "frequence du groupement des flux (en pas de temps)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iconser", 
+     .  "periode de sortie des variables de controle (en pas de temps)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iecri", 
+     .  "periode d ecriture du fichier histoire (en jour)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "periodav", 
+     .  "periode de stockage fichier histmoy (en jour)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dissip_period", 
+     .  "periode de la dissipation (en pas) ... a completer",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "lstardis", 
+     .  "choix de l operateur de dissipation: 1= star,0=non-star ??",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "nitergdiv", 
+     .  "nombre d iterations de l operateur de dissipation gradiv",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "nitergrot", 
+     .  "nombre d iterations de l operateur de dissipation nxgradrot",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "niterh", 
+     .  "nombre d iterations de l operateur de dissipation divgrad",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tetagdiv", 
+     ."temps dissipation des + petites long. d ondes pour u,v (gradiv)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tetagrot", 
+     ."temps diss. des + petites long. d ondes pour u,v (nxgradrot)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tetatemp", 
+     ."temps diss. des + petites long. d ondes pour h (divgrad)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "coefdis", 
+     ."coefficient pour gamdissip",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "purmats", 
+     ."Choix schema integration temporel: 1=Matsuno,0=Matsuno-leapfrog",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "ok_guide", 
+     ."Guidage: 1=true ,0=false",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "true_calendar", 
+     ."Choix du calendrier",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "guide_calend", 
+     ."Guidage calendrier gregorien: 1=oui ,0=non",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iflag_phys", 
+     ."Permet de faire tourner le modele sans physique: 1=avec ,0=sans",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iphysiq", 
+     ."Periode de la physique en pas de temps de la dynamique",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "clon", 
+     ."longitude en degres du centre du zoom",
+     .                "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "clat", 
+     ."latitude en degres du centre du zoom",
+     .                "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "grossismx", 
+     ."facteur de grossissement du zoom, selon la longitude",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "grossismy", 
+     ."facteur de grossissement du zoom, selon la latitude",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "fxyhypb", 
+     ."Fonction f(y) hyperbolique  si true=1, sinusoidale si false=0",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dzoomx", 
+     ."extension en longitude de la zone du zoom (fraction zone totale)"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dzoomy", 
+     ."extension en latitude de la zone du zoom (fraction zone totale)"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "taux", 
+     ."raideur du zoom en  X"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tauy", 
+     ."raideur du zoom en  Y"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "ysinus", 
+     ."ysinus=1: Ftion f(y) avec y=Sin(latit.)/ ysinus=0: y = latit"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "ip_ebil_dyn", 
+     ."PRINTlevel for energy conservation diag.; 0/1= pas de print,
+     . 2= print","-",iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", dt_cum,dt_cum)
+c
+c=================================================================
+c
+         CALL histend(nid_ctesGCM)
+c
+c=================================================================
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/iniinterp_horiz.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/iniinterp_horiz.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/iniinterp_horiz.F	(revision 222)
@@ -0,0 +1,179 @@
+C 
+C $Header$
+C
+      subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &       ktotal,iik,jjk,jk,ik,intersec,airen)
+   
+      implicit none
+
+
+
+c ---------------------------------------------------------
+c Prepare l' interpolation des variables d'une grille LMDZ
+c  dans une autre grille LMDZ en conservant la quantite
+c  totale pour les variables intensives (/m2) : ex : Pression au sol
+c
+c   (Pour chaque case autour d'un point scalaire de la nouvelle
+c    grille, on calcule la surface (en m2)en intersection avec chaque
+c    case de l'ancienne grille , pour la future interpolation)
+c
+c on calcule aussi l' aire dans la nouvelle grille 
+c
+c
+c   Auteur:  F.Forget 01/1995
+c   -------
+c
+c ---------------------------------------------------------
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+c INPUT
+       integer imo, jmo ! dimensions ancienne grille
+       integer imn,jmn  ! dimensions nouvelle grille
+       integer kllm ! taille du tableau des intersections
+       real rlonuo(imo+1)     !  Latitude et
+       real rlatvo(jmo)       !  longitude des
+       real rlonun(imn+1)     !  bord des
+       real rlatvn(jmn)     !  cases "scalaires" (input)
+
+c OUTPUT
+       integer ktotal ! nombre totale d'intersections reperees
+       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
+       real intersec(kllm)  ! surface des intersections (m2)
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+
+
+       
+ 
+c Autres variables
+c """"""""""""""""
+       integer i,j,ii,jj,k
+       real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1)
+       real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1)
+       real aa, bb,cc,dd
+       real pi
+
+       pi      = 2.*ASIN( 1. )
+
+
+
+c On repere les frontieres des cases :
+c =================================== 
+c
+c Attention, on ruse avec des latitudes = 90 deg au pole.
+
+
+c  ANcienne grile
+c  """"""""""""""
+      a(1) =   - rlonuo(imo+1)
+      b(1) = rlonuo(1)
+      do i=2,imo+1
+         a(i) = rlonuo(i-1)
+         b(i) =  rlonuo(i)
+      end do
+
+      d(1) = pi/2 
+      do j=1,jmo
+         c(j) = rlatvo(j) 
+         d(j+1) = rlatvo(j)
+      end do
+      c(jmo+1) = -pi/2 
+      
+
+c  Nouvelle grille
+c  """""""""""""""
+      an(1) =  - rlonun(imn+1)
+      bn(1) = rlonun(1)
+      do i=2,imn+1
+         an(i) = rlonun(i-1)
+         bn(i) =  rlonun(i)
+      end do
+
+      dn(1) = pi/2 
+      do j=1,jmn
+         cn(j) = rlatvn(j)
+         dn(j+1) = rlatvn(j)
+      end do
+      cn(jmn+1) = -pi/2 
+
+c Calcul de la surface des cases scalaires de la nouvelle grille
+c ==============================================================
+      do ii=1,imn + 1
+        do jj = 1,jmn+1
+               airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj)))
+        end do
+      end do
+
+c Calcul de la surface des intersections
+c ======================================
+
+c     boucle sur la nouvelle grille
+c     """"""""""""""""""""""""""""
+      ktotal = 0
+      do jj = 1,jmn+1
+       do j=1, jmo+1
+          if((cn(jj).lt.d(j)).and.(dn(jj).gt.c(j)))then
+              do ii=1,imn + 1
+                do i=1, imo +1
+                    if (  ((an(ii).lt.b(i)).and.(bn(ii).gt.a(i)))
+     &        .or. ((an(ii).lt.b(i)-2*pi).and.(bn(ii).gt.a(i)-2*pi)
+     &             .and.(b(i)-2*pi.lt.-pi) )
+     &        .or. ((an(ii).lt.b(i)+2*pi).and.(bn(ii).gt.a(i)+2*pi)
+     &             .and.(a(i)+2*pi.gt.pi) )
+     &                     )then
+                      ktotal = ktotal +1
+                      iik(ktotal) =ii
+                      jjk(ktotal) =jj
+                      ik(ktotal) =i
+                      jk(ktotal) =j
+
+                      dd = min(d(j), dn(jj))
+                      cc = cn(jj)
+                      if (cc.lt. c(j))cc=c(j)
+                      if((an(ii).lt.b(i)-2*pi).and.
+     &                  (bn(ii).gt.a(i)-2*pi)) then 
+                          bb = min(b(i)-2*pi,bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)-2*pi) aa=a(i)-2*pi
+                      else if((an(ii).lt.b(i)+2*pi).and.
+     &                       (bn(ii).gt.a(i)+2*pi)) then
+                          bb = min(b(i)+2*pi,bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)+2*pi) aa=a(i)+2*pi
+                      else 
+                          bb = min(b(i),bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)) aa=a(i)
+                      end if
+                      intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc))
+                     end if
+                end do
+               end do
+             end if
+         end do
+       end do       
+
+
+
+c     TEST  INFO
+c     DO k=1,ktotal 
+c      ii = iik(k) 
+c      jj = jjk(k)
+c      i = ik(k)
+c      j = jk(k)
+c      if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then
+c      if (jj.eq.2.and.(ii.eq.1))then
+c          write(*,*) '**************** jj=',jj,'ii=',ii
+c          write(*,*) 'i,j =',i,j
+c          write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj)
+c          write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j)
+c          write(*,*) 'intersec(k)',intersec(k)
+c          write(*,*) 'airen(ii,jj)=',airen(ii,jj)
+c      end if
+c     END DO 
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/integrd.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/integrd.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/integrd.F	(revision 222)
@@ -0,0 +1,258 @@
+!
+! $Id: integrd.F 1616 2012-02-17 11:59:00Z emillour $
+!
+      SUBROUTINE integrd
+     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
+     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis !,finvmaold
+     &  )
+
+      use control_mod, only : planet_type
+
+      IMPLICIT NONE
+
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Incrementation des tendances dynamiques
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "logic.h"
+#include "temps.h"
+#include "serre.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+
+      integer,intent(in) :: nq ! number of tracers to handle in this routine
+      real,intent(inout) :: vcov(ip1jm,llm) ! covariant meridional wind
+      real,intent(inout) :: ucov(ip1jmp1,llm) ! covariant zonal wind
+      real,intent(inout) :: teta(ip1jmp1,llm) ! potential temperature
+      real,intent(inout) :: q(ip1jmp1,llm,nq) ! advected tracers
+      real,intent(inout) :: ps(ip1jmp1) ! surface pressure
+      real,intent(inout) :: masse(ip1jmp1,llm) ! atmospheric mass
+      real,intent(in) :: phis(ip1jmp1) ! ground geopotential !!! unused
+      ! values at previous time step
+      real,intent(inout) :: vcovm1(ip1jm,llm)
+      real,intent(inout) :: ucovm1(ip1jmp1,llm)
+      real,intent(inout) :: tetam1(ip1jmp1,llm)
+      real,intent(inout) :: psm1(ip1jmp1)
+      real,intent(inout) :: massem1(ip1jmp1,llm)
+      ! the tendencies to add
+      real,intent(in) :: dv(ip1jm,llm)
+      real,intent(in) :: du(ip1jmp1,llm)
+      real,intent(in) :: dteta(ip1jmp1,llm)
+      real,intent(in) :: dp(ip1jmp1)
+      real,intent(in) :: dq(ip1jmp1,llm,nq) !!! unused
+!      real,intent(out) :: finvmaold(ip1jmp1,llm) !!! unused
+
+c   Local:
+c   ------
+
+      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
+      REAL massescr( ip1jmp1,llm )
+!      REAL finvmasse(ip1jmp1,llm)
+      REAL p(ip1jmp1,llmp1)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+      REAL deltap( ip1jmp1,llm )
+
+      INTEGER  l,ij,iq,i,j
+
+      REAL SSUM
+
+c-----------------------------------------------------------------------
+
+      DO  l = 1,llm
+        DO  ij = 1,iip1
+         ucov(    ij    , l) = 0.
+         ucov( ij +ip1jm, l) = 0.
+         uscr(     ij      ) = 0.
+         uscr( ij +ip1jm   ) = 0.
+        ENDDO
+      ENDDO
+
+
+c    ............    integration  de       ps         ..............
+
+      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+
+      DO ij = 1,ip1jmp1
+       pscr (ij)    = ps(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)
+      ENDDO
+c
+      DO ij = 1,ip1jmp1
+        IF( ps(ij).LT.0. ) THEN
+         write(lunout,*) "integrd: negative surface pressure ",ps(ij)
+         write(lunout,*) " at node ij =", ij
+         ! since ij=j+(i-1)*jjp1 , we have
+         j=modulo(ij,jjp1)
+         i=1+(ij-j)/jjp1
+         write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
+     &                   " lat = ",rlatu(j)*180./pi, " deg"
+         write(lunout,*) " psm1(ij)=",psm1(ij)," dt=",dt,
+     &                   " dp(ij)=",dp(ij)
+         stop
+        ENDIF
+      ENDDO
+c
+      DO  ij    = 1, iim
+       tppn(ij) = aire(   ij   ) * ps(  ij    )
+       tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+      ENDDO
+       tpn      = SSUM(iim,tppn,1)/apoln
+       tps      = SSUM(iim,tpps,1)/apols
+      DO ij   = 1, iip1
+       ps(   ij   )  = tpn
+       ps(ij+ip1jm)  = tps
+      ENDDO
+c
+c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+c
+      CALL pression ( ip1jmp1, ap, bp, ps, p )
+      CALL massdair (     p  , masse         )
+
+! Ehouarn : we don't use/need finvmaold and finvmasse,
+!           so might as well not compute them
+!      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+!      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
+c
+
+c    ............   integration  de  ucov, vcov,  h     ..............
+
+      DO l = 1,llm
+
+       DO ij = iip2,ip1jm
+        uscr( ij )   =  ucov( ij,l )
+        ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+       ENDDO
+
+       DO ij = 1,ip1jm
+        vscr( ij )   =  vcov( ij,l )
+        vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+       ENDDO
+
+       DO ij = 1,ip1jmp1
+        hscr( ij )    =  teta(ij,l)
+        teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) 
+     &                + dt * dteta(ij,l) / masse(ij,l)
+       ENDDO
+
+c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
+       DO  ij   = 1, iim
+        tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+        tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+       ENDDO
+        tpn      = SSUM(iim,tppn,1)/apoln
+        tps      = SSUM(iim,tpps,1)/apols
+
+       DO ij   = 1, iip1
+        teta(   ij   ,l)  = tpn
+        teta(ij+ip1jm,l)  = tps
+       ENDDO
+c
+
+       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 )
+       END IF
+
+      ENDDO ! of DO l = 1,llm
+
+
+c
+c   .......  integration de   q   ......
+c
+c$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
+c$$$c
+c$$$       IF( forward. OR . leapf )  THEN
+c$$$        DO iq = 1,2
+c$$$        DO  l = 1,llm
+c$$$        DO ij = 1,ip1jmp1
+c$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
+c$$$     $                            finvmasse(ij,l)
+c$$$        ENDDO
+c$$$        ENDDO
+c$$$        ENDDO
+c$$$       ELSE
+c$$$         DO iq = 1,2
+c$$$         DO  l = 1,llm
+c$$$         DO ij = 1,ip1jmp1
+c$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
+c$$$         ENDDO
+c$$$         ENDDO
+c$$$         ENDDO
+c$$$
+c$$$       END IF
+c$$$c
+c$$$      ENDIF
+
+      if (planet_type.eq."earth") then
+! Earth-specific treatment of first 2 tracers (water)
+        DO l = 1, llm
+          DO ij = 1, ip1jmp1
+            deltap(ij,l) =  p(ij,l) - p(ij,l+1) 
+          ENDDO
+        ENDDO
+
+        CALL qminimum( q, nq, deltap )
+
+c
+c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+c
+
+       DO iq = 1, nq
+        DO l = 1, llm
+
+           DO ij = 1, iim
+             qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+             qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+           ENDDO
+             qpn  =  SSUM(iim,qppn,1)/apoln
+             qps  =  SSUM(iim,qpps,1)/apols
+
+           DO ij = 1, iip1
+             q(   ij   ,l,iq)  = qpn
+             q(ij+ip1jm,l,iq)  = qps
+           ENDDO
+
+        ENDDO
+       ENDDO
+
+! Ehouarn: forget about finvmaold
+!      CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+
+      endif ! of if (planet_type.eq."earth")
+c
+c
+c     .....   FIN  de l'integration  de   q    .......
+
+c    .................................................................
+
+
+      IF( leapf )  THEN
+         CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+         CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+      END IF
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/interp_horiz.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/interp_horiz.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/interp_horiz.F	(revision 222)
@@ -0,0 +1,154 @@
+c
+c $Id: interp_horiz.F 1403 2010-07-01 09:02:53Z fairhead $
+c
+      subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm,
+     &  rlonuo,rlatvo,rlonun,rlatvn)  
+
+c===========================================================
+c  Interpolation Horizontales des variables d'une grille LMDZ
+c (des points SCALAIRES au point SCALAIRES)
+c  dans une autre grille LMDZ en conservant la quantite
+c  totale pour les variables intensives (/m2) : ex : Pression au sol
+c
+c Francois Forget (01/1995)
+c===========================================================
+
+      IMPLICIT NONE 
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+        
+       integer imo, jmo ! dimensions ancienne grille (input)
+       integer imn,jmn  ! dimensions nouvelle grille (input)
+
+       real rlonuo(imo+1)     !  Latitude et
+       real rlatvo(jmo)       !  longitude des
+       real rlonun(imn+1)     !  bord des 
+       real rlatvn(jmn)     !  cases "scalaires" (input)
+
+       integer lm ! dimension verticale (input)
+       real varo (imo+1, jmo+1,lm) ! var dans l'ancienne grille (input)
+       real varn (imn+1,jmn+1,lm) ! var dans la nouvelle grille (output)
+
+c Autres variables
+c """"""""""""""""
+       real airetest(imn+1,jmn+1)
+       integer ii,jj,l
+
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+c    Info sur les ktotal intersection entre les cases new/old grille
+       integer kllm, k, ktotal
+       parameter (kllm = 400*200*10)
+       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
+       real intersec(kllm)
+       real R
+       real totn, tots
+
+       logical firstcall, firsttest, aire_ok
+       save firsttest
+       data firsttest /.true./
+       data aire_ok /.true./
+
+       
+
+
+
+c initialisation
+c --------------
+c Si c'est le premier appel, on prepare l'interpolation
+c en calculant pour chaque case autour d'un point scalaire de la
+c nouvelle grille, la surface  de intersection avec chaque
+c    case de l'ancienne grille.
+
+
+        call iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &          ktotal,iik,jjk,jk,ik,intersec,airen)
+
+      do l=1,lm
+       do jj =1 , jmn+1
+        do ii=1, imn+1
+          varn(ii,jj,l) =0.
+        end do
+       end do
+      end do 
+       
+c Interpolation horizontale
+c -------------------------
+c boucle sur toute les ktotal intersections entre les cases
+c de l'ancienne et la  nouvelle grille
+c
+      PRINT *, 'ktotal 1 = ', ktotal
+     
+      do k=1,ktotal
+        do l=1,lm
+         varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l) 
+     &        + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k))
+        end do
+      end do
+
+c Une seule valeur au pole pour les variables ! :
+c -----------------------------------------------
+       do l=1, lm
+         totn =0.
+         tots =0.
+           do ii =1, imn+1
+             totn = totn + varn(ii,1,l)
+             tots = tots + varn (ii,jmn+1,l)
+           end do 
+           do ii =1, imn+1
+             varn(ii,1,l) = totn/REAL(imn+1)
+             varn(ii,jmn+1,l) = tots/REAL(imn+1)
+           end do 
+       end do
+           
+
+c---------------------------------------------------------------
+c  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST 
+!!       if (.not.(firsttest)) goto 99
+!!       firsttest = .false.
+!! !     write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:'
+!!       do jj =1 , jmn+1
+!!         do ii=1, imn+1
+!!           airetest(ii,jj) =0.
+!!         end do
+!!       end do 
+!!       PRINT *, 'ktotal = ', ktotal
+!!       PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1
+!! 
+!!       do k=1,ktotal
+!!          airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k) 
+!!       end DO
+!! 
+!! 
+!!       PRINT *, 'fin boucle'
+!!       do jj =1 , jmn+1
+!!        do ii=1, imn+1
+!!          r = airen(ii,jj)/airetest(ii,jj)
+!!          if ((r.gt.1.001).or.(r.lt.0.999)) then
+!! !             write (*,*) '********** PROBLEME D'' AIRES !!!',
+!! !     &                   ' DANS L''INTERPOLATION HORIZONTALE'
+!! !             write(*,*)'ii,jj,airen,airetest',
+!! !     &          ii,jj,airen(ii,jj),airetest(ii,jj)
+!!              aire_ok = .false.
+!!          end if
+!!        end do
+!!       end do
+!! !      if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK'
+!!  99   continue
+
+c FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST
+c---------------------------------------------------------------
+
+
+
+
+
+
+
+
+        return
+        end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/leapfrog.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/leapfrog.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/leapfrog.F	(revision 222)
@@ -0,0 +1,952 @@
+!
+! $Id: leapfrog.F 1446 2010-10-22 09:27:25Z emillour $
+!
+c
+c
+      SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,q,
+     &                    time_0)
+
+
+cIM : pour sortir les param. du modele dans un fis. netcdf 110106
+#ifdef CPP_IOIPSL
+      use IOIPSL
+#endif
+      USE infotrac, ONLY: nqtot
+      USE guide_mod, ONLY : guide_main
+      USE write_field, ONLY: writefield
+      USE control_mod, ONLY: planet_type,nday,day_step,iperiod,iphysiq,
+     &                       less1day,fractday,ndynstep,iconser,
+     &                       dissip_period,offline,ip_ebil_dyn,
+     &                       ok_dynzon,periodav,ok_dyn_ave,iecri,
+     &                       ok_dyn_ins,output_grads_dyn
+      use exner_hyb_m, only: exner_hyb
+      use exner_milieu_m, only: exner_milieu
+      use cpdet_mod, only: cpdet,tpot2t,t2tpot
+      use sponge_mod, only: callsponge,mode_sponge,sponge
+       use comuforc_h
+
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+c  ... Possibilite de choisir le shema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10 
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+!#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "academic.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! #include "clesphys.h"
+
+      REAL,INTENT(IN) :: time_0 ! not used
+
+c   dynamical variables:
+      REAL,INTENT(INOUT) :: ucov(ip1jmp1,llm)    ! zonal covariant wind
+      REAL,INTENT(INOUT) :: vcov(ip1jm,llm)      ! meridional covariant wind
+      REAL,INTENT(INOUT) :: teta(ip1jmp1,llm)    ! potential temperature
+      REAL,INTENT(INOUT) :: ps(ip1jmp1)          ! surface pressure (Pa)
+      REAL,INTENT(INOUT) :: masse(ip1jmp1,llm)   ! air mass
+      REAL,INTENT(INOUT) :: phis(ip1jmp1)        ! geopotentiat at the surface
+      REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers
+
+      REAL p (ip1jmp1,llmp1  )               ! interlayer pressure
+      REAL pks(ip1jmp1)                      ! exner at the surface
+      REAL pk(ip1jmp1,llm)                   ! exner at mid-layer
+      REAL pkf(ip1jmp1,llm)                  ! filtered exner at mid-layer
+      REAL phi(ip1jmp1,llm)                  ! geopotential
+      REAL w(ip1jmp1,llm)                    ! vertical velocity
+! ADAPTATION GCM POUR CP(T)
+      REAL temp(ip1jmp1,llm)                 ! temperature  
+      REAL tsurpk(ip1jmp1,llm)               ! cpp*T/pk  
+
+      real zqmin,zqmax
+
+c variables dynamiques intermediaire pour le transport
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
+
+c   variables dynamiques au pas -1
+      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1)
+      REAL massem1(ip1jmp1,llm)
+
+c   tendances dynamiques en */s
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqtot),dp(ip1jmp1)
+
+c   tendances de la dissipation en */s
+      REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
+      REAL dtetadis(ip1jmp1,llm)
+
+c   tendances de la couche superieure */s
+c      REAL dvtop(ip1jm,llm)
+      REAL dutop(ip1jmp1,llm)
+c      REAL dtetatop(ip1jmp1,llm)
+c      REAL dqtop(ip1jmp1,llm,nqtot),dptop(ip1jmp1)
+
+c   TITAN : tendances due au forces de marees */s
+      REAL dvtidal(ip1jm,llm),dutidal(ip1jmp1,llm)
+
+c   tendances physiques */s
+      REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
+      REAL dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqtot),dpfi(ip1jmp1)
+
+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 finvmaold(ip1jmp1,llm)
+
+cym      LOGICAL  lafin
+      LOGICAL :: lafin=.false.
+      INTEGER ij,iq,l
+      INTEGER ik
+
+      real time_step, t_wrt, t_ops
+
+      REAL rdaym_ini
+! jD_cur: jour julien courant
+! jH_cur: heure julienne courante
+      REAL :: jD_cur, jH_cur
+      INTEGER :: an, mois, jour
+      REAL :: secondes
+
+      LOGICAL first,callinigrads
+cIM : pour sortir les param. du modele dans un fis. netcdf 110106
+      save first
+      data first/.true./
+      real dt_cum
+      character*10 infile
+      integer zan, tau0, thoriid
+      integer nid_ctesGCM
+      save nid_ctesGCM
+      real degres
+      real rlong(iip1), rlatg(jjp1)
+      real zx_tmp_2d(iip1,jjp1)
+      integer ndex2d(iip1*jjp1)
+      logical ok_sync
+      parameter (ok_sync = .true.) 
+      logical physic
+
+      data callinigrads/.true./
+      character*10 string10
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+      REAL :: flxw(ip1jmp1,llm)  ! flux de masse verticale
+
+c+jld variables test conservation energie
+      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+      REAL dtetaecdt(ip1jmp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
+      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+      CHARACTER*15 ztit
+!IM   INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+!IM   SAVE      ip_ebil_dyn
+!IM   DATA      ip_ebil_dyn/0/
+c-jld 
+
+      integer :: itau_w ! for write_paramLMDZ_dyn.h
+
+      character*80 dynhist_file, dynhistave_file
+      character(len=*),parameter :: modname="leapfrog"
+      character*80 abort_message
+
+      logical dissip_conservative
+      save dissip_conservative
+      data dissip_conservative/.true./
+
+      INTEGER testita
+      PARAMETER (testita = 9)
+
+      logical , parameter :: flag_verif = .false.
+      
+      ! for CP(T)
+      real :: dtec
+      real :: ztetaec(ip1jmp1,llm)
+
+c dummy: sinon cette routine n'est jamais compilee...
+      if(1.eq.0) then
+#ifdef CPP_PHYS
+        CALL init_phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+#endif
+      endif
+
+      if (nday>=0) then
+         itaufin   = nday*day_step
+      else
+         ! to run a given (-nday) number of dynamical steps
+         itaufin   = -nday
+      endif
+      if (less1day) then
+c MODIF VENUS: to run less than one day:
+        itaufin   = int(fractday*day_step)
+      endif
+      if (ndynstep.gt.0) then
+        ! running a given number of dynamical steps
+        itaufin=ndynstep
+      endif
+      itaufinp1 = itaufin +1
+      
+c INITIALISATIONS
+        dudis(:,:)   =0.
+        dvdis(:,:)   =0.
+        dtetadis(:,:)=0.
+        dutop(:,:)   =0.
+c        dvtop(:,:)   =0.
+c        dtetatop(:,:)=0.
+c        dqtop(:,:,:) =0.
+c        dptop(:)     =0.
+        dufi(:,:)   =0.
+        dvfi(:,:)   =0.
+        dtetafi(:,:)=0.
+        dqfi(:,:,:) =0.
+        dpfi(:)     =0.
+
+      itau = 0
+      physic=.true.
+      if (iflag_phys==0.or.iflag_phys==2) physic=.false.
+
+c      iday = day_ini+itau/day_step
+c      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+c         IF(time.GT.1.) THEN
+c          time = time-1.
+c          iday = iday+1
+c         ENDIF
+
+
+c-----------------------------------------------------------------------
+c   On initialise la pression et la fonction d'Exner :
+c   --------------------------------------------------
+
+      dq(:,:,:)=0.
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      if (pressure_exner) then
+        CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
+      else
+        CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
+      endif
+
+c------------------
+c TEST PK MONOTONE
+c------------------
+      write(*,*) "Test PK"
+      do ij=1,ip1jmp1
+        do l=2,llm
+          if(pk(ij,l).gt.pk(ij,l-1)) then
+c           write(*,*) ij,l,pk(ij,l)
+            abort_message = 'PK non strictement decroissante'
+            call abort_gcm(modname,abort_message,1)
+c           write(*,*) "ATTENTION, Test PK deconnecté..."
+          endif
+        enddo
+      enddo
+      write(*,*) "Fin Test PK"
+c     stop
+c------------------
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+
+   1  CONTINUE ! Matsuno Forward step begins here
+
+      jD_cur = jD_ref + day_ini - day_ref +                             &
+     &          itau/day_step 
+      jH_cur = jH_ref + start_time +                                    &
+     &          mod(itau,day_step)/float(day_step) 
+      jD_cur = jD_cur + int(jH_cur)
+      jH_cur = jH_cur - int(jH_cur)
+
+
+#ifdef CPP_IOIPSL
+      IF (planet_type.eq."earth") THEN
+      if (ok_guide) then
+        call guide_main(itau,ucov,vcov,teta,q,masse,ps)
+      endif
+      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
+
+! Save fields obtained at previous time step as '...m1'
+      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+
+c   ...    P.Le Van .26/04/94  ....
+! Ehouarn: finvmaold is actually not used
+!      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+!      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+   2  CONTINUE ! Matsuno backward or leapfrog step begins here
+
+c-----------------------------------------------------------------------
+
+c   date:
+c   -----
+
+
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+
+      IF( purmats ) THEN
+      ! 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
+
+#ifdef NODYN
+      apdiss=.false.
+#endif
+
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+
+! ADAPTATION GCM POUR CP(T)
+      call tpot2t(ijp1llm,teta,temp,pk)
+      tsurpk = cpp*temp/pk
+      ! compute geopotential phi()
+      CALL geopot  ( ip1jmp1, tsurpk  , pk , pks,  phis  , phi   )
+
+           rdaym_ini  = itau * dtvr / daysec
+
+      time = jD_cur + jH_cur
+
+#ifdef NODYN
+      WRITE(lunout,*)"NO DYN !!!!!"
+      dv(:,:) = 0.D+0
+      du(:,:) = 0.D+0
+      dteta(:,:) = 0.D+0
+      dq(:,:,:) = 0.D+0
+      dp(:) = 0.D+0
+#else
+      CALL caldyn 
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,tsurpk,phis ,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+
+      ! Simple zonal wind nudging for generic planetary model
+      ! AS 09/2013
+      ! ---------------------------------------------------
+      if (planet_type.eq."generic") then
+       if (ok_guide) then
+         du(:,:) = du(:,:) + ((uforc(:,:)-ucov(:,:)) / facwind)
+       endif
+      endif
+
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+
+      IF( forward. OR . leapf )  THEN
+! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
+         CALL caladvtrac(q,pbaru,pbarv,
+     *        p, masse, dq,  teta,
+     .        flxw, pk)
+         
+         IF (offline) THEN
+Cmaf stokage du flux de masse pour traceurs OFF-LINE
+
+#ifdef CPP_IOIPSL
+           CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     .   dtvr, itau)
+#endif
+
+
+         ENDIF ! of IF (offline)
+c
+      ENDIF ! of IF( forward. OR . leapf )
+
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+
+       CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
+!     $              finvmaold                                    )
+
+       IF ((planet_type.eq."titan").and.(tidal)) then
+c-----------------------------------------------------------------------
+c   Marées gravitationnelles causées par Saturne
+c   B. Charnay (28/10/2010)
+c   ----------------------------------------------------------
+            CALL tidal_forces(rdaym_ini, dutidal, dvtidal)
+            ucov=ucov+dutidal*dt
+            vcov=vcov+dvtidal*dt
+       ENDIF
+
+! NODYN precompiling flag
+#endif
+
+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
+c
+c
+       IF( apphys )  THEN
+c
+c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+c
+
+         CALL pression (  ip1jmp1, ap, bp, ps,  p      )
+         if (pressure_exner) then
+           CALL exner_hyb(  ip1jmp1, ps, p,pks, pk, pkf )
+         else
+           CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
+         endif
+
+! Compute geopotential (physics might need it)
+         CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+           jD_cur = jD_ref + day_ini - day_ref +                        &
+     &          itau/day_step 
+
+           IF ((planet_type .eq."generic").or.
+     &         (planet_type .eq."mars")) THEN
+              ! AS: we make jD_cur to be pday
+              jD_cur = int(day_ini + itau/day_step)
+           ENDIF
+
+           jH_cur = jH_ref + start_time +                               &
+     &          mod(itau,day_step)/float(day_step) 
+           jD_cur = jD_cur + int(jH_cur)
+           jH_cur = jH_cur - int(jH_cur)
+!         write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur
+!         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
+!         write(lunout,*)'current date = ',an, mois, jour, secondes 
+
+c rajout debug
+c       lafin = .true.
+
+
+c   Interface avec les routines de phylmd (phymars ... )
+c   -----------------------------------------------------
+
+c+jld
+
+c  Diagnostique de conservation de l'énergie : initialisation
+         IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil dyn'
+! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)!
+           IF (planet_type.eq."earth") THEN
+            CALL diagedyn(ztit,2,1,1,dtphys
+     &    , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+           ENDIF
+         ENDIF ! of IF (ip_ebil_dyn.ge.1 )
+c-jld
+#ifdef CPP_IOIPSL
+cIM decommenter les 6 lignes suivantes pour sortir quelques parametres dynamiques de LMDZ 
+cIM uncomment next 6 lines to get some parameters for LMDZ dynamics
+c        IF (first) THEN
+c         first=.false.
+c#include "ini_paramLMDZ_dyn.h"
+c        ENDIF
+c
+c#include "write_paramLMDZ_dyn.h"
+c
+#endif
+! #endif of #ifdef CPP_IOIPSL
+
+c          call WriteField('pfi',reshape(p,(/iip1,jmp1,llmp1/)))
+
+         CALL calfis( 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  )
+
+c          call WriteField('dufi',reshape(dufi,(/iip1,jmp1,llm/)))
+c          call WriteField('dvfi',reshape(dvfi,(/iip1,jjm,llm/)))
+c          call WriteField('dtetafi',reshape(dtetafi,(/iip1,jmp1,llm/)))
+
+c      ajout des tendances physiques:
+c      ------------------------------
+          CALL addfi( dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps ,
+     $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+          ! since addfi updates ps(), also update p(), masse() and pk()
+          CALL pression (ip1jmp1,ap,bp,ps,p)
+          CALL massdair(p,masse)
+          if (pressure_exner) then
+            CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
+          else
+            CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
+          endif
+          
+c      Couche superieure :
+c      -------------------
+         IF (iflag_top_bound > 0) THEN
+           CALL top_bound(vcov,ucov,teta,masse,dtphys,dutop)
+           dutop(:,:)=dutop(:,:)/dtphys   ! convert to a tendency in (m/s)/s
+         ENDIF
+
+c  Diagnostique de conservation de l'énergie : difference
+         IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil phys'
+          IF (planet_type.eq."earth") THEN
+           CALL diagedyn(ztit,2,1,1,dtphys
+     &     , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+          ENDIF
+         ENDIF ! of IF (ip_ebil_dyn.ge.1 )
+
+       ENDIF ! of IF( apphys )
+
+      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+!   Academic case : Simple friction and Newtonan relaxation 
+!   -------------------------------------------------------
+        DO l=1,llm   
+          DO ij=1,ip1jmp1
+           teta(ij,l)=teta(ij,l)-dtvr*
+     &      (teta(ij,l)-tetarappel(ij,l))*(knewt_g+knewt_t(l)*clat4(ij))
+          ENDDO
+        ENDDO ! of DO l=1,llm 
+    
+        if (planet_type.eq."giant") then
+          ! add an intrinsic heat flux at the base of the atmosphere
+          teta(:,1)=teta(:,1)+dtvr*aire(:)*ihf/cpp/masse(:,1)
+        endif
+
+        call friction(ucov,vcov,dtvr)
+
+    
+        ! Sponge layer (if any)
+        IF (ok_strato) THEN
+           CALL top_bound(vcov,ucov,teta,masse,dtvr,dutop)
+           dutop(:,:)=dutop(:,:)/dtvr   ! convert to a tendency in (m/s)/s
+        ENDIF ! of IF (ok_strato) 
+      ENDIF ! of IF (iflag_phys.EQ.2)
+
+
+c-jld
+
+        CALL pression ( ip1jmp1, ap, bp, ps, p                  )
+        if (pressure_exner) then
+          CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
+        else
+          CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
+        endif
+        CALL massdair(p,masse)
+
+c-----------------------------------------------------------------------
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+      IF(apdiss) THEN
+
+        ! sponge layer
+        if (callsponge) then
+          CALL sponge(ucov,vcov,teta,ps,dtdiss,mode_sponge)
+        endif
+
+c   calcul de l'energie cinetique avant dissipation
+        call covcont(llm,ucov,vcov,ucont,vcont)
+        call enercin(vcov,ucov,vcont,ucont,ecin0)
+
+c   dissipation
+! ADAPTATION GCM POUR CP(T)
+        call tpot2t(ijp1llm,teta,temp,pk)
+
+        CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+        ucov=ucov+dudis
+        vcov=vcov+dvdis
+        dudis=dudis/dtdiss   ! passage en (m/s)/s
+        dvdis=dvdis/dtdiss   ! passage en (m/s)/s
+
+c------------------------------------------------------------------------
+        if (dissip_conservative) then
+C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+C       lors de la dissipation
+            call covcont(llm,ucov,vcov,ucont,vcont)
+            call enercin(vcov,ucov,vcont,ucont,ecin)
+! ADAPTATION GCM POUR CP(T)
+            do ij=1,ip1jmp1
+              do l=1,llm
+                dtec = (ecin0(ij,l)-ecin(ij,l))/cpdet(temp(ij,l))
+                temp(ij,l) = temp(ij,l) + dtec
+              enddo
+            enddo
+            call t2tpot(ijp1llm,temp,ztetaec,pk)
+            dtetaecdt=ztetaec-teta
+            dtetadis=dtetadis+dtetaecdt
+        endif
+        teta=teta+dtetadis
+        dtetadis=dtetadis/dtdiss   ! passage en K/s
+c------------------------------------------------------------------------
+
+
+c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+c
+
+        DO l  =  1, llm
+          DO ij =  1,iim
+           tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+           tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+          ENDDO
+           tpn  = SSUM(iim,tppn,1)/apoln
+           tps  = SSUM(iim,tpps,1)/apols
+
+          DO ij = 1, iip1
+           teta(  ij    ,l) = tpn
+           teta(ij+ip1jm,l) = tps
+          ENDDO
+        ENDDO
+
+        if (1 == 0) then
+!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
+!!!                     2) should probably not be here anyway
+!!! but are kept for those who would want to revert to previous behaviour
+           DO ij =  1,iim
+             tppn(ij)  = aire(  ij    ) * ps (  ij    )
+             tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+           ENDDO
+             tpn  = SSUM(iim,tppn,1)/apoln
+             tps  = SSUM(iim,tpps,1)/apols
+
+           DO ij = 1, iip1
+             ps(  ij    ) = tpn
+             ps(ij+ip1jm) = tps
+           ENDDO
+        endif ! of if (1 == 0)
+
+      END IF ! of IF(apdiss)
+
+c ajout debug
+c              IF( lafin ) then  
+c                abort_message = 'Simulation finished'
+c                call abort_gcm(modname,abort_message,0)
+c              ENDIF
+        
+c   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+
+c   preparation du pas d'integration suivant  ......
+
+      IF ( .NOT.purmats ) THEN
+c       ........................................................
+c       ..............  schema matsuno + leapfrog  ..............
+c       ........................................................
+
+            IF(forward. OR. leapf) THEN
+              itau= itau + 1
+c              iday= day_ini+itau/day_step
+c              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+c                IF(time.GT.1.) THEN
+c                  time = time-1.
+c                  iday = iday+1
+c                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
+
+              abort_message = 'Simulation finished'
+
+              call abort_gcm(modname,abort_message,0)
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+               
+               IF (ok_dynzon) THEN
+#ifdef CPP_IOIPSL
+c les traceurs ne sont pas sortis, trop lourd. 
+c Peut changer eventuellement si besoin.
+                 CALL bilan_dyn(dtvr*iperiod,dtvr*day_step*periodav,
+     &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,
+     &                 du,dudis,dutop,dufi)
+#endif
+               END IF
+               IF (ok_dyn_ave) THEN
+#ifdef CPP_IOIPSL
+                 CALL writedynav(itau,vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+#endif
+               ENDIF
+
+            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
+
+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
+! ADAPTATION GCM POUR CP(T)
+              call tpot2t(ijp1llm,teta,temp,pk)
+              tsurpk = cpp*temp/pk
+              CALL geopot(ip1jmp1,tsurpk,pk,pks,phis,phi)
+              unat=0.
+              do l=1,llm
+                unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm)
+                vnat(:,l)=vcov(:,l)/cv(:)
+              enddo
+#ifdef CPP_IOIPSL
+              if (ok_dyn_ins) then
+!               write(lunout,*) "leapfrog: call writehist, itau=",itau
+	       CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
+!               call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+!               call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+!              call WriteField('teta',reshape(teta,(/iip1,jmp1,llm/)))
+!               call WriteField('ps',reshape(ps,(/iip1,jmp1/)))
+!               call WriteField('masse',reshape(masse,(/iip1,jmp1,llm/)))
+              endif ! of if (ok_dyn_ins)
+#endif
+! For some Grads outputs of fields
+              if (output_grads_dyn) then
+#include "write_grads_dyn.h"
+              endif
+             endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
+            ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+
+            IF(itau.EQ.itaufin) THEN
+
+              if (planet_type=="mars") then
+                CALL dynredem1("restart.nc",REAL(itau)/REAL(day_step),
+     &                         vcov,ucov,teta,q,masse,ps)
+              else
+                CALL dynredem1("restart.nc",start_time,
+     &                         vcov,ucov,teta,q,masse,ps)
+              endif
+              CLOSE(99)
+              !!! Ehouarn: Why not stop here and now?
+            ENDIF ! of IF (itau.EQ.itaufin)
+
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2 
+                   END IF ! of IF (forward)
+            ELSE
+
+c      ......   pas leapfrog  .....
+
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF ! of IF (MOD(itau,iperiod).EQ.0)
+                   !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
+
+      ELSE ! of IF (.not.purmats)
+
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+
+             itau =  itau + 1
+c             iday = day_ini+itau/day_step
+c             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+c
+c                  IF(time.GT.1.) THEN
+c                   time = time-1.
+c                   iday = iday+1
+c                  ENDIF
+
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then  
+                 abort_message = 'Simulation finished'
+                 call abort_gcm(modname,abort_message,0)
+               ENDIF
+               GO TO 2
+
+            ELSE ! of IF(forward) i.e. backward step
+
+              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+
+               IF (ok_dynzon) THEN 
+#ifdef CPP_IOIPSL
+c les traceurs ne sont pas sortis, trop lourd. 
+c Peut changer eventuellement si besoin.
+                 CALL bilan_dyn(dtvr*iperiod,dtvr*day_step*periodav,
+     &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,
+     &                 du,dudis,dutop,dufi)
+#endif
+               ENDIF
+               IF (ok_dyn_ave) THEN
+#ifdef CPP_IOIPSL
+                 CALL writedynav(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              IF(MOD(itau,iecri*day_step).EQ.0) THEN
+! ADAPTATION GCM POUR CP(T)
+                call tpot2t(ijp1llm,teta,temp,pk)
+                tsurpk = cpp*temp/pk
+                CALL geopot(ip1jmp1,tsurpk,pk,pks,phis,phi)
+                unat=0.
+                do l=1,llm
+                  unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm)
+                  vnat(:,l)=vcov(:,l)/cv(:)
+                enddo
+#ifdef CPP_IOIPSL
+              if (ok_dyn_ins) then
+!                write(lunout,*) "leapfrog: call writehist (b)",
+!     &                        itau,iecri
+		CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
+              endif ! of if (ok_dyn_ins)
+#endif
+! For some Grads outputs
+                if (output_grads_dyn) then
+#include "write_grads_dyn.h"
+                endif
+
+              ENDIF ! of IF(MOD(itau,iecri         ).EQ.0) 
+
+              IF(itau.EQ.itaufin) THEN
+                if (planet_type=="mars") then
+                  CALL dynredem1("restart.nc",REAL(itau)/REAL(day_step),
+     &                         vcov,ucov,teta,q,masse,ps)
+                else
+                  CALL dynredem1("restart.nc",start_time,
+     &                         vcov,ucov,teta,q,masse,ps)
+                endif
+              ENDIF ! of IF(itau.EQ.itaufin)
+
+              forward = .TRUE.
+              GO TO  1
+
+            ENDIF ! of IF (forward)
+
+      END IF ! of IF(.not.purmats)
+
+      STOP
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/logic.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/logic.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/logic.h	(revision 222)
@@ -0,0 +1,28 @@
+!
+! $Id: logic.h 1520 2011-05-23 11:37:09Z emillour $
+!
+!
+! NB: keep items of different kinds in seperate common blocs to avoid
+!     "misaligned commons" issues
+!-----------------------------------------------------------------------
+! INCLUDE 'logic.h'
+
+      COMMON/logicl/ purmats,forward,leapf,apphys,                      &
+     &  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus       &
+     &  ,read_start,ok_guide,ok_strato,tidal,ok_gradsfile               &
+     &  ,ok_limit,ok_etat0,hybrid                                       &
+     &  ,moyzon_mu,moyzon_ch
+
+      COMMON/logici/ iflag_phys,iflag_trac
+      
+      LOGICAL purmats,forward,leapf,apphys,statcl,conser,               &
+     & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus                      &
+     &  ,read_start,ok_guide,ok_strato,tidal,ok_gradsfile               &
+     &  ,ok_limit,ok_etat0
+
+      logical hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
+                     ! (only used if disvert_type==2)
+      logical moyzon_mu,moyzon_ch ! used for zonal averages in Titan
+
+      integer iflag_phys,iflag_trac
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/mod_const_mpi.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/mod_const_mpi.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/mod_const_mpi.F90	(revision 222)
@@ -0,0 +1,16 @@
+MODULE mod_const_mpi
+
+  INTEGER :: COMM_LMDZ
+  INTEGER :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+  IMPLICIT NONE
+  
+    COMM_LMDZ=0
+    MPI_REAL_LMDZ=0
+  END SUBROUTINE Init_const_mpi
+
+END MODULE mod_const_mpi
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/moyzon_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/moyzon_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/moyzon_mod.F90	(revision 222)
@@ -0,0 +1,66 @@
+      MODULE moyzon_mod
+! Moyennes zonales pour transmission a la physique 
+!======================================================================
+! Specifique a Titan
+!
+!======================================================================
+! Declaration des variables
+
+      REAL,ALLOCATABLE,SAVE :: zplevbar(:,:),zplaybar(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfibar(:,:),zqfibar(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zphibar(:,:),zphisbar(:)
+      REAL,ALLOCATABLE,SAVE :: zpkbar(:,:),ztetabar(:,:)
+      REAL,ALLOCATABLE,SAVE :: zzlevbar(:,:),zzlaybar(:,:)
+
+! pmoy: global averaged pressure...
+! tmoy: global averaged temperature...
+! put here to be transfered to Titan routines...
+! to be changed...
+      REAL,ALLOCATABLE,SAVE :: plevmoy(:),playmoy(:)
+      REAL,ALLOCATABLE,SAVE :: zlevmoy(:),zlaymoy(:),phimoy(:)
+      REAL,ALLOCATABLE,SAVE :: tmoy(:),tetamoy(:),pkmoy(:)
+      INTEGER,ALLOCATABLE,SAVE :: klat(:)
+
+CONTAINS
+!======================================================================
+SUBROUTINE moyzon_init(klon,llm,nqtot)
+#ifdef CPP_PHYS
+!! This routine needs physics
+IMPLICIT NONE
+       INTEGER :: klon,llm,nqtot
+
+      ALLOCATE(zplevbar(klon,llm+1),zplaybar(klon,llm))
+      ALLOCATE(zphibar(klon,llm),zphisbar(klon))
+      ALLOCATE(ztfibar(klon,llm),zqfibar(klon,llm,nqtot))
+      ALLOCATE(zpkbar(klon,llm),ztetabar(klon,llm))
+      ALLOCATE(zzlevbar(klon,llm+1),zzlaybar(klon,llm))
+#else
+    include "iniprint.h"
+    write(lunout,*) "moyzon_init Error: should only be called with physics"
+    stop
+#endif
+END SUBROUTINE moyzon_init
+
+!======================================================================
+SUBROUTINE moyzon(nlev,var,varbar)
+
+IMPLICIT NONE
+#include "dimensions.h"
+#include "paramet.h"
+
+      INTEGER :: nlev
+      REAL,dimension(iip1,nlev) :: var
+      REAL,dimension(nlev)      :: varbar
+
+      INTEGER :: i
+
+      varbar(:) = 0.
+      do i=1,iim
+        varbar(:)=varbar(:)+var(i,:)/iim
+      enddo
+
+      return
+END SUBROUTINE moyzon
+
+!======================================================================
+      END MODULE moyzon_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/qminimum.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/qminimum.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/qminimum.F	(revision 222)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+      SUBROUTINE qminimum( q,nq,deltap )
+
+      IMPLICIT none
+c
+c  -- Objet : Traiter les valeurs trop petites (meme negatives)
+c             pour l'eau vapeur et l'eau liquide
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+c
+      INTEGER nq
+      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide
+c
+c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+c            parametres seuil_vap, seuil_liq soient pareilles a celles 
+c            qui  sont utilisees dans la routine    ADDFI       )
+c     .................................................................
+c
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+c
+      REAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+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
+      DO 1000 k = 1, llm
+        DO 1040 i = 1, ip1jmp1
+          if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+             q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+             q(i,k,iq_liq) = seuil_liq
+           endif
+ 1040   CONTINUE
+ 1000 CONTINUE
+c
+c Quand l'eau vapeur est trop faible (ou negative), on complete
+c le defaut en prennant de l'eau vapeur de la couche au-dessous.
+c
+      iq = iq_vap
+c
+      DO k = llm, 2, -1
+ccc      zx_abc = dpres(k) / dpres(k-1)
+        DO i = 1, ip1jmp1
+          if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
+            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
+     &                     deltap(i,k) / deltap(i,k-1)
+            q(i,k,iq)   =  seuil_vap  
+          endif
+        ENDDO
+      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
+      DO i = 1, ip1jmp1
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+      ENDDO
+      pompe = SSUM(ip1jmp1,zx_pump,1)
+      IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN
+         WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
+         DO i = 1, ip1jmp1
+            IF (zx_pump(i).GT.0.0) THEN
+               imprim = imprim + 1
+               PRINT*,'QMINIMUM:  en ',i,zx_pump(i)
+            ENDIF
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/sponge_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/sponge_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/sponge_mod.F90	(revision 222)
@@ -0,0 +1,162 @@
+module sponge_mod
+
+implicit none
+
+! sponge parameters (set/read via conf_gcm.F)
+logical,save :: callsponge  ! do we use a sponge on upper layers
+integer,save :: mode_sponge ! sponge mode
+integer,save :: nsponge ! number of sponge layers 
+real,save :: tetasponge  ! sponge time scale (s) at topmost layer
+
+
+contains
+
+      subroutine sponge(ucov,vcov,h,ps,dt,mode)
+
+! Sponge routine: Quench ucov, vcov and potential temperature near the
+!                 top of the model
+! Depending on 'mode' relaxation of variables is towards:
+! mode = 0 : h -> h_mean , ucov -> 0 , vcov -> 0
+! mode = 1 : h -> h_mean , ucov -> ucov_mean , vcov -> 0
+! mode >= 2 : h -> h_mean , ucov -> ucov_mean , vcov -> vcov_mean
+! Number of layer over which sponge is applied is 'nsponge' (read from def file)
+! Time scale for quenching at top level is given by 'tetasponge' (read from
+! def file) and doubles as level indexes decrease.
+! Quenching is modeled as: A(t)=Am+A0exp(-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*dt))
+
+
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+
+! Arguments:
+!------------
+      real,intent(inout) :: ucov(iip1,jjp1,llm) ! covariant zonal wind
+      real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind
+      real,intent(inout) :: h(iip1,jjp1,llm) ! potential temperature
+!      real,intent(in) :: pext(iip1,jjp1) ! extensive pressure
+      real,intent(in) :: ps(iip1,jjp1) ! surface pressure (Pa)
+      real,intent(in) :: dt   ! time step
+      integer,intent(in) :: mode  ! sponge mode
+
+!   Local:
+!   ------
+
+      real,save :: sig_s(llm) !sigma au milieu des couches
+      REAL vm,um,hm,ptot(jjp1)
+      real,save :: cst(llm)
+      real :: pext(iip1,jjp1) ! extensive pressure
+
+      INTEGER l,i,j
+      integer,save :: l0 ! layer down to which sponge is applied
+
+      real ssum
+
+      real zkm
+      logical,save :: firstcall=.true.
+
+
+
+      if (firstcall) then
+
+       ! build approximative sigma levels at midlayer
+        do l=1,llm
+          sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+        enddo
+
+        l0=llm-nsponge+1
+ 
+        write(lunout,*)
+        write(lunout,*)'sponge mode',mode
+        write(lunout,*)'nsponge tetasponge ',nsponge,tetasponge
+        write(lunout,*)'Coeffs for the sponge layer'
+        write(lunout,*)'Z (km)         tau             cst'
+        do l=llm,l0,-1
+          ! double time scale with every level, starting from the top
+          cst(l)=1.-exp(-dt/(tetasponge*2**(llm-l)))
+        enddo
+
+        do l=l0,llm
+           zkm=-scaleheight*log(sig_s(l))
+           print*,zkm,tetasponge*2**(llm-l),cst(l)
+        enddo
+        PRINT*
+
+        firstcall=.false.
+      endif ! of if (firstcall)
+
+!-----------------------------------------------------------------------
+!   compute sponge relaxation:
+!   -------------------------
+
+      pext(1:iip1,1:jjp1)=ps(1:iip1,1:jjp1)*aire(1:iip1,1:jjp1)
+
+      do j=1,jjp1
+         ptot(j)=sum(pext(1:iim,j))
+      enddo
+ 
+!   potential temperature
+      do l=l0,llm
+         do j=1,jjp1
+            ! compute zonal average
+            hm=0.
+            do i=1,iim
+               hm=hm+h(i,j,l)*pext(i,j)
+            enddo
+            hm=hm/ptot(j)
+            ! update h()
+            do i=1,iim
+               h(i,j,l)=h(i,j,l)-cst(l)*(h(i,j,l)-hm)
+            enddo
+            h(iip1,j,l)=h(1,j,l)
+         enddo
+      enddo
+
+!   zonal wind
+      do l=l0,llm
+         do j=2,jjm
+            um=0.
+            if(mode.ge.1) then ! compute zonal average
+               do i=1,iim
+                  um=um+0.5*ucov(i,j,l)*(pext(i,j)+pext(i+1,j))/cu(i,j)
+               enddo
+               um=um/ptot(j)
+            endif
+            ! update ucov()
+            do i=1,iim
+               ucov(i,j,l)=ucov(i,j,l)-cst(l)*(ucov(i,j,l)-um*cu(i,j))
+            enddo
+            ucov(iip1,j,l)=ucov(1,j,l)
+         enddo
+      enddo
+
+!  meridional wind
+      do l=l0,llm
+         do j=1,jjm
+            vm=0.
+            if(mode.ge.2) then ! compute zonal average
+               do i=1,iim
+                  vm=vm+vcov(i,j,l)*(pext(i,j)+pext(i,j+1))/cv(i,j)
+               enddo
+               vm=vm/(ptot(j)+ptot(j+1))
+            endif
+            ! update vcov
+            do i=1,iim
+               vcov(i,j,l)=vcov(i,j,l)-cst(l)*(vcov(i,j,l)-vm*cv(i,j))
+            enddo
+            vcov(iip1,j,l)=vcov(1,j,l)
+         enddo
+      enddo
+
+      end subroutine sponge
+      
+end module sponge_mod
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/sw_case_williamson91_6.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/sw_case_williamson91_6.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/sw_case_williamson91_6.F	(revision 222)
@@ -0,0 +1,140 @@
+!
+! $Id $
+!
+      SUBROUTINE sw_case_williamson91_6(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=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+
+c   Local:
+c   ------
+
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+
+      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)
+ 
+      IF(0==0) THEN
+c Williamson et al. (1991) : onde de Rossby-Haurwitz
+         teta = 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(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(ij,1) = (Ath + Bth*cos(R0*lon))
+            enddo
+         enddo
+         write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
+         ucov(:,1)=ucov(:,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(ij,1) = Ath*sin(R0*lon)
+            enddo
+         enddo
+         write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
+         vcov(:,1)=vcov(:,1)*cv
+         
+c         ucov=0
+c         vcov=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(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2) )
+            enddo
+         enddo
+         
+c     rho = preff/(cpp*teta)
+         teta = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
+         ucov=0.
+         vcov=0.
+      END IF      
+      
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL massdair(p,masse)
+
+      END
+c-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/tetaleveli1j.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/tetaleveli1j.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/tetaleveli1j.F	(revision 222)
@@ -0,0 +1,139 @@
+c================================================================
+c================================================================
+      SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+!      USE dimphy
+      IMPLICIT none
+
+#include "dimensions.h"
+ccccc#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cIM 211004
+c     INTEGER lt(klon), lb(klon)
+c     REAL ptop, pbot, aist(klon), aisb(klon)
+c
+#include "paramet.h"
+c
+      INTEGER lt(ip1jm), lb(ip1jm)
+      REAL ptop, pbot, aist(ip1jm), aisb(ip1jm)
+cMI 211004
+      save lt,lb,ptop,pbot,aist,aisb
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+c=====================================================================
+      if (lnew) then
+c   on réinitialise les réindicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Frédéric Hourdin (3/01/02)
+
+        IF(pgcm(i,lb(i)).EQ.0.OR.
+     $     pgcm(i,lt(i)).EQ.0.) THEN
+c
+        PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+     .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        ENDIF 
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/tetaleveli1j1.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/tetaleveli1j1.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/tetaleveli1j1.F	(revision 222)
@@ -0,0 +1,139 @@
+c================================================================
+c================================================================
+      SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+!      USE dimphy
+      IMPLICIT none
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cIM 211004
+c     INTEGER lt(klon), lb(klon)
+c     REAL ptop, pbot, aist(klon), aisb(klon)
+c
+#include "paramet.h"
+c
+      INTEGER lt(ip1jmp1), lb(ip1jmp1)
+      REAL ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1)
+cMI 211004
+      save lt,lb,ptop,pbot,aist,aisb
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+c=====================================================================
+      if (lnew) then
+c   on réinitialise les réindicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Frédéric Hourdin (3/01/02)
+
+        IF(pgcm(i,lb(i)).EQ.0.OR.
+     $     pgcm(i,lt(i)).EQ.0.) THEN
+c
+        PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+     .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        ENDIF 
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/top_bound.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/top_bound.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/top_bound.F	(revision 222)
@@ -0,0 +1,196 @@
+!
+! $Id: top_bound.F 1793 2013-07-18 07:13:18Z emillour $
+!
+      SUBROUTINE top_bound(vcov,ucov,teta,masse,dt,ducov)
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+
+c ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
+C     F. LOTT DEC. 2006
+c                                 (  10/12/06  )
+
+c=======================================================================
+c
+c   Auteur:  F. LOTT  
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation linéaire (ex top_bound de la physique)
+c
+c=======================================================================
+
+! 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*dt))
+! 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.h)
+!    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,jjp1,llm) ! covariant zonal wind
+      real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind
+      real,intent(inout) :: teta(iip1,jjp1,llm) ! potential temperature
+      real,intent(in) :: masse(iip1,jjp1,llm) ! mass of atmosphere 
+      real,intent(in) :: dt ! time step (s) of sponge model
+      real,intent(out) :: ducov(iip1,jjp1,llm) ! increment on ucov due to sponge
+
+c   Local:
+c   ------
+
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm
+      REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm)
+      
+      integer i
+      REAL,SAVE :: rdamp(llm) ! quenching coefficient
+      real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
+
+      LOGICAL,SAVE :: first=.true.
+
+      INTEGER j,l
+      
+      if (first) then
+         if (iflag_top_bound.eq.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.eq.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.
+      endif ! of if (first)
+
+      CALL massbar(masse,massebx,masseby)
+
+      ! compute zonal average of vcov and u
+      if (mode_top_bound.ge.2) then
+       do l=1,llm
+        do j=1,jjm
+          vzon(j,l)=0.
+          zm=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
+
+       do l=1,llm
+        do j=2,jjm ! excluding poles
+          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
+      else ! ucov and vcov will relax towards 0
+        vzon(:,:)=0.
+        uzon(:,:)=0.
+      endif ! of if (mode_top_bound.ge.2)
+
+      ! compute zonal average of potential temperature, if necessary
+      if (mode_top_bound.ge.3) then
+       do l=1,llm
+        do j=2,jjm ! excluding poles
+          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
+      endif ! of if (mode_top_bound.ge.3)
+
+      if (mode_top_bound.ge.1) then
+       ! Apply sponge quenching on vcov:
+       do l=1,llm
+        do i=1,iip1
+          do j=1,jjm
+            vcov(i,j,l)=vcov(i,j,l)
+     &                  -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
+          enddo
+        enddo
+       enddo
+
+       ! Apply sponge quenching on ucov:
+       do l=1,llm
+        do i=1,iip1
+          do j=2,jjm ! excluding poles
+            ducov(i,j,l)=-rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+            ucov(i,j,l)=ucov(i,j,l)
+     &                  +ducov(i,j,l)
+          enddo
+        enddo
+       enddo
+      endif ! of if (mode_top_bound.ge.1)
+
+      if (mode_top_bound.ge.3) then
+       ! Apply sponge quenching on teta:
+       do l=1,llm
+        do i=1,iip1
+          do j=2,jjm ! excluding poles
+            teta(i,j,l)=teta(i,j,l)
+     &                  -rdamp(l)*(teta(i,j,l)-tzon(j,l))
+          enddo
+        enddo
+       enddo
+      endif ! of if (mode_top_bound.ge.3)
+    
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/vlsplt.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/vlsplt.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/vlsplt.F	(revision 222)
@@ -0,0 +1,959 @@
+c
+c $Id: vlsplt.F 1550 2011-07-05 09:44:55Z lguez $
+c
+
+      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pente_max facteur de limitation des pentes: 2 en general
+c                                               0 pour un schema amont
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+c      REAL masse(iip1,jjp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+c      REAL q(iip1,jjp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      INTEGER ijlqmin,iqmin,jqmin,lqmin
+c
+      REAL zm(ip1jmp1,llm),newmasse
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm),zz
+      REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
+      REAL second,temps0,temps1,temps2,temps3
+      REAL ztemps1,ztemps2,ztemps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+      INTEGER iminn,imaxx
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+      
+      CALL SCOPY(ijp1llm,q,1,zq,1)
+      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+cprint*,'Entree vlx1'
+c	call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call vlx(zq,pente_max,zm,mu)
+cprint*,'Sortie vlx1'
+c	call minmaxq(zq,qmin,qmax,'apres vlx1    ')
+
+c print*,'Entree vly1'
+      call vly(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly1     ')
+cprint*,'Sortie vly1'
+      call vlz(zq,pente_max,zm,mw)
+c	call minmaxq(zq,qmin,qmax,'apres vlz     ')
+
+
+      call vly(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly     ')
+
+
+      call vlx(zq,pente_max,zm,mu)
+c	call minmaxq(zq,qmin,qmax,'apres vlx2    ')
+	
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlx(q,pente_max,masse,u_m)
+
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+      include "dimensions.h"
+      include "paramet.h"
+      include "logic.h"
+      include "comvert.h"
+      include "comconst.h"
+      include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical extremum,first,testcpu
+      SAVE first,testcpu
+
+      REAL      SSUM
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+
+      REAL z1,z2,z3
+
+      DATA first,testcpu/.true.,.false./
+
+      IF(first) THEN
+         temps1=0.
+         temps2=0.
+         temps3=0.
+         temps4=0.
+         temps5=0.
+         first=.false.
+      ENDIF
+
+c   calcul de la pente a droite et a gauche de la maille
+
+
+      IF (pente_max.gt.-1.e-5) THEN
+c       IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=iip2,ip1jm
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=iip2+1,ip1jm
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+cprint*,'Ok calcul des pentes'
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               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
+
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+
+      DO l=1,llm
+         DO ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+         DO ij=1,ip1jmp1
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+
+c print*,'Bouclage en iip1'
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+cprint*,'Cumule ....'
+
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+c	print*,'masse(',ij,')=',masse(ij,l)
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
+          ENDIF
+       ENDDO
+      ENDDO
+#endif
+c	stop
+
+c	go to 9999
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+      DO l=1,llm
+         DO ij=iip2,ip1jm-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+cprint*,'Ok test 1'
+      DO l=1,llm
+       DO ij=iip1+iip1,ip1jm,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c print*,'Ok test 2'
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+      DO l=1,llm
+         nl(l)=0
+         DO ij=iip2,ip1jm
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+
+      IF(n0.gt.0) THEN
+      if (prt_level > 2) PRINT *,
+     $        'Nombre de points pour lesquels on advect plus que le'
+     &       ,'contenu de la maille : ',n0
+
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=iip2,ip1jm
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF  ! n0.gt.0 
+9999    continue
+
+
+c   bouclage en latitude
+cprint*,'cvant bouclage en latitude'
+      DO l=1,llm
+        DO ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+
+
+c   calcul des tENDances
+
+      DO l=1,llm
+         DO ij=iip2+1,ip1jm
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         ENDDO
+c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         DO ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+
+
+      RETURN
+      END
+      SUBROUTINE vly(q,pente_max,masse,masse_adv_v)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical extremum,first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE first,testcpu
+
+      REAL convpn,convps,convmpn,convmps
+      real massepn,masseps,qpn,qps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c
+c
+      REAL      SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+cPRINT*,'CALCUL EN LATITUDE'
+
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      DO ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      DO ij=iip2,ip1jm
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+
+      DO ij=1,iip1
+         dyq(ij,l)=qpns-q(ij+iip1,l)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+      ENDDO
+
+c   filtrage de la derivee
+      dyn1=0.
+      dys1=0.
+      dyn2=0.
+      dys2=0.
+      DO ij=1,iim
+         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+      ENDDO
+
+c   calcul des pentes limites aux poles
+
+      goto 8888
+      fn=1.
+      fs=1.
+      DO ij=1,iim
+         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+         ENDIF
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+      ENDDO
+8888    continue
+      DO ij=1,iip1
+         dyq(ij,l)=0.
+         dyq(ip1jm+ij,l)=0.
+      ENDDO
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     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
+
+      DO ij=iip2,ip1jm
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+
+      DO l=1,llm
+       DO ij=1,ip1jm
+          IF(masse_adv_v(ij,l).gt.0) THEN
+              qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
+     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
+          ELSE
+              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+          ENDIF
+          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+
+
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+            newmasse=masse(ij,l)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+
+         convpn=SSUM(iim,qbyv(1,l),1)
+         convmpn=ssum(iim,masse_adv_v(1,l),1)
+         massepn=ssum(iim,masse(1,l),1)
+         qpn=0.
+         do ij=1,iim
+            qpn=qpn+masse(ij,l)*q(ij,l)
+         enddo
+         qpn=(qpn+convpn)/(massepn+convmpn)
+         do ij=1,iip1
+            q(ij,l)=qpn
+         enddo
+
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+
+         convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+         convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+         masseps=ssum(iim, masse(ip1jm+1,l),1)
+         qps=0.
+         do ij = ip1jm+1,ip1jmp1-1
+            qps=qps+masse(ij,l)*q(ij,l)
+         enddo
+         qps=(qps+convps)/(masseps+convmps)
+         do ij=ip1jm+1,ip1jmp1
+            q(ij,l)=qps
+         enddo
+
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlz(q,pente_max,masse,w)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL wq(ip1jmp1,llm+1),newmasse
+
+      REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
+      REAL sigw
+
+      LOGICAL testcpu
+      SAVE testcpu
+
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      REAL      SSUM
+
+      DATA testcpu/.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps0=second(0.)
+      ENDIF
+#endif
+      DO l=2,llm
+         DO ij=1,ip1jmp1
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         ENDDO
+      ENDDO
+
+      DO l=2,llm-1
+         DO ij=1,ip1jmp1
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            ELSE
+                dzq(ij,l)=0.
+            ENDIF
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      ENDDO
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps1=temps1+second(0.)-temps0
+      ENDIF
+#endif
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+       DO l = 1,llm-1
+         do  ij = 1,ip1jmp1
+          IF(w(ij,l+1).gt.0.) THEN
+             sigw=w(ij,l+1)/masse(ij,l+1)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
+          ELSE
+             sigw=w(ij,l+1)/masse(ij,l)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+          ENDIF
+         ENDDO
+       ENDDO
+
+       DO ij=1,ip1jmp1
+          wq(ij,llm+1)=0.
+          wq(ij,1)=0.
+       ENDDO
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+      ENDDO
+
+
+      RETURN
+      END
+c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
+c
+c#include "dimensions.h"
+c#include "paramet.h"
+
+c      CHARACTER*(*) comment
+c      real qmin,qmax
+c      real zq(ip1jmp1,llm)
+
+c      INTEGER jadrs(ip1jmp1), jbad, k, i
+
+
+c      DO k = 1, llm
+c         jbad = 0
+c         DO i = 1, ip1jmp1
+c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+c            jbad = jbad + 1
+c            jadrs(jbad) = i
+c         ENDIF
+c         ENDDO
+c         IF (jbad.GT.0) THEN
+c         PRINT*, comment
+c         DO i = 1, jbad
+cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
+c         ENDDO
+c         ENDIF
+c      ENDDO
+
+c      return
+c      end
+      subroutine minmaxq(zq,qmin,qmax,comment)
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      character*20 comment
+      real qmin,qmax
+      real zq(ip1jmp1,llm)
+      real zzq(iip1,jjp1,llm)
+
+      integer imin,jmin,lmin,ijlmin
+      integer imax,jmax,lmax,ijlmax
+
+      integer ismin,ismax
+
+#ifdef isminismax
+      call scopy (ip1jmp1*llm,zq,1,zzq,1)
+
+      ijlmin=ismin(ijp1llm,zq,1)
+      lmin=(ijlmin-1)/ip1jmp1+1
+      ijlmin=ijlmin-(lmin-1.)*ip1jmp1
+      jmin=(ijlmin-1)/iip1+1
+      imin=ijlmin-(jmin-1.)*iip1
+      zqmin=zq(ijlmin,lmin)
+
+      ijlmax=ismax(ijp1llm,zq,1)
+      lmax=(ijlmax-1)/ip1jmp1+1
+      ijlmax=ijlmax-(lmax-1.)*ip1jmp1
+      jmax=(ijlmax-1)/iip1+1
+      imax=ijlmax-(jmax-1.)*iip1
+      zqmax=zq(ijlmax,lmax)
+
+       if(zqmin.lt.qmin) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
+       if(zqmax.gt.qmax) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
+
+#endif
+      return
+9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
+      end
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/vlspltqs.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/vlspltqs.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/vlspltqs.F	(revision 222)
@@ -0,0 +1,777 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltqs ( 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          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      use cpdet_mod, only: tpot2t
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL qsat(ip1jmp1,llm)
+      REAL zm(ip1jmp1,llm)
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm)
+      REAL temps1,temps2,temps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+! ADAPTATION GCM POUR CP(T)
+      REAL tempe(ip1jmp1,llm)
+
+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-- 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.
+
+! ADAPTATION GCM POUR CP(T)
+        call tpot2t(ip1jmp1*llm,teta,tempe,pk)
+        DO l = 1, llm
+         DO ij = 1, ip1jmp1
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij,l)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij,l),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+
+      CALL SCOPY(ijp1llm,q,1,zq,1)
+      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
+      call vlxqs(zq,pente_max,zm,mu,qsat)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
+
+      call vlyqs(zq,pente_max,zm,mv,qsat)
+
+
+c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
+
+      call vlz(zq,pente_max,zm,mw)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
+c     call minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
+
+      call vlyqs(zq,pente_max,zm,mv,qsat)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
+c     call minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
+
+      call vlxqs(zq,pente_max,zm,mu,qsat)
+
+c     call minmaxq(zq,qmin,qmax,'apres vlxqs     ')
+c     call minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
+
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm )
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical first,testcpu
+      SAVE first,testcpu
+
+      REAL      SSUM
+      REAL temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+
+
+      DATA first,testcpu/.true.,.false./
+
+      IF(first) THEN
+         temps1=0.
+         temps2=0.
+         temps3=0.
+         temps4=0.
+         temps5=0.
+         first=.false.
+      ENDIF
+
+c   calcul de la pente a droite et a gauche de la maille
+
+
+      IF (pente_max.gt.-1.e-5) THEN
+c     IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=iip2,ip1jm
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=iip2+1,ip1jm
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               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
+
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+
+      DO l=1,llm
+         DO ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+
+         DO ij=1,ip1jmp1
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c--pas encore modification sur Qsat
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+c   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+          ENDIF
+       ENDDO
+      ENDDO
+#endif
+
+
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+      DO l=1,llm
+         DO ij=iip2,ip1jm-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+      DO l=1,llm
+       DO ij=iip1+iip1,ip1jm,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c   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
+      DO l=1,llm
+         nl(l)=0
+         DO ij=iip2,ip1jm
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+
+      IF(n0.gt.0) THEN
+ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+ccc     &       ,'contenu de la maille : ',n0
+
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=iip2,ip1jm
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF  ! n0.gt.0 
+
+
+
+c   bouclage en latitude
+
+      DO l=1,llm
+        DO ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+
+
+c   calcul des tendances
+
+      DO l=1,llm
+         DO ij=iip2+1,ip1jm
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         ENDDO
+c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         DO ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+
+
+      RETURN
+      END
+      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     qsat 	       est   un argument de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE first,testcpu
+
+      REAL convpn,convps,convmpn,convmps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c
+c
+      REAL      SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+
+
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      DO ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      DO ij=iip2,ip1jm
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+
+      DO ij=1,iip1
+         dyq(ij,l)=qpns-q(ij+iip1,l)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+      ENDDO
+
+c   filtrage de la derivee
+      dyn1=0.
+      dys1=0.
+      dyn2=0.
+      dys2=0.
+      DO ij=1,iim
+         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+      ENDDO
+
+c   calcul des pentes limites aux poles
+
+      fn=1.
+      fs=1.
+      DO ij=1,iim
+         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+         ENDIF
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+      ENDDO
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     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
+
+      DO ij=iip2,ip1jm
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+
+      DO l=1,llm
+       DO ij=1,ip1jm
+         IF( masse_adv_v(ij,l).GT.0. ) THEN
+           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
+         ELSE
+              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
+         ENDIF
+          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+
+
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+            newmasse=masse(ij,l)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+         convpn=SSUM(iim,qbyv(1,l),1)/apoln
+         convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+         DO ij = 1,iip1
+            newmasse=masse(ij,l)+convmpn*aire(ij)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
+     &               newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+         convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+         convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+         DO ij = ip1jm+1,ip1jmp1
+            newmasse=masse(ij,l)+convmps*aire(ij)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
+     &               newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/wrgrads.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/wrgrads.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/wrgrads.F	(revision 222)
@@ -0,0 +1,133 @@
+!
+! $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)
+
+      integer, parameter:: wp = selected_real_kind(p=6, r=36)
+      real(wp) field4(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.
+
+c     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)
+
+c     print*,'im,jm,lm,name,firsttime(if)'
+c     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
+c           print*,'initialisation ecriture de ',var(ivar(if),if)
+c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
+      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   ((field4((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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/write_paramLMDZ_dyn.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/write_paramLMDZ_dyn.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d/write_paramLMDZ_dyn.h	(revision 222)
@@ -0,0 +1,246 @@
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Attention : il n'y a aucune raison pour ecrire ces constantes
+! comme des champs 2D. A corriger un jour ...
+
+c
+      ndex2d = 0
+      itau_w=itau_dyn+itau
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(prt_level) 
+      CALL histwrite(nid_ctesGCM, "prt_level", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(dayref)
+      CALL histwrite(nid_ctesGCM, "dayref", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(anneeref)
+      CALL histwrite(nid_ctesGCM, "anneeref", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(raz_date)
+      CALL histwrite(nid_ctesGCM, "raz_date", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(nday)
+      CALL histwrite(nid_ctesGCM, "nday", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(day_step)
+      CALL histwrite(nid_ctesGCM, "day_step", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iperiod)
+      CALL histwrite(nid_ctesGCM, "iperiod", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iapp_tracvl)
+      CALL histwrite(nid_ctesGCM, "iapp_tracvl", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iconser)
+      CALL histwrite(nid_ctesGCM, "iconser", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iecri)
+      CALL histwrite(nid_ctesGCM, "iecri", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=periodav
+      CALL histwrite(nid_ctesGCM, "periodav", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(dissip_period)
+      CALL histwrite(nid_ctesGCM, "dissip_period", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(lstardis) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "lstardis", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(nitergdiv)
+      CALL histwrite(nid_ctesGCM, "nitergdiv", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(nitergrot)
+      CALL histwrite(nid_ctesGCM, "nitergrot", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(niterh) 
+      CALL histwrite(nid_ctesGCM, "niterh", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tetagdiv
+      CALL histwrite(nid_ctesGCM, "tetagdiv", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tetagrot
+      CALL histwrite(nid_ctesGCM, "tetagrot", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tetatemp
+      CALL histwrite(nid_ctesGCM, "tetatemp", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=coefdis
+      CALL histwrite(nid_ctesGCM, "coefdis", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(purmats) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "purmats", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(ok_guide) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "ok_guide", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      if (calend == 'earth_360d') then
+        zx_tmp_2d(1:iip1,1:jjp1)=1.
+      else if (calend == 'earth_365d') then
+        zx_tmp_2d(1:iip1,1:jjp1)=2.
+      else if (calend == 'earth_366d') then
+        zx_tmp_2d(1:iip1,1:jjp1)=3.
+      endif
+
+      CALL histwrite(nid_ctesGCM, "true_calendar", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iflag_phys)
+      CALL histwrite(nid_ctesGCM, "iflag_phys", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iphysiq)
+      CALL histwrite(nid_ctesGCM, "iphysiq", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02
+! La variable cycle_diurne n'est pas vue par la dynamique
+!     IF(cycle_diurne) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "cycle_diurne", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(soil_model) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "soil_model", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(new_oliq) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "new_oliq", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(ok_orodr) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "ok_orodr", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(ok_orolf) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "ok_orolf", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(ok_limitvrai) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "ok_limitvrai", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     zx_tmp_2d(1:iip1,1:jjp1)=nbapp_rad
+!     CALL histwrite(nid_ctesGCM, "nbapp_rad", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     zx_tmp_2d(1:iip1,1:jjp1)=iflag_con
+!     CALL histwrite(nid_ctesGCM, "iflag_con", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=clon
+      CALL histwrite(nid_ctesGCM, "clon", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=clat
+      CALL histwrite(nid_ctesGCM, "clat", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=grossismx
+      CALL histwrite(nid_ctesGCM, "grossismx", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=grossismy
+      CALL histwrite(nid_ctesGCM, "grossismy", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(fxyhypb) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "fxyhypb", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=dzoomx
+      CALL histwrite(nid_ctesGCM, "dzoomx", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=dzoomy
+      CALL histwrite(nid_ctesGCM, "dzoomy", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=taux
+      CALL histwrite(nid_ctesGCM, "taux", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tauy
+      CALL histwrite(nid_ctesGCM, "tauy", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(ysinus) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "ysinus", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=ip_ebil_dyn
+      CALL histwrite(nid_ctesGCM, "ip_ebil_dyn", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_ctesGCM)
+      endif
+c
+c=================================================================
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/academic.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/academic.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/academic.h	(revision 222)
@@ -0,0 +1,9 @@
+!
+! $Id: academic.h 1437 2010-09-30 08:29:10Z emillour $
+!
+      common/academic/tetarappel,knewt_t,kfrict,knewt_g,clat4
+      real :: tetarappel(ip1jmp1,llm)
+      real :: knewt_t(llm)
+      real :: kfrict(llm)
+      real :: knewt_g
+      real :: clat4(ip1jmp1)
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/adaptdt.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/adaptdt.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/adaptdt.F	(revision 222)
@@ -0,0 +1,59 @@
+!
+! $Id: adaptdt.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      subroutine adaptdt(nadv,dtbon,n,pbaru,
+     c                   masse)
+
+      USE control_mod
+      IMPLICIT NONE
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+
+c----------------------------------------------------------
+c     Arguments
+c----------------------------------------------------------
+      INTEGER n,nadv
+      REAL dtbon 
+      REAL pbaru(iip1,jjp1,llm)
+      REAL masse(iip1,jjp1,llm)
+c----------------------------------------------------------    
+c     Local
+c----------------------------------------------------------
+      INTEGER i,j,l
+      REAL CFLmax,aaa,bbb
+      
+        CFLmax=0.
+        do l=1,llm
+         do j=2,jjm
+          do i=1,iim
+             aaa=pbaru(i,j,l)*dtvr/masse(i,j,l)
+             CFLmax=max(CFLmax,aaa)
+             bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l)
+             CFLmax=max(CFLmax,bbb)
+          enddo
+         enddo
+        enddo              
+        n=int(CFLmax)+1
+c pour reproduire cas VL du code qui appele x,y,z,y,x
+c        if (nadv.eq.30) n=n/2   ! Pour Prather
+        dtbon=dtvr/n
+        
+       return
+       end
+
+
+
+
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advn.F	(revision 222)
@@ -0,0 +1,983 @@
+!
+! $Header$
+!
+      SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+c
+c   Arguments:
+c   ----------
+      integer mode
+      real masse(ip1jmp1,llm)
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      integer ijlqmin,iqmin,jqmin,lqmin
+      integer ismin
+c
+      real zm(ip1jmp1,llm),newmasse
+      real mu(ip1jmp1,llm)
+      real mv(ip1jm,llm)
+      real mw(ip1jmp1,llm+1)
+      real zq(ip1jmp1,llm),zz,qpn,qps
+      real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm)
+      real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm)
+      real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm)
+      real temps0,temps1,temps2,temps3
+      real ztemps1,ztemps2,ztemps3,ssum
+      logical testcpu
+      save testcpu
+      save temps1,temps2,temps3
+      real zzpbar,zzw
+
+#ifdef CRAY
+      real second
+#endif
+
+      real qmin,qmax
+      data qmin,qmax/0.,1./
+      data testcpu/.false./
+      data temps1,temps2,temps3/0.,0.,0./
+
+      zzpbar = 0.5 * pdt
+      zzw    = pdt
+
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+
+      do l=1,llm
+         qpn=0.
+         qps=0.
+         do ij=1,iim
+            qpn=qpn+q(ij,l)*masse(ij,l)
+            qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l)
+         enddo
+         qpn=qpn/ssum(iim,masse(1,l),1)
+         qps=qps/ssum(iim,masse(ip1jm+1,l),1)
+         do ij=1,iip1
+            q(ij,l)=qpn
+            q(ip1jm+ij,l)=qps
+         enddo
+      enddo
+
+      do ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      enddo
+      do l=1,llm
+         do ij=1,ip1jmp1
+            zq(ij,l)=q(ij,l)
+            zm(ij,l)=masse(ij,l)
+         enddo
+      enddo
+
+c     call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call advnqx(zq,zqg,zqd)
+      call advnx(zq,zqg,zqd,zm,mu,mode)
+      call advnqy(zq,zqs,zqn)
+      call advny(zq,zqs,zqn,zm,mv)
+      call advnqz(zq,zqh,zqb)
+      call advnz(zq,zqh,zqb,zm,mw)
+c     call vlz(zq,0.,zm,mw)
+      call advnqy(zq,zqs,zqn)
+      call advny(zq,zqs,zqn,zm,mv)
+      call advnqx(zq,zqg,zqd)
+      call advnx(zq,zqg,zqd,zm,mu,mode)
+c     call minmaxq(zq,qmin,qmax,'apres vlx     ')
+
+#ifdef CRAY
+      if(testcpu) then
+         ztemps1=second(0.)
+         temps1=temps1+ztemps1-ztemps2
+            print*,'VLSPLT X:',temps1,'   Y:',temps2,'   Z:',temps3
+      endif
+#endif
+      do l=1,llm
+         do ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         enddo
+         do ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         enddo
+      enddo
+
+      RETURN
+      END
+
+      SUBROUTINE advnqx(q,qg,qd)
+c
+c     Auteurs:   Calcul des valeurs de q aux point u.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dxqu(ip1jmp1),zqu(ip1jmp1)
+      real zqmax(ip1jmp1),zqmin(ip1jmp1)
+      logical extremum(ip1jmp1)
+
+      integer mode
+      save mode
+      data mode/1/
+
+c   calcul des pentes en u:
+c   -----------------------
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jm
+               qd(ij,l)=q(ij,l)
+               qg(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+      do l = 1, llm
+         do ij=iip2,ip1jm-1
+            dxqu(ij)=q(ij+1,l)-q(ij,l)
+            zqu(ij)=0.5*(q(ij+1,l)+q(ij,l))
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqu(ij)=dxqu(ij-iim)
+            zqu(ij)=zqu(ij-iim)
+         enddo
+         do ij=iip2,ip1jm-1
+            zqu(ij)=zqu(ij)-dxqu(ij+1)/12.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqu(ij)=zqu(ij-iim)
+         enddo
+         do ij=iip2+1,ip1jm
+            zqu(ij)=zqu(ij)+dxqu(ij-1)/12.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqu(ij-iim)=zqu(ij)
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+
+         do ij=iip2,ip1jm-1
+            zqmax(ij)=max(q(ij+1,l),q(ij,l))
+            zqmin(ij)=min(q(ij+1,l),q(ij,l))
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqmax(ij)=zqmax(ij-iim)
+            zqmin(ij)=zqmin(ij-iim)
+         enddo
+         do ij=iip2+1,ip1jm
+            extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            extremum(ij-iim)=extremum(ij)
+         enddo
+         do ij=iip2,ip1jm
+            zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij))
+         enddo
+         do ij=iip2+1,ip1jm
+            if(extremum(ij)) then
+               qg(ij,l)=q(ij,l)
+               qd(ij,l)=q(ij,l)
+            else
+               qd(ij,l)=zqu(ij)
+               qg(ij,l)=zqu(ij-1)
+            endif
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            qd(ij-iim,l)=qd(ij,l)
+            qg(ij-iim,l)=qg(ij,l)
+         enddo
+
+         goto 8888
+
+         do ij=iip2+1,ip1jm
+            if(extremum(ij).and..not.extremum(ij-1))
+     s         qd(ij-1,l)=q(ij,l)
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            qd(ij-iim,l)=qd(ij,l)
+         enddo
+         do ij=iip2,ip1jm-1
+            if (extremum(ij).and..not.extremum(ij+1))
+     s         qg(ij+1,l)=q(ij,l)
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            qg(ij,l)=qg(ij-iim,l)
+         enddo
+8888     continue
+      enddo
+      endif
+      RETURN
+      END
+      SUBROUTINE advnqy(q,qs,qn)
+c
+c     Auteurs:   Calcul des valeurs de q aux point v.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dyqv(ip1jm),zqv(ip1jm,llm)
+      real zqmax(ip1jm),zqmin(ip1jm)
+      logical extremum(ip1jmp1)
+
+      integer mode
+      save mode
+      data mode/1/
+
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+               qn(ij,l)=q(ij,l)
+               qs(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+
+c   calcul des pentes en u:
+c   -----------------------
+      do l = 1, llm
+         do ij=1,ip1jm
+            dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         enddo
+
+         do ij=iip2,ip1jm-iip1
+            zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l))
+            zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12.
+         enddo
+
+         do ij=iip2,ip1jm
+            extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0.
+         enddo
+
+c Pas de pentes aux poles
+         do ij=1,iip1
+            zqv(ij,l)=q(ij,l)
+            zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l)
+            extremum(ij)=.true.
+            extremum(ip1jmp1-iip1+ij)=.true.
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+         do ij=1,ip1jm
+            zqmax(ij)=max(q(ij+iip1,l),q(ij,l))
+            zqmin(ij)=min(q(ij+iip1,l),q(ij,l))
+         enddo
+
+         do ij=1,ip1jm
+            zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij))
+         enddo
+
+         do ij=iip2,ip1jm
+            if(extremum(ij)) then
+               qs(ij,l)=q(ij,l)
+               qn(ij,l)=q(ij,l)
+c              if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l)
+c              if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l)
+            else
+               qs(ij,l)=zqv(ij,l)
+               qn(ij,l)=zqv(ij-iip1,l)
+            endif
+         enddo
+
+         do ij=1,iip1
+            qs(ij,l)=q(ij,l)
+            qn(ij,l)=q(ij,l)
+            qs(ip1jm+ij,l)=q(ip1jm+ij,l)
+            qn(ip1jm+ij,l)=q(ip1jm+ij,l)
+         enddo
+
+      enddo
+      endif
+      RETURN
+      END
+
+      SUBROUTINE advnqz(q,qh,qb)
+c
+c     Auteurs:   Calcul des valeurs de q aux point v.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1)
+      real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm)
+      logical extremum(ip1jmp1,llm)
+
+      integer mode
+      save mode
+
+      data mode/1/
+
+c   calcul des pentes en u:
+c   -----------------------
+
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+               qb(ij,l)=q(ij,l)
+               qh(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+      do l = 2, llm
+         do ij=1,ip1jmp1
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l))
+         enddo
+      enddo
+      do ij=1,ip1jmp1
+         dzqw(ij,1)=0.
+         dzqw(ij,llm+1)=0.
+      enddo
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12.
+         enddo
+      enddo
+      do l=2,llm-1
+         do ij=1,ip1jmp1
+            extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0.
+         enddo
+      enddo
+
+c Pas de pentes en bas et en haut
+         do ij=1,ip1jmp1
+            zqw(ij,2)=q(ij,1)
+            zqw(ij,llm)=q(ij,llm)
+            extremum(ij,1)=.true.
+            extremum(ij,llm)=.true.
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqmax(ij,l)=max(q(ij,l-1),q(ij,l))
+            zqmin(ij,l)=min(q(ij,l-1),q(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm-1
+         do ij=1,ip1jmp1
+            if(extremum(ij,l)) then
+               qh(ij,l)=q(ij,l)
+               qb(ij,l)=q(ij,l)
+            else
+               qh(ij,l)=zqw(ij,l+1)
+               qb(ij,l)=zqw(ij,l)
+            endif
+         enddo
+      enddo
+c     do l=2,llm-1
+c        do ij=1,ip1jmp1
+c           if(extremum(ij,l)) then
+c              if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l)
+c              if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l)
+c           endif
+c        enddo
+c     enddo
+
+      do ij=1,ip1jmp1
+         qb(ij,1)=q(ij,1)
+         qh(ij,1)=q(ij,1)
+         qb(ij,llm)=q(ij,llm)
+         qh(ij,llm)=q(ij,llm)
+      enddo
+
+      endif
+
+      RETURN
+      END
+
+      SUBROUTINE advnx(q,qg,qd,masse,u_m,mode)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      integer mode
+      real masse(ip1jmp1,llm)
+      real u_m( ip1jmp1,llm )
+      real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq
+      integer n0,nl(llm)
+c
+      real new_m,zu_m,zdq,zz
+      real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig
+      real u_mq(ip1jmp1,llm)
+
+      real zm,zq,zsigm,zsigp,zqm,zqp,zu
+
+      logical ladvplus(ip1jmp1,llm)
+
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+
+      do l=1,llm
+            do ij=iip2,ip1jm
+               zdq=qd(ij,l)-qg(ij,l)
+c              if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l
+c                 print*,qd(ij,l),q(ij,l),qg(ij,l)
+c                 qd(ij,l)=q(ij,l)
+c                 qg(ij,l)=q(ij,l)
+c              endif
+               if(abs(zdq).gt.prec) then
+                  zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq
+                  zsigg(ij,l)=1.-zsigd(ij,l)
+c                 if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and.
+c    s               zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then
+c                    print*,'probleme au point ij=',ij,'  l=',l
+c                    print*,'sigg=',zsigg(ij,l),'  sigd=',zsigd(ij,l)
+c                    print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq
+c                    stop
+c                 endif
+               else
+                  zsigd(ij,l)=0.5
+                  zsigg(ij,l)=0.5
+                  qd(ij,l)=q(ij,l)
+                  qg(ij,l)=q(ij,l)
+               endif
+            enddo
+       enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+       do l=1,llm
+       do ij=iip2,ip1jm-1
+          if (u_m(ij,l).ge.0.) then
+             zsigp=zsigd(ij,l)
+             zsigm=zsigg(ij,l)
+             zqp=qd(ij,l)
+             zqm=qg(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          else
+             zsigm=zsigd(ij+1,l)
+             zsigp=zsigg(ij+1,l)
+             zqm=qd(ij+1,l)
+             zqp=qg(ij+1,l)
+             zm=masse(ij+1,l)
+             zq=q(ij+1,l)
+          endif
+          zu=abs(u_m(ij,l))
+          ladvplus(ij,l)=zu.gt.zm
+          zsig=zu/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (mode.eq.1) then
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*zqp
+             else if (mode.eq.1) then
+                 u_mq(ij,l)=
+     s           sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm)
+             endif 
+          else
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+             else
+                zz=0.5*(zsig-zsigp)/zsigm
+                u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp
+     s          +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+             endif
+          endif
+c         if(zsig.lt.0.) then
+c            print*,'au point ij=',ij,'  l=',l,'  sig=',zsig
+c            stop
+c         endif
+      enddo
+      enddo
+
+      do l=1,llm
+       do ij=iip1+iip1,ip1jm,iip1
+          u_mq(ij,l)=u_mq(ij-iim,l)
+          ladvplus(ij,l)=ladvplus(ij-iim,l)
+       enddo
+      enddo
+
+c=================================================================
+C   SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES
+c=================================================================
+c   tris des regions a traiter
+      n0=0
+      do l=1,llm
+         nl(l)=0
+         do ij=iip2,ip1jm
+            if(ladvplus(ij,l)) then
+               nl(l)=nl(l)+1
+               u_mq(ij,l)=0.
+            endif
+         enddo
+         n0=n0+nl(l)
+      enddo
+
+      if(n0.gt.1) then
+      IF (prt_level > 9) WRITE(lunout,*)
+     & 'Nombre de points pour lesquels on advect plus que le'
+     &       ,'contenu de la maille : ',n0
+
+         do l=1,llm
+            if(nl(l).gt.0) then
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               do ij=iip2,ip1jm
+                  if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then
+                     iju=iju+1
+                     indu(iju)=ij
+                  endif
+               enddo
+               niju=iju
+c              print*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               do iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  if(zu_m.gt.0.) then
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   MODIFS SPECIFIQUES DU SCHEMA
+c   ajout de la maille non completement advectee
+             zsig=zu_m/masse(ijq,l)
+             if(zsig.le.zsigd(ijq,l)) then
+                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l)
+     s          -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l)))
+             else
+c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+c         goto 8888
+                zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l)
+                if(.not.(zz.gt.0..and.zz.le.0.5)) then
+                     WRITE(lunout,*)'probleme2 au point ij=',ij,
+     s               '  l=',l
+                     WRITE(lunout,*)'zz=',zz
+                     stop
+                endif
+                u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*(
+     s          0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l)
+     s        +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) )
+             endif
+                  else
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   ajout de la maille non completement advectee
+c 2eme MODIF SPECIFIQUE
+             zsig=-zu_m/masse(ij+1,l)
+             if(zsig.le.zsigg(ijq,l)) then
+                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l)
+     s          -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l)))
+             else
+c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+c           goto 9999
+                zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l)
+                if(.not.(zz.gt.0..and.zz.le.0.5)) then
+                     WRITE(lunout,*)'probleme22 au point ij=',ij
+     s               ,'  l=',l
+                     WRITE(lunout,*)'zz=',zz
+                     stop
+                endif
+                u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*(
+     s          0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l)
+     s          +(zsig-zsigg(ijq,l))*
+     s           (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) )
+             endif
+c   fin de la modif
+                  endif
+               enddo
+            endif
+         enddo
+      endif  ! n0.gt.0 
+
+c   bouclage en latitude
+      do l=1,llm
+        do ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        enddo
+      enddo
+
+c=================================================================
+c   CALCUL DE LA CONVERGENCE DES FLUX
+c=================================================================
+
+      do l=1,llm
+         do ij=iip2+1,ip1jm
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         enddo
+c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         do ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         enddo
+      enddo
+
+      RETURN
+      END
+      SUBROUTINE advny(q,qs,qn,masse,v_m)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real masse(ip1jmp1,llm)
+      real v_m( ip1jm,llm )
+      real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real new_m,zdq,zz
+      real zsigs(ip1jmp1),zsign(ip1jmp1),zsig
+      real v_mq(ip1jm,llm)
+      real convpn,convps,convmpn,convmps,massen,masses
+      real zm,zq,zsigm,zsigp,zqm,zqp
+      real ssum
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+      do l=1,llm
+            do ij=1,ip1jmp1
+               zdq=qn(ij,l)-qs(ij,l)
+c              if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l,'  advnqx'
+c                 print*,qn(ij,l),q(ij,l),qs(ij,l)
+c                 qn(ij,l)=q(ij,l)
+c                 qs(ij,l)=q(ij,l)
+c              endif
+               if(abs(zdq).gt.prec) then
+                  zsign(ij)=(q(ij,l)-qs(ij,l))/zdq
+                  zsigs(ij)=1.-zsign(ij)
+c                 if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and.
+c    s               zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then
+c                    print*,'probleme au point ij=',ij,'  l=',l
+c                    print*,'sigs=',zsigs(ij),'  sign=',zsign(ij)
+c                    stop
+c                 endif
+               else
+                  zsign(ij)=0.5
+                  zsigs(ij)=0.5
+               endif
+            enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+       do ij=1,ip1jm
+          if (v_m(ij,l).ge.0.) then
+             zsigp=zsign(ij+iip1)
+             zsigm=zsigs(ij+iip1)
+             zqp=qn(ij+iip1,l)
+             zqm=qs(ij+iip1,l)
+             zm=masse(ij+iip1,l)
+             zq=q(ij+iip1,l)
+          else
+             zsigm=zsign(ij)
+             zsigp=zsigs(ij)
+             zqm=qn(ij,l)
+             zqp=qs(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          endif
+          zsig=abs(v_m(ij,l))/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (zsig.le.zsigp) then
+              v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+          else
+              zz=0.5*(zsig-zsigp)/zsigm
+              v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp 
+     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+          endif
+       enddo
+      enddo
+
+      do l=1,llm
+         do ij=iip2,ip1jm
+            new_m=masse(ij,l)
+     &      +v_m(ij,l)-v_m(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l))
+     &         /new_m
+            masse(ij,l)=new_m
+         enddo
+c.-. ancienne version
+         convpn=SSUM(iim,v_mq(1,l),1)
+         convmpn=ssum(iim,v_m(1,l),1)
+         massen=ssum(iim,masse(1,l),1)
+         new_m=massen+convmpn
+         q(1,l)=(q(1,l)*massen+convpn)/new_m
+         do ij = 1,iip1
+            q(ij,l)=q(1,l)
+            masse(ij,l)=new_m*aire(ij)/apoln
+         enddo
+
+         convps=-SSUM(iim,v_mq(ip1jm-iim,l),1)
+         convmps=-ssum(iim,v_m(ip1jm-iim,l),1)
+         masses=ssum(iim,masse(ip1jm+1,l),1)
+         new_m=masses+convmps
+         q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m
+         do ij = ip1jm+1,ip1jmp1
+            q(ij,l)=q(ip1jm+1,l)
+            masse(ij,l)=new_m*aire(ij)/apols
+         enddo
+      enddo
+
+      RETURN
+      END
+      SUBROUTINE advnz(q,qh,qb,masse,w_m)
+c
+c     Auteurs:   F.Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c     b designe le bas et h le haut
+c     il y a une correspondance entre le b en z et le d en x
+c    ********************************************************************
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real masse(ip1jmp1,llm)
+      real w_m( ip1jmp1,llm+1)
+      real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm)
+
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real new_m,zdq,zz
+      real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig
+      real w_mq(ip1jmp1,llm+1)
+      real zm,zq,zsigm,zsigp,zqm,zqp
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-13/
+#endif
+
+      do l=1,llm
+            do ij=1,ip1jmp1
+               zdq=qb(ij,l)-qh(ij,l)
+c              if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l
+c                 print*,qh(ij,l),q(ij,l),qb(ij,l)
+c                 qh(ij,l)=q(ij,l)
+c                 qb(ij,l)=q(ij,l)
+c              endif
+
+               if(abs(zdq).gt.prec) then
+                  zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq
+                  zsigh(ij,l)=1.-zsigb(ij,l)
+                  zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.)
+               else
+                  zsigb(ij,l)=0.5
+                  zsigh(ij,l)=0.5
+               endif
+            enddo
+       enddo
+
+c      print*,'ok1'
+c   calcul de la pente maximum dans la maille en valeur absolue
+       do l=2,llm
+       do ij=1,ip1jmp1
+          if (w_m(ij,l).ge.0.) then
+             zsigp=zsigb(ij,l)
+             zsigm=zsigh(ij,l)
+             zqp=qb(ij,l)
+             zqm=qh(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          else
+             zsigm=zsigb(ij,l-1)
+             zsigp=zsigh(ij,l-1)
+             zqm=qb(ij,l-1)
+             zqp=qh(ij,l-1)
+             zm=masse(ij,l-1)
+             zq=q(ij,l-1)
+          endif
+          zsig=abs(w_m(ij,l))/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (zsig.le.zsigp) then
+              w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+          else
+              zz=0.5*(zsig-zsigp)/zsigm
+              w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp
+     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+          endif
+      enddo
+      enddo
+
+       do ij=1,ip1jmp1
+          w_mq(ij,llm+1)=0.
+          w_mq(ij,1)=0.
+       enddo
+
+      do l=1,llm
+         do ij=1,ip1jmp1
+            new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l))
+     &         /new_m
+            masse(ij,l)=new_m
+         enddo
+      enddo
+c     print*,'ok3'
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advx.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advx.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advx.F	(revision 222)
@@ -0,0 +1,499 @@
+!
+! $Header$
+!
+      SUBROUTINE  advx(limit,dtx,pbaru,sm,s0,
+     $     sx,sy,sz,lati,latf)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (FOM) advection of tracer in X direction  C
+C                                                                C
+C  Source : Pascal Simon (Meteo,CNRM)                            C
+C  Adaptation : A.Armengaud (LGGE) juin 94                       C
+C                                                                C
+C  limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C
+C  sont des arguments d'entree pour le s-pg...                   C
+C                                                                C
+C  sm,s0,sx,sy,sz                                                C
+C  sont les arguments de sortie pour le s-pg                     C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+C  Arguments :
+C  -----------
+C  dtx : frequence fictive d'appel du transport 
+C  pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1
+
+       INTEGER ntra
+       PARAMETER (ntra = 1)
+
+C ATTENTION partout ou on trouve ntra, insertion de boucle
+C           possible dans l'avenir.
+
+      REAL dtx
+      REAL pbaru ( iip1,jjp1,llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     $    ,sy(iip1,jjp1,llm,ntra)
+      REAL sz(iip1,jjp1,llm,ntra)
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL UGRI(iip1,jjp1,llm)
+
+C  Rem : VGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en x uniquement )
+C
+C  Ti are the moments for the current latitude and level
+C
+      REAL TM(iim)
+      REAL T0(iim,ntra),TX(iim,ntra)
+      REAL TY(iim,ntra),TZ(iim,ntra)
+      REAL TEMPTM                ! just a temporary variable
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL FM(iim)
+      REAL F0(iim,ntra),FX(iim,ntra)
+      REAL FY(iim,ntra),FZ(iim,ntra)
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+C
+      REAL SMNEW(iim),UEXT(iim)
+C
+      REAL sqi,sqf
+
+      LOGICAL LIMIT
+      INTEGER NUM(jjp1),LONK,NUMK
+      INTEGER lon,lati,latf,niv
+      INTEGER i,i2,i3,j,jv,l,k,itrac 
+
+      lon = iim 
+      niv = llm 
+
+C *** Test de passage d'arguments ******
+
+
+C  -------------------------------------
+      DO 300 j = 1,jjp1 
+         NUM(j) = 1
+  300 CONTINUE
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+cIM 240305            sqi = sqi + S0(i,j,l,9)
+               sqi = sqi + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------'
+      PRINT*,'sqi=',sqi
+
+
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  ---------------------------------------------------------
+C  Conversion des flux de masses en kg/s
+C  pbaru est en N/s d'ou :
+C  ugri est en kg/s
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjm+1
+            DO 500 i = 1,iip1  
+C            ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )
+             ugri (i,j,llm+1-l) = pbaru (i,j,l)
+  500 CONTINUE
+
+
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+  
+C  start here          
+C
+C  boucle principale sur les niveaux et les latitudes
+C
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+C
+C  modifications for extended polar zones
+C
+      NUMK=NUM(K)
+      LONK=LON/NUMK
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0(I,JV)=0.
+         TX(I,JV)=0.
+         TY(I,JV)=0.
+         TZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TM(I)=TM(I)+SM(I3,K,L)
+            ALF(I)=SM(I3,K,L)/TM(I)
+            ALF1(I)=1.-ALF(I)
+ 113     CONTINUE
+C
+         DO  JV=1,NTRA
+         DO  I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)
+     $          *S0(I3,K,L,JV)
+            T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+            TX(I,JV)=ALF(I)  *sx(I3,K,L,JV)+
+     $       ALF1(I)*TX(I,JV) +3.*TEMPTM
+            TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV)
+            TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV)
+         ENDDO 
+         ENDDO
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 I=1,LON
+         T0(I,JV)=S0(I,K,L,JV)
+         TX(I,JV)=sx(I,K,L,JV)
+         TY(I,JV)=sy(I,K,L,JV)
+         TZ(I,JV)=sz(I,K,L,JV)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 13
+C
+      DO 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))
+ 120  CONTINUE
+ 12   CONTINUE
+C
+ 13   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from IP to I if U(I).lt.0
+C
+      DO 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+        FM(I)=-UEXT(I)*DTX
+        ALF(I)=FM(I)/TM(1)
+        TM(1)=TM(1)-FM(I)
+      ENDIF
+C
+C  flux from I to IP if U(I).gt.0
+C
+      DO 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) )
+           FX(I,JV)=ALFQ(I)*TX(I+1,JV)
+           FY(I,JV)=ALF (I)*TY(I+1,JV)
+           FZ(I,JV)=ALF (I)*TZ(I+1,JV)
+C
+           T0(I+1,JV)=T0(I+1,JV)-F0(I,JV)
+           TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV)
+           TY(I+1,JV)=TY(I+1,JV)-FY(I,JV)
+           TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV)
+C
+         ENDIF
+C
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 JV=1,NTRA
+C
+           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) )
+           FX (I,JV)=ALFQ(I)*TX(1,JV)
+           FY (I,JV)=ALF (I)*TY(1,JV)
+           FZ (I,JV)=ALF (I)*TZ(1,JV)
+C
+           T0(1,JV)=T0(1,JV)-F0(I,JV)
+           TX(1,JV)=ALF1Q(I)*TX(1,JV)
+           TY(1,JV)=TY(1,JV)-FY(I,JV)
+           TZ(1,JV)=TZ(1,JV)-FZ(I,JV)
+C
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) )
+           FX(I,JV)=ALFQ(I)*TX(I,JV)
+           FY(I,JV)=ALF (I)*TY(I,JV)
+           FZ(I,JV)=ALF (I)*TZ(I,JV)
+C
+           T0(I,JV)=T0(I,JV)-F0(I,JV)
+           TX(I,JV)=ALF1Q(I)*TX(I,JV)
+           TY(I,JV)=TY(I,JV)-FY(I,JV)
+           TZ(I,JV)=TZ(I,JV)-FZ(I,JV)
+C
+         ENDIF
+C
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+           T0(I,JV)=T0(I,JV)+F0(I,JV)
+           TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+           TY(I,JV)=TY(I,JV)+FY(I,JV)
+           TZ(I,JV)=TZ(I,JV)+FZ(I,JV)
+C
+         ENDIF
+C
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+           T0(I+1,JV)=T0(I+1,JV)+F0(I,JV)
+           TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM
+           TY(I+1,JV)=TY(I+1,JV)+FY(I,JV)
+           TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV)
+C
+         ENDIF
+C
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 JV=1,NTRA
+           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+           T0(1,JV)=T0(1,JV)+F0(I,JV)
+           TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+           TY(1,JV)=TY(1,JV)+FY(I,JV)
+           TZ(1,JV)=TZ(1,JV)+FZ(I,JV)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 180 I2=1,NUMK
+C
+         DO 180 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            SM(I3,K,L)=SMNEW(I3)
+            ALF(I)=SMNEW(I3)/TM(I)
+            TM(I)=TM(I)-SMNEW(I3)
+C
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1(I)=1.-ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 180     CONTINUE
+C
+         DO  JV=1,NTRA
+         DO  I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            S0(I3,K,L,JV)=ALF (I)
+     $       * (T0(I,JV)-ALF1(I)*TX(I,JV))
+            sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV)
+            sy(I3,K,L,JV)=ALF (I)*TY(I,JV)
+            sz(I3,K,L,JV)=ALF (I)*TZ(I,JV)
+C
+C   reajusts moments remaining in the box
+C
+            T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+            TX(I,JV)=ALF1Q(I)*TX(I,JV)
+            TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV)
+            TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV)
+          ENDDO
+          ENDDO
+C
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 I=1,LON
+         S0(I,K,L,JV)=T0(I,JV)
+         sx(I,K,L,JV)=TX(I,JV)
+         sy(I,K,L,JV)=TY(I,JV)
+         sz(I,K,L,JV)=TZ(I,JV)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+c OK
+c      DO 9998 l = 1, llm
+c      DO 9998 j = 1, jjp1
+c      DO 9998 i = 1, iip1
+c         IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
+c            PRINT*, '-------------------'
+c            PRINT*, 'En fin de ADVX'
+c            PRINT*,'SM(',i,j,l,')=',SM(i,j,l)
+c            PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c            print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c            print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c            print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1'
+cc            STOP
+c         ENDIF
+c 9998 CONTINUE
+c
+C ---------- bouclage cyclique 
+      DO itrac=1,ntra
+      DO l = 1,llm
+        DO j = lati,latf
+           SM(iip1,j,l) = SM(1,j,l)
+           S0(iip1,j,l,itrac) = S0(1,j,l,itrac)
+           sx(iip1,j,l,itrac) = sx(1,j,l,itrac)
+           sy(iip1,j,l,itrac) = sy(1,j,l,itrac)
+           sz(iip1,j,l,itrac) = sz(1,j,l,itrac)
+        END DO
+      END DO
+      ENDDO 
+
+c ----------- qqtite totale de traceur dans tte l'atmosphere
+      DO l = 1, llm
+        DO j = 1, jjp1
+          DO i = 1, iim
+cIM 240405          sqf = sqf + S0(i,j,l,9)
+             sqf = sqf + S0(i,j,l,ntra)
+          END DO  
+        END DO
+      END DO
+c
+      PRINT*,'------ DIAG DANS ADVX - SORTIE -----'
+      PRINT*,'sqf=',sqf
+c-------------
+
+      RETURN
+      END
+C_________________________________________________________________
+C_________________________________________________________________
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advxp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advxp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advxp.F	(revision 222)
@@ -0,0 +1,650 @@
+!
+! $Header$
+!
+       SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ
+     .                ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
+       IMPLICIT NONE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in X direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+       INTEGER ntra
+c      PARAMETER (ntra = 1)
+C
+C  definition de la grille du modele
+C
+      REAL dtx
+      REAL pbaru ( iip1,jjp1,llm )
+C
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C           Sij 2nd  order moment in i and j directions
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+      REAL SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+
+C  Local :
+C  -------
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+       REAL UGRI(iip1,jjp1,llm)
+
+C  Rem : VGRI et WGRI ne sont pas utilises dans
+C  cette subroutine ( advection en x uniquement )
+C
+C
+C  Tij are the moments for the current latitude and level
+C
+      REAL TM (iim)
+      REAL T0 (iim,NTRA),TX (iim,NTRA)
+      REAL TY (iim,NTRA),TZ (iim,NTRA)
+      REAL TXX(iim,NTRA),TXY(iim,NTRA)
+      REAL TXZ(iim,NTRA),TYY(iim,NTRA)
+      REAL TYZ(iim,NTRA),TZZ(iim,NTRA)
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL FM (iim)
+      REAL F0 (iim,NTRA),FX (iim,NTRA)
+      REAL FY (iim,NTRA),FZ (iim,NTRA)
+      REAL FXX(iim,NTRA),FXY(iim,NTRA)
+      REAL FXZ(iim,NTRA),FYY(iim,NTRA)
+      REAL FYZ(iim,NTRA),FZZ(iim,NTRA)
+C
+C  work arrays
+C
+      REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+      REAL ALF2(iim),ALF3(iim),ALF4(iim)
+C
+      REAL SMNEW(iim),UEXT(iim)
+      REAL sqi,sqf
+      REAL TEMPTM
+      REAL SLPMAX
+      REAL S1MAX,S1NEW,S2NEW
+
+      LOGICAL LIMIT
+      INTEGER NUM(jjp1),LONK,NUMK
+      INTEGER lon,lati,latf,niv
+      INTEGER i,i2,i3,j,jv,l,k,iter
+
+      lon = iim
+      lati=2
+      latf = jjm
+      niv = llm
+
+C *** Test de passage d'arguments ******
+
+c      DO 399 l = 1, llm
+c       DO 399 j = 1, jjp1
+c        DO 399 i = 1, iip1
+c         IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+c         PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c	     print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+c         print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+c         print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+c         PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
+cc            STOP
+c         ENDIF
+c  399 CONTINUE
+
+C *** Test : diagnostique de la qtite totale de traceur
+C            dans l'atmosphere avant l'advection
+c
+      sqi =0.
+      sqf =0.
+c
+      DO l = 1, llm
+      DO j = 1, jjp1
+      DO i = 1, iim
+	 sqi = sqi + S0(i,j,l,ntra)
+      END DO
+      END DO
+      END DO
+      PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
+      PRINT*,'sqi=',sqi
+c test
+c  -------------------------------------
+        DO 300 j =1,jjp1
+         NUM(j) =1 
+ 300  CONTINUE
+c       DO l=1,llm
+c      NUM(2,l)=6
+c      NUM(3,l)=6
+c      NUM(jjm-1,l)=6  
+c      NUM(jjm,l)=6
+c      ENDDO
+c        DO j=2,6
+c       NUM(j)=12
+c       ENDDO
+c       DO j=jjm-5,jjm-1 
+c       NUM(j)=12
+c       ENDDO
+
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  ---------------------------------------------------------
+C  Conversion des flux de masses en kg/s
+C  pbaru est en N/s d'ou :
+C  ugri est en kg/s
+
+       DO 500 l = 1,llm
+       DO 500 j = 1,jjp1
+       DO 500 i = 1,iip1
+       ugri (i,j,llm+1-l) =pbaru (i,j,l) 
+ 500   CONTINUE
+
+C  ---------------------------------------------------------
+C  start here
+C
+C  boucle principale sur les niveaux et les latitudes
+C     
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+C
+C  modifications for extended polar zones
+C
+      NUMK=NUM(K)
+      LONK=LON/NUMK
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0 (I,JV)=0.
+         TX (I,JV)=0.
+         TY (I,JV)=0.
+         TZ (I,JV)=0.
+         TXX(I,JV)=0.
+         TXY(I,JV)=0.
+         TXZ(I,JV)=0.
+         TYY(I,JV)=0.
+         TYZ(I,JV)=0.
+         TZZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TM(I)=TM(I)+SM(I3,K,L)
+            ALF(I)=SM(I3,K,L)/TM(I)
+            ALF1(I)=1.-ALF(I)
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+            ALF2(I)=ALF1(I)-ALF(I)
+            ALF3(I)=ALF(I)*ALF1(I)
+ 113     CONTINUE
+C
+         DO 114 JV=1,NTRA
+         DO 1140 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
+            T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+            TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV)
+     +        +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+            TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+            TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV)
+     +           +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
+            TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV)
+     +           +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
+            TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
+            TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
+            TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
+            TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
+            TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
+ 1140    CONTINUE
+ 114     CONTINUE
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 I=1,LON
+         T0 (I,JV)=S0 (I,K,L,JV)
+         TX (I,JV)=SSX (I,K,L,JV)
+         TY (I,JV)=SY (I,K,L,JV)
+         TZ (I,JV)=SZ (I,K,L,JV)
+         TXX(I,JV)=SSXX(I,K,L,JV)
+         TXY(I,JV)=SSXY(I,K,L,JV)
+         TXZ(I,JV)=SSXZ(I,K,L,JV)
+         TYY(I,JV)=SYY(I,K,L,JV)
+         TYZ(I,JV)=SYZ(I,K,L,JV)
+         TZZ(I,JV)=SZZ(I,K,L,JV)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 13
+C
+      DO 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        IF(T0(I,JV).GT.0.) THEN
+          SLPMAX=T0(I,JV)
+          S1MAX=1.5*SLPMAX
+          S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
+          S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                 AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
+          TX (I,JV)=S1NEW
+          TXX(I,JV)=S2NEW
+          TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
+          TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
+        ELSE
+          TX (I,JV)=0.
+          TXX(I,JV)=0.
+          TXY(I,JV)=0.
+          TXZ(I,JV)=0.
+        ENDIF
+ 120  CONTINUE
+ 12   CONTINUE
+C
+ 13   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from IP to I if U(I).lt.0
+C
+      DO 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+        FM(I)=-UEXT(I)*DTX
+        ALF(I)=FM(I)/TM(1)
+        TM(1)=TM(1)-FM(I)
+      ENDIF
+C
+C  flux from I to IP if U(I).gt.0
+C
+      DO 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF1(I)-ALF(I)
+         ALF3(I)=ALF(I)*ALFQ(I)
+         ALF4(I)=ALF1(I)*ALF1Q(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
+     +             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
+           FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
+           FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
+           FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
+           FYY(I,JV)=ALF (I)*TYY(I+1,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
+C
+           T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
+           TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
+           TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
+           TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
+           TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
+           TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
+           TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
+           TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
+           TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
+           TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
+C
+         ENDIF
+C
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 JV=1,NTRA
+C
+           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
+     +             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
+           FXX(I,JV)=ALF3(I)*TXX(1,JV)
+           FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
+           FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(1,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
+           FYY(I,JV)=ALF (I)*TYY(1,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(1,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(1,JV)
+C
+           T0 (1,JV)=T0(1,JV)-F0(I,JV)
+           TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
+           TXX(1,JV)=ALF4(I)*TXX(1,JV)
+           TY (1,JV)=TY (1,JV)-FY (I,JV)
+           TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
+           TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
+           TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
+           TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
+           TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
+           TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
+C
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
+     +             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
+           FXX(I,JV)=ALF3(I)*TXX(I,JV)
+           FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
+           FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(I,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
+           FYY(I,JV)=ALF (I)*TYY(I,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(I,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(I,JV)
+C
+           T0 (I,JV)=T0(I,JV)-F0(I,JV)
+           TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
+           TXX(I,JV)=ALF4(I)*TXX(I,JV)
+           TY (I,JV)=TY (I,JV)-FY (I,JV)
+           TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
+           TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
+           TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
+           TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
+           TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+           TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+C
+         ENDIF
+C
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF1(I)-ALF(I)
+         ALF3(I)=ALF(I)*ALF1(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+           T0 (I,JV)=T0(I,JV)+F0(I,JV)
+           TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV)
+     +          +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+           TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
+           TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV)
+     +          +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
+           TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV)
+     +          +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
+           TY (I,JV)=TY (I,JV)+FY (I,JV)
+           TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
+           TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
+           TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
+           TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
+C
+         ENDIF
+C
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+           T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
+           TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV)
+     +           +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+           TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
+           TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV)
+     +            +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
+           TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV)
+     +            +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
+           TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
+           TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
+           TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
+           TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
+           TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
+C
+         ENDIF
+C
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 JV=1,NTRA
+           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+           T0 (1,JV)=T0(1,JV)+F0(I,JV)
+           TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV)
+     +         +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+           TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+           TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV)
+     +          +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
+           TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV)
+     +          +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
+           TY (1,JV)=TY (1,JV)+FY (I,JV)
+           TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
+           TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
+           TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
+           TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 18 I2=1,NUMK
+C
+         DO 180 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            SM(I3,K,L)=SMNEW(I3)
+            ALF(I)=SMNEW(I3)/TM(I)
+            TM(I)=TM(I)-SMNEW(I3)
+C
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1(I)=1.-ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+            ALF2(I)=ALF1(I)-ALF(I)
+            ALF3(I)=ALF(I)*ALFQ(I)
+            ALF4(I)=ALF1(I)*ALF1Q(I)
+C
+ 180     CONTINUE
+C
+         DO 181 JV=1,NTRA
+         DO 181 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
+     +              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
+            SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
+            SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
+            SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
+            SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
+            SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
+            SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
+            SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
+            SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
+            SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
+C
+C   reajusts moments remaining in the box
+C
+            T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+            TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
+            TXX(I,JV)=ALF4 (I)*TXX(I,JV)
+            TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
+            TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
+            TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
+            TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
+            TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
+            TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+            TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+C
+ 181     CONTINUE
+C
+ 18   CONTINUE
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 I=1,LON
+         S0 (I,K,L,JV)=T0 (I,JV)
+         SSX (I,K,L,JV)=TX (I,JV)
+         SY (I,K,L,JV)=TY (I,JV)
+         SZ (I,K,L,JV)=TZ (I,JV)
+         SSXX(I,K,L,JV)=TXX(I,JV)
+         SSXY(I,K,L,JV)=TXY(I,JV)
+         SSXZ(I,K,L,JV)=TXZ(I,JV)
+         SYY(I,K,L,JV)=TYY(I,JV)
+         SYZ(I,K,L,JV)=TYZ(I,JV)
+         SZZ(I,K,L,JV)=TZZ(I,JV)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+
+c      DO 9999 l = 1, llm
+c      DO 9999 j = 1, jjp1
+c      DO 9999 i = 1, iip1
+c	   IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
+c           PRINT*, '-------------------'
+c	        PRINT*, 'En fin de ADVXP'
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c	        print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+c           print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+c       	print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
+c            STOP
+c           ENDIF
+c 9999 CONTINUE
+c ---------- bouclage cyclique
+
+      DO l = 1,llm
+      DO j = 1,jjp1
+         SM(iip1,j,l) = SM(1,j,l)
+         S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+     	 SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+    	 SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+    	 SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+      END DO
+      END DO
+
+C ----------- qqtite totale de traceur dans tte l'atmosphere
+      DO l = 1, llm
+      DO j = 1, jjp1
+      DO i = 1, iim
+        sqf = sqf + S0(i,j,l,ntra)
+      END DO
+      END DO
+      END DO
+
+      PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
+      PRINT*,'sqf=',sqf
+c-------------------------------------------------------------
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advy.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advy.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advy.F	(revision 222)
@@ -0,0 +1,422 @@
+!
+! $Header$
+!
+      SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (SOM) advection of tracer in Y direction  C
+C                                                                C
+C  Source : Pascal Simon ( Meteo, CNRM )			 C
+C  Adaptation : A.A. (LGGE) 					 C
+C  Derniere Modif : 15/12/94 LAST
+C								 C
+C  sont les arguments d'entree pour le s-pg			 C
+C								 C
+C  argument de sortie du s-pg					 C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation 
+C
+C  parametres principaux du modele
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+ 
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,kp,l
+      INTEGER ntra
+      PARAMETER (ntra = 1)
+
+      REAL dty
+      REAL pbarv ( iip1,jjm, llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     +    ,sy(iip1,jjp1,llm,ntra)
+     +    ,sz(iip1,jjp1,llm,ntra)
+
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL VGRI(iip1,0:jjp1,llm)
+
+C  Rem : UGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en y uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+      REAL FZ(iim,jjm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+      REAL TEMPTM          ! Just temporal variable
+c
+C  Special pour poles 
+c
+      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
+      REAL sns0(ntra),snsz(ntra),snsm
+      REAL s1v(llm),slatv(llm)
+      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+      REAL cx1(llm,ntra), cxLAT(llm,ntra)
+      REAL cy1(llm,ntra), cyLAT(llm,ntra)
+      REAL z1(iim), zcos(iim), zsin(iim)
+      real smpn,smps,s0pn,s0ps
+      REAL SSUM
+      EXTERNAL SSUM
+C
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv=llm
+
+C
+C  the moments Fi are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+
+      DO l = 1,llm
+         DO j = 1,jjm
+            DO i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)  
+            enddo
+         enddo
+         do i=1,iip1
+             vgri(i,0,l) = 0.
+             vgri(i,jjp1,l) = 0.
+         enddo
+      enddo
+
+      DO 1 L=1,NIV
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 11
+C
+      DO 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
+     +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+           FM(I,0)=-VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+           SM(I,1,L)=SM(I,1,L)-FM(I,0)
+           SM0=SM0+FM(I,0)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+C
+ 21   CONTINUE
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+C
+           F0(I,0,JV)=ALF(I,0)*
+     +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
+C
+           S00(JV)=S00(JV)+F0(I,0,JV)
+           S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+           sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
+           sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
+           sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
+C
+         ENDIF
+C
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+           SM(I,1,L)=SM(I,1,L)+FM(I,0)
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+         ENDIF
+C
+         ALF1(I,0)=1.-ALF(I,0)
+C
+ 25   CONTINUE
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+C
+         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+         S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+         sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
+C
+         ENDIF
+C
+ 260  CONTINUE
+ 26   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+         ELSE
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+C
+ 300  CONTINUE
+ 30   CONTINUE
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+           F0(I,K,JV)=ALF (I,K)*
+     +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
+           FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
+           FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
+           FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
+C
+           S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+           sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
+           sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
+           sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
+C
+         ELSE
+C
+           F0(I,K,JV)=ALF (I,K)*
+     +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+           FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
+           FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
+           FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
+C
+           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
+           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
+           sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
+C
+         ENDIF
+C
+ 310  CONTINUE
+ 31   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ELSE
+           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+         ENDIF
+C
+         ALF1(I,K)=1.-ALF(I,K)
+C
+ 320  CONTINUE
+ 32   CONTINUE
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV)
+     +               +3.*TEMPTM
+         sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
+         sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
+C
+         ELSE
+C
+         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+         S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+         sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV)
+     +                +3.*TEMPTM
+         sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
+         sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
+C
+         ENDIF
+C
+ 330  CONTINUE
+ 33   CONTINUE
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+           SM0=SM0+FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+C
+ 41   CONTINUE
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           F0 (I,K,JV)=ALF(I,K)*
+     +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+           S00(JV)=S00(JV)+F0(I,K,JV)
+C
+           S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+           sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
+           sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
+         ENDIF
+C
+ 420  CONTINUE
+ 42   CONTINUE
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ENDIF
+C
+         ALF1(I,K)=1.-ALF(I,K)
+C
+ 45   CONTINUE
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
+C
+         ENDIF
+C
+ 460  CONTINUE
+ 46   CONTINUE
+C
+ 1    CONTINUE
+C
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advyp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advyp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advyp.F	(revision 222)
@@ -0,0 +1,653 @@
+!
+! $Header$
+!
+      SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
+     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+      IMPLICIT NONE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in Y direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  Source : Pascal Simon ( Meteo, CNRM )			 C
+C  Adaptation : A.A. (LGGE) 					 C
+C  Derniere Modif : 19/10/95 LAST
+C								 C
+C  sont les arguments d'entree pour le s-pg			 C
+C								 C
+C  argument de sortie du s-pg					 C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation 
+C
+C  parametres principaux du modele
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+ 
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,kp,l
+      INTEGER ntra
+C      PARAMETER (ntra = 1)
+
+      REAL dty
+      REAL pbarv ( iip1,jjm, llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+     +    ,SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+C
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL VGRI(iip1,0:jjp1,llm)
+
+C  Rem : UGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en y uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+C  the moments Fij are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+C
+      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+      REAL FZ(iim,jjm,ntra)
+      REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
+      REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
+      REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+      REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
+      REAL ALF4(iim,0:jjp1)
+      REAL TEMPTM          ! Just temporal variable
+      REAL SLPMAX,S1MAX,S1NEW,S2NEW
+c
+C  Special pour poles 
+c
+      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
+      REAL sns0(ntra),snsz(ntra),snsm
+      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+      REAL cx1(llm,ntra), cxLAT(llm,ntra)
+      REAL cy1(llm,ntra), cyLAT(llm,ntra)
+      REAL z1(iim), zcos(iim), zsin(iim)
+      REAL SSUM
+      EXTERNAL SSUM
+C
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv = llm         !       tab. S et VGRI 
+                    
+c-----------------------------------------------------------------
+C initialisations
+
+      sbms = 0.
+      sfms = 0.
+      sfzs = 0.
+      sbmn = 0.
+      sfmn = 0.
+      sfzn = 0.
+
+c-----------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+c 
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqi = sqi + S0(i,j,l,ntra)
+           END DO
+         END DO
+      END DO
+      PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
+      PRINT*,'sqi=',sqi
+
+c-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion des flux de masses en kg
+C-AA 20/10/94  le signe -1 est necessaire car indexation opposee
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjm
+            DO 500 i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
+  500 CONTINUE
+
+CAA Initialisation de flux fictifs aux bords sup. des boites pol.
+
+      DO l = 1,llm
+         DO i = 1,iip1  
+             vgri(i,0,l) = 0.
+             vgri(i,jjp1,l) = 0.
+         ENDDO
+      ENDDO
+c
+c----------------- START HERE -----------------------
+C  boucle sur les niveaux
+C
+      DO 1 L=1,NIV
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 11
+C
+      DO 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         IF(S0(I,K,L,JV).GT.0.) THEN
+           SLPMAX=AMAX1(S0(I,K,L,JV),0.)
+           S1MAX=1.5*SLPMAX
+           S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
+           S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                  AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
+           SY (I,K,L,JV)=S1NEW
+           SYY(I,K,L,JV)=S2NEW
+       SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
+       SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+         ELSE
+           SY (I,K,L,JV)=0.
+           SYY(I,K,L,JV)=0.
+           SSXY(I,K,L,JV)=0.
+           SYZ(I,K,L,JV)=0.
+         ENDIF
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+           FM(I,0)=-VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+           SM(I,1,L)=SM(I,1,L)-FM(I,0)
+           SM0=SM0+FM(I,0)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+         ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
+         ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
+C
+ 21   CONTINUE
+c     print*,'ADVYP 21'
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+C
+           F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
+     +        ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
+C
+           S00(JV)=S00(JV)+F0(I,0,JV)
+           S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+           SY (I,1,L,JV)=ALF1Q(I,0)*
+     +            (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
+           SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
+           SSX (I,1,L,JV)=ALF1 (I,0)*
+     +            (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
+           SZ (I,1,L,JV)=ALF1 (I,0)*
+     +            (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
+           SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
+           SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
+           SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
+           SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
+           SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
+C
+         ENDIF
+C
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+c     print*,'av ADVYP 25'
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+           SM(I,1,L)=SM(I,1,L)+FM(I,0)
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+         ALF3(I,0)=ALF1(I,0)*ALF(I,0)
+C
+ 25   CONTINUE
+c     print*,'av ADVYP 25'
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+C
+         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+         S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+         SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
+     +        +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
+         SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
+      SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
+      SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
+C
+         ENDIF
+C
+ 260  CONTINUE
+ 26   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+c     print*,'av ADVYP 30'
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+         ELSE
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+C
+ 300  CONTINUE
+ 30   CONTINUE
+c     print*,'ap ADVYP 30'
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+           F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
+     +        ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
+           FY (I,K,JV)=ALFQ(I,K)*
+     +                 (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
+           FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
+           FX (I,K,JV)=ALF (I,K)*
+     +                 (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
+           FZ (I,K,JV)=ALF (I,K)*
+     +                 (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
+           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
+           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
+           FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
+           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
+           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
+C
+           S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+           SY (I,KP,L,JV)=ALF1Q(I,K)*
+     +                 (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
+           SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
+           SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
+           SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
+           SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
+           SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
+           SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
+           SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
+           SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
+C
+         ELSE
+C
+           F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
+     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+           FY (I,K,JV)=ALFQ(I,K)*
+     +                 (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
+           FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
+      FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
+      FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
+           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
+           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
+           FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
+           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
+           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           SY (I,K,L,JV)=ALF1Q(I,K)*
+     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+           SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
+           SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
+           SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
+           SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
+           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+C
+         ENDIF
+C
+ 310  CONTINUE
+ 31   CONTINUE
+c     print*,'ap ADVYP 31'
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ELSE
+           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+C
+ 320  CONTINUE
+ 32   CONTINUE
+c     print*,'ap ADVYP 32'
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+       SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV)
+     +  +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
+         SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV)
+     +            +3.*TEMPTM
+       SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV)
+     +         +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
+       SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV)
+     +         +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
+         SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
+         SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
+         SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
+         SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
+         SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
+C
+         ELSE
+C
+         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+         S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+       SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV)
+     +  +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
+         SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV)
+     +                 +3.*TEMPTM
+       SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV)
+     +             +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
+         SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV)
+     +             +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
+         SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
+         SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
+         SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
+         SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
+         SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
+C
+         ENDIF
+C
+ 330  CONTINUE
+ 33   CONTINUE
+c     print*,'ap ADVYP 33'
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+           SM0=SM0+FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+C
+ 41   CONTINUE
+c     print*,'ap ADVYP 41'
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
+     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+           S00(JV)=S00(JV)+F0(I,K,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           SY (I,K,L,JV)=ALF1Q(I,K)*
+     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+           SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
+      SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
+      SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
+           SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
+           SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
+           SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
+           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+         ENDIF
+C
+ 420  CONTINUE
+ 42   CONTINUE
+c     print*,'ap ADVYP 42'
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+c     print*,'ap ADVYP 43'
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+C
+ 45   CONTINUE
+c     print*,'ap ADVYP 45'
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
+     +           +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
+         SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
+      SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
+      SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
+C
+         ENDIF
+C
+ 460  CONTINUE
+ 46   CONTINUE
+c     print*,'ap ADVYP 46'
+C
+ 1    CONTINUE
+
+c--------------------------------------------------
+C     bouclage cyclique horizontal .
+     
+      DO l = 1,llm
+         DO jv = 1,ntra
+            DO j = 1,jjp1
+               SM(iip1,j,l) = SM(1,j,l)
+               S0(iip1,j,l,jv) = S0(1,j,l,jv)
+               SSX(iip1,j,l,jv) = SSX(1,j,l,jv)   
+               SY(iip1,j,l,jv) = SY(1,j,l,jv)
+               SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
+            END DO
+         END DO
+      END DO
+
+c -------------------------------------------------------------------
+C *** Test  negativite:
+
+c      DO jv = 1,ntra
+c       DO l = 1,llm
+c         DO j = 1,jjp1
+c           DO i = 1,iip1
+c              IF (s0( i,j,l,jv ).lt.0.) THEN
+c                 PRINT*, '------ S0 < 0 en FIN ADVYP ---'
+c                 PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
+cc                 STOP
+c              ENDIF
+c           ENDDO
+c         ENDDO
+c       ENDDO
+c      ENDDO
+ 
+   
+c -------------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+ 
+       DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqf = sqf + S0(i,j,l,ntra)
+           END DO
+         END DO
+       END DO
+      PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
+      PRINT*,'sqf=',sqf
+c     print*,'ap ADVYP fin'
+
+c-----------------------------------------------------------------
+C
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advz.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advz.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advz.F	(revision 222)
@@ -0,0 +1,322 @@
+!
+! $Header$
+!
+      SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (FOM) advection of tracer in Z direction  C
+C                                                                C
+C  Source : Pascal Simon (Meteo,CNRM)                            C
+C  Adaptation : A.Armengaud (LGGE) juin 94                       C
+C                                                                C
+C                                                                C
+C  sont des arguments d'entree pour le s-pg...                   C
+C                                                                C
+C  dq est l'argument de sortie pour le s-pg                      C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+C    #include "traceur.h"
+
+C  Arguments :
+C  -----------
+C  dtz : frequence fictive d'appel du transport 
+C  w : flux de masse en z en Pa.m2.s-1
+
+      INTEGER ntra
+      PARAMETER (ntra = 1)
+
+      REAL dtz
+      REAL w ( iip1,jjp1,llm )
+    
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     +    ,sy(iip1,jjp1,llm,ntra)
+     +    ,sz(iip1,jjp1,llm,ntra)
+
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL WGRI(iip1,jjp1,0:llm)
+
+C
+C  the moments F are used as temporary  storage for 
+C  portions of grid boxes in transit at the current latitude
+C
+      REAL FM(iim,llm)
+      REAL F0(iim,llm,ntra),FX(iim,llm,ntra)
+      REAL FY(iim,llm,ntra),FZ(iim,llm,ntra)
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+      REAL TEMPTM            ! Just temporal variable
+      REAL sqi,sqf
+C
+      LOGICAL LIMIT
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,l,lp
+
+      lon = iim
+      lat = jjp1
+      niv = llm 
+
+C *** Test de passage d'arguments ******
+ 
+c     DO 399 l = 1, llm
+c     DO 399 j = 1, jjp1
+c     DO 399 i = 1, iip1
+c        IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c           print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c           print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c           print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c           PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
+c            STOP
+c        ENDIF
+  399 CONTINUE
+
+C-----------------------------------------------------------------
+C *** Test : diag de la qqtite totale de traceur 
+C            dans l'atmosphere avant l'advection en z
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+cIM 240305            sqi = sqi + S0(i,j,l,9)
+               sqi = sqi + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
+      PRINT*,'sqi=',sqi
+
+C-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion du flux de masse en kg.s-1
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+c            wgri (i,j,llm+1-l) =  w (i,j,l) / g 
+               wgri (i,j,llm+1-l) =  w (i,j,l) 
+c             wgri (i,j,0) = 0.                ! a detruire ult.
+c             wgri (i,j,l) = 0.1               !    w (i,j,l) 
+c             wgri (i,j,llm) = 0.              ! a detruire ult.
+  500 CONTINUE
+         DO  j = 1,jjp1
+            DO i = 1,iip1  
+               wgri(i,j,0)=0.
+            enddo
+         enddo
+
+C-----------------------------------------------------------------
+  
+C  start here          
+C  boucle sur les latitudes
+C
+      DO 1 K=1,LAT
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 101
+C
+      DO 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
+     +                              ABS(sz(I,K,L,JV))),sz(I,K,L,JV))
+ 100     CONTINUE
+ 10   CONTINUE
+C
+ 101  CONTINUE
+C
+C  boucle sur les niveaux intercouches de 1 a NIV-1
+C   (flux nul au sommet L=0 et a la base L=NIV)
+C
+C  calculate flux and moments between adjacent boxes
+C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+      DO 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           FM(I,L)=-WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+         ELSE
+           FM(I,L)=WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,L)
+         ENDIF
+C
+         ALFQ (I)=ALF(I)*ALF(I)
+         ALF1 (I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) )
+           FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
+           FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
+           FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
+C
+           S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
+           sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
+           sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
+           sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
+C
+         ELSE
+C
+           F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) )
+           FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
+           FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
+           FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
+C
+           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
+           sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
+           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
+           sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
+C
+         ENDIF
+C
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,L)
+         ELSE
+           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+         ENDIF
+C
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+           sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM
+           sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
+           sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
+C
+         ELSE
+C
+           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+           S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+           sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV)
+     +                  +3.*TEMPTM
+           sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
+           sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
+C
+         ENDIF
+C
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+C
+C-------------------------------------------------------------
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+
+c     DO 9999 l = 1, llm
+c     DO 9999 j = 1, jjp1
+c     DO 9999 i = 1, iip1
+c        IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
+c           PRINT*, '-------------------'
+c           PRINT*, 'En fin de ADVZ'
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c           print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c           print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c           print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c           WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1'
+c            STOP
+c        ENDIF
+ 9999 CONTINUE
+
+C *** ------------------- bouclage cyclique  en X ------------
+      
+c      DO l = 1,llm
+c         DO j = 1,jjp1
+c            SM(iip1,j,l) = SM(1,j,l)
+c            S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+C            sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
+c            sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
+c            sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
+c         ENDDO
+c      ENDDO
+           
+C-------------------------------------------------------------
+C *** Test : diag de la qqtite totale de traceur 
+C            dans l'atmosphere avant l'advection en z
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+cIM 240305            sqf = sqf + S0(i,j,l,9)
+               sqf = sqf + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+      PRINT*,'sqf=', sqf
+
+C-------------------------------------------------------------
+      RETURN
+      END
+C_______________________________________________________________
+C_______________________________________________________________
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advzp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advzp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/advzp.F	(revision 222)
@@ -0,0 +1,378 @@
+!
+! $Header$
+!
+      SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ
+     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in Z direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  Source : Pascal Simon ( Meteo, CNRM )                          C
+C  Adaptation : A.A. (LGGE)                                       C
+C  Derniere Modif : 19/11/95 LAST                                 C
+C                                                                 C
+C  sont les arguments d'entree pour le s-pg                       C
+C                                                                 C
+C  argument de sortie du s-pg                                     C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation
+C
+
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+C
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+c
+        INTEGER lon,lat,niv
+        INTEGER i,j,jv,k,kp,l,lp
+        INTEGER ntra
+c        PARAMETER (ntra = 1)
+c
+        REAL dtz
+        REAL w ( iip1,jjp1,llm )
+c
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+     +    ,SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+C
+C  Local :
+C  -------
+C
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+C
+      REAL WGRI(iip1,jjp1,0:llm)
+
+C Rem : UGRI et VGRI ne sont pas utilises dans
+C  cette subroutine ( advection en z uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C         attention a celui de WGRI
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+C  the moments Fij are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+C
+      REAL F0(iim,llm,ntra),FM(iim,llm)
+      REAL FX(iim,llm,ntra),FY(iim,llm,ntra)
+      REAL FZ(iim,llm,ntra)
+      REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra)
+      REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
+      REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim)
+      REAL ALFQ(iim),ALF1Q(iim)
+      REAL ALF2(iim),ALF3(iim)
+      REAL ALF4(iim)
+      REAL TEMPTM          ! Just temporal variable
+      REAL SLPMAX,S1MAX,S1NEW,S2NEW
+c
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv = llm         !       tab. S et VGRI 
+                    
+c-----------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+c 
+      sqi = 0.
+      sqf = 0.
+c
+      DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqi = sqi + S0(i,j,l,ntra)
+           END DO
+         END DO
+      END DO
+      PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
+      PRINT*,'sqi=',sqi
+
+c-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion des flux de masses en kg
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+            wgri (i,j,llm+1-l) = w (i,j,l)  
+  500 CONTINUE
+      do j=1,jjp1
+         do i=1,iip1
+            wgri(i,j,0)=0.
+         enddo
+      enddo
+c
+cAA rem : Je ne suis pas sur du signe  
+cAA       Je ne suis pas sur pour le 0:llm
+c
+c-----------------------------------------------------------------
+C---------------------- START HERE -------------------------------
+C
+C  boucle sur les latitudes
+C
+      DO 1 K=1,LAT
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 101
+C
+      DO 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            IF(S0(I,K,L,JV).GT.0.) THEN
+              SLPMAX=S0(I,K,L,JV)
+              S1MAX =1.5*SLPMAX
+              S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
+              S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                     AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
+              SZ (I,K,L,JV)=S1NEW
+              SZZ(I,K,L,JV)=S2NEW
+              SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
+              SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+            ELSE
+              SZ (I,K,L,JV)=0.
+              SZZ(I,K,L,JV)=0.
+              SSXZ(I,K,L,JV)=0.
+              SYZ(I,K,L,JV)=0.
+            ENDIF
+ 100     CONTINUE
+ 10   CONTINUE
+C
+ 101  CONTINUE
+C
+C  boucle sur les niveaux intercouches de 1 a NIV-1
+C   (flux nul au sommet L=0 et a la base L=NIV)
+C
+C  calculate flux and moments between adjacent boxes
+C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+      DO 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           FM(I,L)=-WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+         ELSE
+           FM(I,L)=WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,L)
+         ENDIF
+C
+         ALFQ (I)=ALF(I)*ALF(I)
+         ALF1 (I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2 (I)=ALF1(I)-ALF(I)
+         ALF3 (I)=ALF(I)*ALFQ(I)
+         ALF4 (I)=ALF1(I)*ALF1Q(I)
+C
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)*
+     +          ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
+           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
+           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
+           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
+           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
+           FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
+           FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
+           FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
+           FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
+           FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
+C
+           S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
+           SZ (I,K,LP,JV)=ALF1Q(I)
+     +                   *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
+           SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
+           SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
+           SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
+           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
+           SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
+           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
+           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
+           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
+C
+         ELSE
+C
+           F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV)
+     +           +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
+           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
+           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
+           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
+           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
+           FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
+           FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
+           FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
+           FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
+           FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
+           SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
+           SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
+           SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
+           SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
+           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
+           SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
+C
+         ENDIF
+C
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,L)
+         ELSE
+           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+         ENDIF
+C
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF(I)*ALF1(I)
+         ALF3(I)=ALF1(I)-ALF(I)
+C
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+           S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+           SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV)
+     +        +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
+           SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV)
+     +                  +3.*TEMPTM
+           SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV)
+     +              +3.*(ALF1(I)*FX (I,L,JV)-ALF  (I)*SSX (I,K,L,JV))
+           SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV)
+     +              +3.*(ALF1(I)*FY (I,L,JV)-ALF  (I)*SY (I,K,L,JV))
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
+           SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
+           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
+           SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
+C
+         ELSE
+C
+           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+           S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+           SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV)
+     +        +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
+           SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV)
+     +                   +3.*TEMPTM
+           SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV)
+     +                   +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
+           SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV)
+     +                   +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
+           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
+           SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
+           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
+           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
+           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
+C
+         ENDIF
+C
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+C
+      DO l = 1,llm
+      DO j = 1,jjp1
+          SM(iip1,j,l) = SM(1,j,l)
+	  S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+          SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+	  SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+          SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+      ENDDO
+      ENDDO
+c										C-------------------------------------------------------------
+C *** Test : diag de la qqtite totale de tarceur
+C            dans l'atmosphere avant l'advection en z
+       DO l = 1,llm
+       DO j = 1,jjp1
+       DO i = 1,iim
+          sqf = sqf + S0(i,j,l,ntra)
+       ENDDO
+       ENDDO
+       ENDDO
+       PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+       PRINT*,'sqf=', sqf
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/bernoui.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/bernoui.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/bernoui.F	(revision 222)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c     calcul de la fonction de Bernouilli aux niveaux s  .....
+c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
+c                              energ.cinet.)
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Decalrations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+c
+c   Arguments:
+c   ----------
+c
+      INTEGER nlay,ngrid
+      REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay)
+c
+c   Local:
+c   ------
+c
+      INTEGER   ijl
+c
+c-----------------------------------------------------------------------
+c   calcul de Bernouilli:
+c   ---------------------
+c
+      DO 4 ijl = 1,ngrid*nlay
+         pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
+   4  CONTINUE
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+      CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/clesph0.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/clesph0.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/clesph0.h	(revision 222)
@@ -0,0 +1,13 @@
+!
+! $Header$
+!
+! NE SERT A RIEN !! A VIRER... PAS A JOUR !!!
+
+c..include clesph0.h
+c
+       COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr ,
+     ,                ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con
+c
+       LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/coefpoly.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/coefpoly.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/coefpoly.F	(revision 222)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 ,
+     ,                                          a0,a1,a2,a3         )
+      IMPLICIT NONE
+c
+c   ...  Auteur :   P. Le Van  ...
+c
+c
+c    Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui
+c      satisfait aux 4 equations  suivantes :
+
+c    a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1
+c    a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2
+c               a1  +     2.*a2*xtild1 +     3.*a3*xtild1*xtild1 = Xprim1
+c               a1  +     2.*a2*xtild2 +     3.*a3*xtild2*xtild2 = Xprim2
+
+c  On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3
+
+      REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi 
+      REAL(KIND=8) Xfout, Xprim
+      REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car
+
+      xtil1car = xtild1 * xtild1
+      xtil2car = xtild2 * xtild2 
+
+      derr= 2. *(Xf2-Xf1)/( xtild1-xtild2)
+
+      x1x2car = ( xtild1-xtild2)*(xtild1-xtild2)
+
+      a3 = (derr + Xprim1+Xprim2 )/x1x2car
+      a2     = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) )    /
+     /           (  2.* ( xtild1 - xtild2 )  )
+
+      a1     = Xprim1 -3.* a3 * xtil1car     -2.* a2 * xtild1
+      a0     =  Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/com_io_dyn_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/com_io_dyn_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/com_io_dyn_mod.F90	(revision 222)
@@ -0,0 +1,31 @@
+!
+! $Id $
+!
+module com_io_dyn_mod
+
+  implicit none 
+
+! Names of various files for outputs (in the dynamics)
+  ! to store instantaneous values:
+  character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid
+  character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid
+  character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid
+
+  ! to store averaged values:
+  character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc"
+  character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc"
+  character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc"
+  
+! Ids of various files for outputs (in the dynamics)
+
+  ! instantaneous (these are set by inithist.F)
+  integer :: histid
+  integer :: histvid
+  integer :: histuid
+  
+  ! averages (these are set by initdynav.F)
+  integer :: histaveid
+  integer :: histvaveid
+  integer :: histuaveid
+  
+end module com_io_dyn_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comconst.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comconst.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comconst.h	(revision 222)
@@ -0,0 +1,45 @@
+!
+! $Id: comconst.h 1437 2010-09-30 08:29:10Z emillour $
+!
+!-----------------------------------------------------------------------
+! INCLUDE comconst.h
+
+      COMMON/comconsti/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl,          &
+     &                 iflag_top_bound,mode_top_bound
+      COMMON/comconstr/dtvr,daysec,                                     &
+     & pi,dtphys,dtdiss,rad,r,kappa,cotot,unsim,g,omeg                  &
+     & ,dissip_fac_mid,dissip_fac_up,dissip_deltaz,dissip_hdelta        &
+     & ,dissip_pupstart  ,tau_top_bound,                                &
+     & daylen,molmass, ihf
+      COMMON/cpdetvenus/cpp,nu_venus,t0_venus
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr ! dynamical time step (in s)
+      REAL daysec !length (in s) of a standard day
+      REAL pi    ! something like 3.14159....
+      REAL dtphys ! (s) time step for the physics
+      REAL dtdiss ! (s) time step for the dissipation
+      REAL rad ! (m) radius of the planet
+      REAL r ! Reduced Gas constant r=R/mu
+             ! with R=8.31.. J.K-1.mol-1, mu: mol mass of atmosphere (kg/mol)
+      REAL cpp   ! Cp
+      REAL kappa ! kappa=R/Cp 
+      REAL cotot
+      REAL unsim ! = 1./iim
+      REAL g ! (m/s2) gravity
+      REAL omeg ! (rad/s) rotation rate of the planet
+! Dissipation factors, for Earth model:
+      REAL dissip_factz,dissip_zref !dissip_deltaz
+! Dissipation factors, for other planets:
+      REAL dissip_fac_mid,dissip_fac_up,dissip_deltaz,dissip_hdelta
+      REAL dissip_pupstart
+      INTEGER iflag_top_bound,mode_top_bound
+      REAL tau_top_bound
+      REAL daylen ! length of solar day, in 'standard' day length
+      REAL molmass ! (g/mol) molar mass of the atmosphere
+
+      REAL nu_venus,t0_venus ! coeffs needed for Cp(T), Venus atmosphere
+      REAL ihf  ! (W/m2) intrinsic heat flux for giant planets
+
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissip.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissip.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissip.h	(revision 222)
@@ -0,0 +1,15 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE comdissip.h
+
+      COMMON/comdissip/                                                 &
+     &    niterdis,coefdis,tetavel,tetatemp,gamdissip
+
+
+      INTEGER niterdis
+
+      REAL tetavel,tetatemp,coefdis,gamdissip
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissipn.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissipn.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissipn.h	(revision 222)
@@ -0,0 +1,20 @@
+!
+! $Header$
+!
+!  Attention : ce fichier include est compatible format fixe/format libre
+!                 veillez Ã  n'utiliser que des ! pour les commentaires
+!                 et Ã  bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!-----------------------------------------------------------------------
+! INCLUDE comdissipn.h
+
+      REAL  tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
+!
+      COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm)   ,     &
+     &                        cdivu,      crot,         cdivh
+
+!
+!    Les parametres de ce common proviennent des calculs effectues dans 
+!             Inidissip  .
+!
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissnew.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissnew.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comdissnew.h	(revision 222)
@@ -0,0 +1,31 @@
+!
+! $Id: comdissnew.h 1319 2010-02-23 21:29:54Z fairhead $
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'comdissnew.h'
+
+      COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv,  &
+     &                   tetagrot,tetatemp,coefdis, vert_prof_dissip
+
+      LOGICAL lstardis
+      INTEGER nitergdiv, nitergrot, niterh
+
+! For the Earth model:
+      integer vert_prof_dissip ! vertical profile of horizontal dissipation
+!     Allowed values:
+!     0: rational fraction, function of pressure
+!     1: tanh of altitude
+
+      REAL     tetagdiv, tetagrot,  tetatemp, coefdis
+
+!
+! ... Les parametres de ce common comdissnew sont  lues par defrun_new 
+!              sur le fichier  run.def    ....
+!
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comgeom.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comgeom.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comgeom.h	(revision 222)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+!CDK comgeom
+      COMMON/comgeom/                                                   &
+     & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),             &
+     & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),                  &
+     & airev(ip1jm),unsaire(ip1jmp1),apoln,apols,                       &
+     & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),                 &
+     & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),              &
+     & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),                &
+     & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),               &
+     & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),           &
+     & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),            &
+     & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),         &
+     & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),           &
+     & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),                           &
+     & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),         &
+     & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,                 &
+     & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),    &
+     & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+!
+        REAL                                                            &
+     & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,&
+     & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,&
+     & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,&
+     & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,&
+     & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2&
+     & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,&
+     & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu&
+     & , xprimv
+!
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comgeom2.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comgeom2.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comgeom2.h	(revision 222)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+!CDK comgeom2
+      COMMON/comgeom/                                                   &
+     & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm)  , &
+     & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1)           , &
+     & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols                 , &
+     & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm)       , &
+     & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1)       , &
+     & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1)         , &
+     & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1)        , &
+     & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1)    , &
+     & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm),      &
+     & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm)  , &
+     & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1)                        , &
+     & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), &
+     & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , &
+     & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2                , &
+     & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1)                  , &
+     & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm)  &
+     & , xprimu(iip1),xprimv(iip1)
+
+
+      REAL                                                               &
+     & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire &
+     & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4     , &
+     & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , &
+     & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     , &
+     & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1           , &
+     & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2     , &
+     & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu    , &
+     & cusurcvu,xprimu,xprimv
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comuforc_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comuforc_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comuforc_h.F90	(revision 222)
@@ -0,0 +1,7 @@
+       module comuforc_h
+       IMPLICIT NONE
+       REAL,ALLOCATABLE,DIMENSION(:,:) :: uforc
+       REAL :: facwind
+       end module comuforc_h
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comvert.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comvert.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/comvert.h	(revision 222)
@@ -0,0 +1,38 @@
+!
+! $Id: comvert.h 1654 2012-09-24 15:07:18Z aslmd $
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'comvert.h'
+
+      COMMON/comvertr/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm),     &
+     &               pa,preff,nivsigs(llm),nivsig(llm+1),               &
+     &               aps(llm),bps(llm),scaleheight,pseudoalt(llm)
+
+      common/comverti/disvert_type, pressure_exner
+
+      real ap     ! hybrid pressure contribution at interlayers
+      real bp     ! hybrid sigma contribution at interlayer
+      real presnivs ! (reference) pressure at mid-layers
+      real dpres
+      real pa     ! reference pressure (Pa) at which hybrid coordinates
+                  ! become purely pressure
+      real preff  ! reference surface pressure (Pa)
+      real nivsigs
+      real nivsig
+      real aps    ! hybrid pressure contribution at mid-layers
+      real bps    ! hybrid sigma contribution at mid-layers
+      real scaleheight ! atmospheric (reference) scale height (km)
+      real pseudoalt ! pseudo-altitude of model levels (km), based on presnivs(),
+                     ! preff and scaleheight
+
+      integer disvert_type ! type of vertical discretization:
+                           ! 1: Earth (default for planet_type==earth),
+                           !     automatic generation
+                           ! 2: Planets (default for planet_type!=earth),
+                           !     using 'z2sig.def' (or 'esasig.def) file
+
+      logical pressure_exner
+!     compute pressure inside layers using Exner function, else use mean
+!     of pressure values at interfaces
+
+ !-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/conf_planete.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/conf_planete.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/conf_planete.F90	(revision 222)
@@ -0,0 +1,76 @@
+!
+! $Id$
+!
+SUBROUTINE conf_planete
+!
+#ifdef CPP_IOIPSL
+USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+USE ioipsl_getincom
+#endif
+IMPLICIT NONE
+!
+!
+!   Declarations :
+!   --------------
+#include "dimensions.h"
+#include "comconst.h"
+#include "comvert.h"
+!
+!   local:
+!   ------
+
+real :: year_day_dyn
+
+! ---------------------------------------------
+! Initialisations de constantes de la dynamique
+! ---------------------------------------------
+! Pi
+pi=2.*asin(1.)
+
+!Reference surface pressure (Pa)
+preff=101325.
+CALL getin('preff', preff)
+! Reference pressure at which hybrid coord. become purely pressure
+! pa=50000.
+pa=preff/2.
+CALL getin('pa', pa)
+! Gravity
+g=9.80665
+CALL getin('g',g)
+! Molar mass of the atmosphere
+molmass = 28.9644
+CALL getin('molmass',molmass)
+! kappa=R/Cp et Cp      
+kappa = 2./7.
+CALL getin('kappa',kappa)
+cpp=8.3145/molmass/kappa*1000.
+CALL getin('cpp',cpp)
+! Radius of the planet
+rad = 6371229. 
+CALL getin('radius',rad)
+! Length of a standard day (s)
+daysec=86400.
+CALL getin('daysec',daysec)
+! Rotation rate of the planet:
+! Length of a solar day, in standard days
+daylen = 1.
+CALL getin('daylen',daylen)
+! Number of days (standard) per year:
+year_day_dyn = 365.25
+CALL getin('year_day',year_day_dyn)
+! Omega
+! omeg=2.*pi/86400.
+omeg=2.*pi/daysec*(1./daylen+1./year_day_dyn)
+CALL getin('omeg',omeg)
+
+! Intrinsic heat flux [default is none]
+! Aymeric -- for giant planets
+! [matters only if planet_type="giant"]
+ihf = 0.
+CALL getin('ihf',ihf)
+
+
+
+END SUBROUTINE conf_planete
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/control_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/control_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/control_mod.F90	(revision 222)
@@ -0,0 +1,53 @@
+!
+! $Id $
+!
+
+MODULE control_mod
+
+! LF 01/2010
+! Remplacement du fichier et common control
+
+  IMPLICIT NONE
+
+  real,save :: periodav
+  real,save :: starttime
+  integer,save :: nday
+  integer,save :: day_step ! # of dynamical time steps per day
+  integer,save :: iperiod ! make a Matsuno step before avery iperiod-1 LF steps
+  integer,save :: iapp_tracvl ! apply (cumulated) traceur advection every
+                              ! iapp_tracvl dynamical steps
+  integer,save :: nsplit_phys ! number of sub-cycle steps in call to physics
+  integer,save :: iconser
+  integer,save :: iecri
+  integer,save :: dissip_period ! apply dissipation every dissip_period
+                                ! dynamical step
+  integer,save :: iphysiq ! call physics every iphysiq dynamical steps
+  integer,save :: iecrimoy
+  integer,save :: dayref
+  integer,save :: anneeref ! reference year # 
+  integer,save :: raz_date
+  integer,save :: ip_ebil_dyn
+  logical,save :: offline
+  character(len=4),save :: config_inca
+  character(len=10),save :: planet_type ! planet type ('earth','mars',...)
+  logical,save :: output_grads_dyn ! output dynamics diagnostics in
+                                   ! binary grads file 'dyn.dat' (y/n)
+  logical,save :: ok_dynzon  ! output zonal transports in dynzon.nc file
+  logical,save :: ok_dyn_ins ! output instantaneous values of fields
+                             ! in the dynamics in NetCDF files dyn_hist*nc
+  logical,save :: ok_dyn_ave ! output averaged values of fields in the dynamics
+                             ! in NetCDF files dyn_hist*ave.nc
+  logical,save :: resetvarc  ! allows to reset the variables in sortvarc
+  logical,save :: less1day   ! allows to run less than 1 day (for Venus)
+  real,save :: fractday   ! fraction of the day to run in this case
+  
+  integer,save :: ndynstep ! Alternative to using less1day&fractday; user may
+                           ! specify number of dynamical steps to run
+
+  integer,save :: ecritphy ! (Mars/generic) output (writediagfi) every
+                           ! ecritphy dynamical steps
+  integer,save :: ecritstart ! (Mars) output data in "start.nc" every
+                             !ecritstart dynamical steps 
+  real,save :: timestart ! (Mars) time start for run in "start.nc"
+
+END MODULE
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/convflu.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/convflu.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/convflu.F	(revision 222)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+      SUBROUTINE convflu( xflu,yflu,nbniv,convfl )
+c
+c  P. Le Van
+c
+c
+c    *******************************************************************
+c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+c      composantes xflu et yflu ,variables extensives .  ......
+c    *******************************************************************
+c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+c      convfl                est  un argument de sortie pour le s-pg .
+c
+c     njxflu  est le nombre de lignes de latitude de xflu, 
+c     ( = jjm ou jjp1 )
+c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      REAL       xflu,yflu,convfl,convpn,convps
+      INTEGER    l,ij,nbniv
+      DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) ,
+     *         convfl( ip1jmp1,nbniv )
+c
+      REAL       SSUM
+c
+c
+#include "comgeom.h"
+c
+      DO 5 l = 1,nbniv
+c
+      DO 2  ij = iip2, ip1jm - 1
+      convfl( ij + 1,l ) =  xflu(   ij,l ) - xflu( ij +  1,l )   +
+     *                      yflu(ij +1,l ) - yflu( ij -iim,l )
+   2  CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+   3  CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+      DO 4 ij = 1,iip1
+      convfl(     ij   ,l ) = convpn * aire(   ij     ) / apoln
+      convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols
+   4  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/convmas.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/convmas.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/convmas.F	(revision 222)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      SUBROUTINE convmas (pbaru, pbarv, convm )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+
+       CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+
+      DO      l      = llmm1, 1, -1
+        DO    ij     = 1, ip1jmp1
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/coordij.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/coordij.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/coordij.F	(revision 222)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE coordij(lon,lat,ilon,jlat)
+
+c=======================================================================
+c
+c   calcul des coordonnees i et j de la maille scalaire dans
+c   laquelle se trouve le point (lon,lat) en radian
+c
+c=======================================================================
+
+      IMPLICIT NONE
+      REAL lon,lat
+      INTEGER ilon,jlat
+      INTEGER i,j
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+
+      real zlon,zlat
+
+      zlon=lon*pi/180.
+      zlat=lat*pi/180.
+
+      DO i=1,iim+1
+         IF (rlonu(i).GT.zlon) THEN
+            ilon=i
+            GOTO 10
+         ENDIF
+      ENDDO
+10    CONTINUE
+
+      j=0
+      DO j=1,jjm
+         IF(rlatv(j).LT.zlat) THEN
+            jlat=j
+            GOTO 20
+         ENDIF
+      ENDDO
+20    CONTINUE
+      IF(j.EQ.0) j=jjm+1
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/covcont.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/covcont.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/covcont.F	(revision 222)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. contravariantes a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO 10 l = 1,klevel
+
+      DO 2  ij = iip2, ip1jm
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = 1,ip1jm
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/covnat.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/covnat.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/covnat.F	(revision 222)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  F Hourdin Phu LeVan
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. naturelles a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO l = 1,klevel
+         DO ij = 1, iip1
+            unat (ij,l) =0.
+         END DO
+
+         DO ij = iip2, ip1jm
+            unat( ij,l ) = ucov( ij,l ) / cu(ij)
+         ENDDO
+         DO ij = ip1jm+1, ip1jmp1  
+            unat (ij,l) =0.
+         END DO
+
+         DO ij = 1,ip1jm
+            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+         ENDDO
+
+      ENDDO
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/cpdet_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/cpdet_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/cpdet_mod.F90	(revision 222)
@@ -0,0 +1,312 @@
+module cpdet_mod
+
+implicit none
+
+! ADAPTATION OF GCM TO CP(T)
+!======================================================================
+! S. Lebonnois, 10/2010
+!
+! Cp must be computed using cpdet(t) to be valid
+!
+! The Exner function is still pk = RCPD*(play/pref)**RKAPPA
+! (RCPD=cpp, RKAPPA=kappa)
+!
+! One goes from T to teta (potential temperature) using t2tpot(t,teta,pk)
+! One goes from teta to T using tpot2t(teta,t,pk)
+!
+!======================================================================
+
+contains
+
+      SUBROUTINE ini_cpdet
+      
+      USE control_mod, ONLY: planet_type 
+      IMPLICIT none
+!======================================================================
+! Initialization of nu_venus and t0_venus
+!======================================================================
+
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      if (planet_type.eq."venus") then
+          nu_venus=0.35
+          t0_venus=460.
+      else
+          nu_venus=0.
+          t0_venus=0.
+      endif
+
+      return
+      end subroutine ini_cpdet
+
+!======================================================================
+!======================================================================
+
+      FUNCTION cpdet(t)
+
+      USE control_mod, ONLY: planet_type 
+      IMPLICIT none
+
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      real,intent(in) :: t
+      real cpdet
+
+      if (planet_type.eq."venus") then
+          cpdet = cpp*(t/t0_venus)**nu_venus
+      else
+          cpdet = cpp
+      endif
+
+      return
+      end function cpdet
+      
+!======================================================================
+!======================================================================
+
+      SUBROUTINE t2tpot(npoints, yt, yteta, ypk)
+!======================================================================
+! Arguments:
+!
+! yt   --------input-R- Temperature
+! yteta-------output-R- Temperature potentielle
+! ypk  --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA
+!
+!======================================================================
+
+      USE control_mod, ONLY: planet_type 
+      IMPLICIT NONE
+      
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      integer,intent(in) :: npoints
+      REAL,intent(in) :: yt(npoints), ypk(npoints)
+      REAL,intent(out) :: yteta(npoints)
+      
+      if (planet_type.eq."venus") then
+          yteta = yt**nu_venus                                          &
+     &            - nu_venus * t0_venus**nu_venus * log(ypk/cpp)
+          yteta = yteta**(1./nu_venus)
+      else
+          yteta = yt * cpp/ypk
+      endif
+
+      return
+      end subroutine t2tpot
+
+!======================================================================
+!======================================================================
+
+      SUBROUTINE tpot2t(npoints,yteta, yt, ypk)
+!======================================================================
+! Arguments:
+!
+! yteta--------input-R- Temperature potentielle
+! yt   -------output-R- Temperature
+! ypk  --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA
+!
+!======================================================================
+
+      USE control_mod, ONLY: planet_type 
+      IMPLICIT NONE
+
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      integer,intent(in) :: npoints
+      REAL,intent(in) :: yteta(npoints), ypk(npoints)
+      REAL,intent(out) :: yt(npoints)
+      
+      if (planet_type.eq."venus") then
+         yt = yteta**nu_venus                                           &
+     &       + nu_venus * t0_venus**nu_venus * log(ypk/cpp)
+         yt = yt**(1./nu_venus)
+      else
+          yt = yteta * ypk/cpp
+      endif
+  
+      return
+      end subroutine tpot2t
+
+!======================================================================
+!======================================================================
+! Routines pour les calculs paralleles
+!======================================================================
+#ifdef CPP_PARA
+!======================================================================
+
+      SUBROUTINE t2tpot_p(nlon,nlev, yt, yteta, ypk)
+! Parallel version of t2tpot, for an arbitrary number of columns
+      USE control_mod, only : planet_type
+      IMPLICIT none
+
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      integer,intent(in) :: nlon,nlev
+      real,intent(in) :: yt(nlon,nlev)
+      real,intent(out) :: yteta(nlon,nlev)
+      real,intent(in) :: ypk(nlon,nlev)
+! local variable:
+      integer :: l
+      
+      if (planet_type.eq."venus") then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,nlev
+          yteta(:,l)=yt(:,l)**nu_venus                                  &
+     &                     -nu_venus*t0_venus**nu_venus*                &
+     &                          log(ypk(:,l)/cpp)
+          yteta(:,l)=yteta(:,l)**(1./nu_venus)
+        enddo
+!$OMP END DO
+      else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,nlev
+          yteta(:,l)=yt(:,l)*cpp/ypk(:,l)
+        enddo
+!$OMP END DO
+      endif ! of if (planet_type.eq."venus")
+
+      end subroutine t2tpot_p
+
+!======================================================================
+!======================================================================
+
+      SUBROUTINE t2tpot_glo_p(yt, yteta, ypk)
+! Parallel version of t2tpot, over the full dynamics (scalar) grid
+! (more efficient than multiple calls to t2tpot_p() with slices of data)
+      USE parallel_lmdz, only : jj_begin,jj_end
+      USE control_mod, only : planet_type
+      IMPLICIT none
+! for iip1, jjp1 and llm
+#include "dimensions.h"
+#include "paramet.h"
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      real,intent(in) :: yt(iip1,jjp1,llm)
+      real,intent(out) :: yteta(iip1,jjp1,llm)
+      real,intent(in) :: ypk(iip1,jjp1,llm)
+! local variable:
+      integer :: j,l
+      integer :: jjb,jje
+      
+      jjb=jj_begin
+      jje=jj_end
+
+      if (planet_type.eq."venus") then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+          yteta(:,jjb:jje,l)=yt(:,jjb:jje,l)**nu_venus                  &
+     &                     -nu_venus*t0_venus**nu_venus*                &
+     &                          log(ypk(:,jjb:jje,l)/cpp)
+          yteta(:,jjb:jje,l)=yteta(:,jjb:jje,l)**(1./nu_venus)
+        enddo
+!$OMP END DO
+      else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+          yteta(:,jjb:jje,l)=yt(:,jjb:jje,l)*cpp/ypk(:,jjb:jje,l)
+        enddo
+!$OMP END DO
+      endif ! of if (planet_type.eq."venus")
+
+      end subroutine t2tpot_glo_p
+
+!======================================================================
+!======================================================================
+
+      SUBROUTINE tpot2t_p(nlon,nlev,yteta,yt,ypk)
+! Parallel version of tpot2t, for an arbitrary number of columns
+      USE control_mod, only : planet_type
+      IMPLICIT none
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      integer,intent(in) :: nlon,nlev
+      real,intent(out) :: yt(nlon,nlev)
+      real,intent(in) :: yteta(nlon,nlev)
+      real,intent(in) :: ypk(nlon,nlev)
+
+! local variable:
+      integer :: l
+
+      if (planet_type.eq."venus") then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,nlev
+          yt(:,l)=yteta(:,l)**nu_venus                                  &
+     &                  +nu_venus*t0_venus**nu_venus*                   &
+     &                       log(ypk(:,l)/cpp)
+          yt(:,l)=yt(:,l)**(1./nu_venus)
+        enddo
+!$OMP END DO
+      else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,nlev
+          yt(:,l)=yteta(:,l)*ypk(:,l)/cpp
+        enddo
+!$OMP END DO
+      endif ! of if (planet_type.eq."venus")
+      end subroutine tpot2t_p
+
+!======================================================================
+!======================================================================
+
+      SUBROUTINE tpot2t_glo_p(yteta,yt,ypk)
+! Parallel version of tpot2t, over the full dynamics (scalar) grid
+! (more efficient than multiple calls to tpot2t_p() with slices of data)
+      USE parallel_lmdz, only : jj_begin,jj_end
+      USE control_mod, only : planet_type
+      IMPLICIT none
+! for iip1, jjp1 and llm
+#include "dimensions.h"
+#include "paramet.h"
+! for cpp, nu_venus and t0_venus:
+#include "comconst.h"
+
+      real,intent(out) :: yt(iip1,jjp1,llm)
+      real,intent(in) :: yteta(iip1,jjp1,llm)
+      real,intent(in) :: ypk(iip1,jjp1,llm)
+! local variable:
+      integer :: j,l
+      integer :: jjb,jje
+      
+      jjb=jj_begin
+      jje=jj_end
+
+      if (planet_type.eq."venus") then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+          yt(:,jjb:jje,l)=yteta(:,jjb:jje,l)**nu_venus                  &
+     &                  +nu_venus*t0_venus**nu_venus*                   &
+     &                       log(ypk(:,jjb:jje,l)/cpp)
+          yt(:,jjb:jje,l)=yt(:,jjb:jje,l)**(1./nu_venus)
+        enddo
+!$OMP END DO
+      else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+          yt(:,jjb:jje,l)=yteta(:,jjb:jje,l)*ypk(:,jjb:jje,l)/cpp
+        enddo
+!$OMP END DO
+      endif ! of if (planet_type.eq."venus")
+      end subroutine tpot2t_glo_p
+
+!======================================================================
+#endif
+!======================================================================
+! Fin routines specifiques parallele
+!======================================================================
+!======================================================================
+!
+! ATTENTION
+!
+! Si un jour on a besoin, il faudra coder les routines 
+!    dt2dtpot / dtpto2dt 
+!
+!======================================================================
+!======================================================================
+end module cpdet_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/defrun.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/defrun.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/defrun.F	(revision 222)
@@ -0,0 +1,502 @@
+!
+! $Id: defrun.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+c
+c
+      SUBROUTINE defrun( tapedef, etatinit, clesphy0 )
+c
+! ========================== ATTENTION =============================
+! COMMENTAIRE SL : 
+! NE SERT PLUS APPAREMMENT
+! DONC PAS MIS A JOUR POUR L'UTILISATION AVEC LES PLANETES
+! ==================================================================
+
+      USE control_mod
+ 
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "clesph0.h"
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      INTEGER   tapeout
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy,tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      tapeout = 6
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+      OPEN( tapedef,file ='gcm.def',status='old',form='formatted')
+
+
+      READ (tapedef,9000) ch1,ch2,ch3
+      WRITE(tapeout,9000) ch1,ch2,ch3
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dayref
+      WRITE(tapeout,9001) ch1,'dayref'
+      WRITE(tapeout,*)    dayref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    anneeref
+      WRITE(tapeout,9001) ch1,'anneeref'
+      WRITE(tapeout,*)    anneeref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nday
+      WRITE(tapeout,9001) ch1,'nday'
+      WRITE(tapeout,*)    nday
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    day_step
+      WRITE(tapeout,9001) ch1,'day_step'
+      WRITE(tapeout,*)    day_step
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iperiod
+      WRITE(tapeout,9001) ch1,'iperiod'
+      WRITE(tapeout,*)    iperiod
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iapp_tracvl
+      WRITE(tapeout,9001) ch1,'iapp_tracvl'
+      WRITE(tapeout,*)    iapp_tracvl
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iconser
+      WRITE(tapeout,9001) ch1,'iconser'
+      WRITE(tapeout,*)    iconser
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iecri
+      WRITE(tapeout,9001) ch1,'iecri'
+      WRITE(tapeout,*)    iecri
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    periodav
+      WRITE(tapeout,9001) ch1,'periodav'
+      WRITE(tapeout,*)    periodav
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dissip_period
+      WRITE(tapeout,9001) ch1,'dissip_period'
+      WRITE(tapeout,*)    dissip_period
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    lstardis
+      WRITE(tapeout,9001) ch1,'lstardis'
+      WRITE(tapeout,*)    lstardis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergdiv
+      WRITE(tapeout,9001) ch1,'nitergdiv'
+      WRITE(tapeout,*)    nitergdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergrot
+      WRITE(tapeout,9001) ch1,'nitergrot'
+      WRITE(tapeout,*)    nitergrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    niterh
+      WRITE(tapeout,9001) ch1,'niterh'
+      WRITE(tapeout,*)    niterh
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagdiv
+      WRITE(tapeout,9001) ch1,'tetagdiv'
+      WRITE(tapeout,*)    tetagdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagrot
+      WRITE(tapeout,9001) ch1,'tetagrot'
+      WRITE(tapeout,*)    tetagrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetatemp
+      WRITE(tapeout,9001) ch1,'tetatemp'
+      WRITE(tapeout,*)    tetatemp
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    coefdis
+      WRITE(tapeout,9001) ch1,'coefdis'
+      WRITE(tapeout,*)    coefdis
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    purmats
+      WRITE(tapeout,9001) ch1,'purmats'
+      WRITE(tapeout,*)    purmats
+
+c    ...............................................................
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_phys
+      WRITE(tapeout,9001) ch1,'iflag_phys'
+      WRITE(tapeout,*)    iflag_phys
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iphysiq
+      WRITE(tapeout,9001) ch1,'iphysiq'
+      WRITE(tapeout,*)    iphysiq
+
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    cycle_diurne
+      WRITE(tapeout,9001) ch1,'cycle_diurne'
+      WRITE(tapeout,*)    cycle_diurne
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    soil_model
+      WRITE(tapeout,9001) ch1,'soil_model'
+      WRITE(tapeout,*)    soil_model
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    new_oliq
+      WRITE(tapeout,9001) ch1,'new_oliq'
+      WRITE(tapeout,*)    new_oliq
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orodr
+      WRITE(tapeout,9001) ch1,'ok_orodr'
+      WRITE(tapeout,*)    ok_orodr
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orolf
+      WRITE(tapeout,9001) ch1,'ok_orolf'
+      WRITE(tapeout,*)    ok_orolf
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_limitvrai
+      WRITE(tapeout,9001) ch1,'ok_limitvrai'
+      WRITE(tapeout,*)    ok_limitvrai
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nbapp_rad
+      WRITE(tapeout,9001) ch1,'nbapp_rad'
+      WRITE(tapeout,*)    nbapp_rad
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_con
+      WRITE(tapeout,9001) ch1,'iflag_con'
+      WRITE(tapeout,*)    iflag_con
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = REAL( iflag_con )
+                          clesphy0(2) = REAL( nbapp_rad )
+
+       IF( cycle_diurne  ) clesphy0(3) =  1.
+       IF(   soil_model  ) clesphy0(4) =  1.
+       IF(     new_oliq  ) clesphy0(5) =  1.
+       IF(     ok_orodr  ) clesphy0(6) =  1.
+       IF(     ok_orolf  ) clesphy0(7) =  1.
+       IF(  ok_limitvrai ) clesphy0(8) =  1.
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clonn
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clonn
+      IF( ABS(clon - clonn).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clatt
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clatt
+
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismxx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismxx
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismyy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismyy
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypbb
+      WRITE(tapeout,9001) ch1,'fxyhypbb'
+      WRITE(tapeout,*)    fxyhypbb
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F'
+     *,      '                   alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t'
+     *,      '                   alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomxx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomyy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomyy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauxx
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    tauxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauyy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauyy
+
+      IF( fxyhypb )  THEN
+
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT_gcm("defrun", "", 1)
+       ENDIF
+
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT_gcm("defrun", "", 1)
+       ENDIF
+
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de taux passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT_gcm("defrun", "", 1)
+       ENDIF
+
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de tauy passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT_gcm("defrun", "", 1)
+       ENDIF
+
+      ENDIF
+      
+cc
+      IF( .NOT.fxyhypb  )  THEN
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ysinuss
+        WRITE(tapeout,9001) ch1,'ysinus'
+        WRITE(tapeout,*)    ysinuss
+
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est T',
+     *       ' alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+      WRITE(6,*) ' alphax alphay defrun ',alphax,alphay
+
+      CLOSE(tapedef)
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clon
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clon
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clat
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clat
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismy
+
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) '***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypb
+      WRITE(tapeout,9001) ch1,'fxyhypb'
+      WRITE(tapeout,*)    fxyhypb
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    taux
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    taux
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ysinus
+      WRITE(tapeout,9001) ch1,'ysinus'
+      WRITE(tapeout,*)    ysinus
+       
+      WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a12)
+cc
+      CLOSE(tapedef)
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/description.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/description.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/description.h	(revision 222)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      character *120 descript
+      common /titre/descript
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diagedyn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diagedyn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diagedyn.F	(revision 222)
@@ -0,0 +1,326 @@
+!
+! $Id: diagedyn.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+
+C======================================================================
+      SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime
+     e  , ucov    , vcov , ps, p ,pk , teta , q, ql)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la dynamique.
+C
+C
+c======================================================================
+C Arguments: 
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+C uconv, vconv-input-R- vents covariants (m/s)
+C ps-------input-R- Surface pressure (Pa)
+C p--------input-R- pressure at the interfaces
+C pk-------input-R- pk= (p/Pref)**kappa
+c teta-----input-R- potential temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c aire-----input-R- mesh surafce (m2)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+#ifdef CPP_EARTH
+#include "../phylmd/YOMCST.h"
+#include "../phylmd/YOETHF.h"
+#endif
+C
+      INTEGER imjmp1
+      PARAMETER( imjmp1=iim*jjp1)
+c     Input variables
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )  ! pression aux interfac.des couches
+      REAL pk (ip1jmp1,llm  )  ! = (p/Pref)**kappa
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm)               ! champs eau vapeur
+      REAL ql(ip1jmp1,llm)               ! champs eau liquide
+
+
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL ecin(ip1jmp1,llm)
+
+      REAL zaire(imjmp1)
+      REAL zps(imjmp1)
+      REAL zairm(imjmp1,llm)
+      REAL zecin(imjmp1,llm)
+      REAL zpaprs(imjmp1,llm)
+      REAL zpk(imjmp1,llm)
+      REAL zt(imjmp1,llm)
+      REAL zh(imjmp1,llm)
+      REAL zqw(imjmp1,llm)
+      REAL zql(imjmp1,llm)
+      REAL zqs(imjmp1,llm)
+
+      REAL  zqw_col(imjmp1)
+      REAL  zql_col(imjmp1)
+      REAL  zqs_col(imjmp1)
+      REAL  zec_col(imjmp1)
+      REAL  zh_dair_col(imjmp1)
+      REAL  zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k, jj, ij , l ,ip1jjm1
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+
+
+      real,external :: cpdet
+
+#ifdef CPP_EARTH
+c======================================================================
+C     Compute Kinetic enrgy
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL massdair( p, masse )
+c======================================================================
+C
+C
+      print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?'
+      return
+C     On ne garde les donnees que dans les colonnes i=1,iim
+      DO jj = 1,jjp1
+        ip1jjm1=iip1*(jj-1)
+        DO ij =  1,iim
+          i=iim*(jj-1)+ij
+          zaire(i)=aire(ij+ip1jjm1)
+          zps(i)=ps(ij+ip1jjm1)
+        ENDDO 
+      ENDDO 
+C 3D arrays
+      DO l  =  1, llm
+        DO jj = 1,jjp1
+          ip1jjm1=iip1*(jj-1)
+          DO ij =  1,iim
+            i=iim*(jj-1)+ij
+            zairm(i,l) = masse(ij+ip1jjm1,l)
+            zecin(i,l) = ecin(ij+ip1jjm1,l)
+            zpaprs(i,l) = p(ij+ip1jjm1,l)
+            zpk(i,l) = pk(ij+ip1jjm1,l)
+            zh(i,l) = teta(ij+ip1jjm1,l)
+            zqw(i,l) = q(ij+ip1jjm1,l)
+            zql(i,l) = ql(ij+ip1jjm1,l)
+            zqs(i,l) = 0.
+          ENDDO 
+        ENDDO 
+      ENDDO 
+C
+C     Reset variables
+      DO i = 1, imjmp1
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+! ADAPTATION GCM POUR CP(T)
+      call tpot2t(imjmp1*llm,zh,zt,zpk)
+      DO k = 1, llm
+        DO i = 1, imjmp1
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +zecin(i,k)*zairm(i,k)
+C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i)
+! ADAPTATION GCM POUR CP(T)
+     $        + cpdet(zt(i,k))*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))
+     $                       *zairm(i,k)*zt(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLVTT*zql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLSTT*zqs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,imjmp1
+        qw_tot = qw_tot + zqw_col(i)
+        ql_tot = ql_tot + zql_col(i)
+        qs_tot = qs_tot + zqs_col(i)
+        ec_tot = ec_tot + zec_col(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)
+        airetot=airetot+zaire(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+C        WRITE(6,9003) tit,pas(idiag), ec_tot
+ 9003   format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6))
+        WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec
+ 9004   format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+#else
+      write(lunout,*)'diagedyn: Needs Earth physics to function'
+#endif
+! #endif of #ifdef CPP_EARTH 
+      RETURN 
+      END 
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/disvert.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/disvert.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/disvert.F90	(revision 222)
@@ -0,0 +1,455 @@
+! $Id: disvert.F90 1645 2012-07-30 16:01:50Z lguez $
+
+SUBROUTINE disvert()
+
+  ! Auteur : P. Le Van
+
+#ifdef CPP_IOIPSL
+  use ioipsl, only: getin
+#else
+  USE ioipsl_getincom, only: getin
+#endif
+  use new_unit_m, only: new_unit
+  use assert_m, only: assert
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comconst.h"
+  include "iniprint.h"
+  include "logic.h"
+
+!-------------------------------------------------------------------------------
+! Purpose: Vertical distribution functions for LMDZ.
+!          Triggered by the levels number llm.
+!-------------------------------------------------------------------------------
+! Read    in "comvert.h":
+! pa                         !--- PURE PRESSURE COORDINATE FOR P<pa (in Pascals)
+! preff                      !--- REFERENCE PRESSURE                 (101325 Pa)
+! Written in "comvert.h":
+! ap(llm+1), bp(llm+1)       !--- Ap, Bp HYBRID COEFFICIENTS AT INTERFACES
+! aps(llm),  bps(llm)        !--- Ap, Bp HYBRID COEFFICIENTS AT MID-LAYERS
+! dpres(llm)                 !--- PRESSURE DIFFERENCE FOR EACH LAYER
+! presnivs(llm)              !--- PRESSURE AT EACH MID-LAYER
+! scaleheight                !--- VERTICAL SCALE HEIGHT            (Earth: 8kms)
+! nivsig(llm+1)              !--- SIGMA INDEX OF EACH LAYER INTERFACE
+! nivsigs(llm)               !--- SIGMA INDEX OF EACH MID-LAYER
+!-------------------------------------------------------------------------------
+! Local variables:
+  REAL sig(llm+1), dsig(llm)
+  REAL sig0(llm+1), zz(llm+1)
+  REAL zk, zkm1, dzk1, dzk2, z, k0, k1
+
+  INTEGER l, unit
+  REAL dsigmin
+  REAL vert_scale,vert_dzmin,vert_dzlow,vert_z0low,vert_dzmid,vert_z0mid,vert_h_mid,vert_dzhig,vert_z0hig,vert_h_hig
+
+  REAL alpha, beta, deltaz
+  REAL x
+  character(len=*),parameter :: modname="disvert"
+
+  character(len=24):: vert_sampling
+  ! (allowed values are "param", "tropo", "strato" and "read")
+
+  !-----------------------------------------------------------------------
+
+  WRITE(lunout,*) TRIM(modname)//" starts"
+
+  ! default scaleheight is 8km for earth
+  scaleheight=8.
+
+  vert_sampling = merge("strato", "tropo ", ok_strato) ! default value
+  call getin('vert_sampling', vert_sampling)
+  WRITE(lunout,*) TRIM(modname)//' vert_sampling = ' // vert_sampling
+  if (llm==39 .and. vert_sampling=="strato") then
+     dsigmin=0.3 ! Vieille option par dÃÂ©faut pour CMIP5
+  else
+     dsigmin=1.
+  endif
+  call getin('dsigmin', dsigmin)
+  WRITE(LUNOUT,*) trim(modname), 'Discretisation verticale DSIGMIN=',dsigmin
+
+
+  select case (vert_sampling)
+  case ("param")
+     ! On lit les options dans sigma.def:
+     OPEN(99, file='sigma.def', status='old', form='formatted')
+     READ(99, *) scaleheight ! hauteur d'echelle 8.
+     READ(99, *) deltaz ! epaiseur de la premiere couche 0.04
+     READ(99, *) beta ! facteur d'acroissement en haut 1.3
+     READ(99, *) k0 ! nombre de couches dans la transition surf
+     READ(99, *) k1 ! nombre de couches dans la transition haute
+     CLOSE(99)
+     alpha=deltaz/(llm*scaleheight)
+     write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', &
+                               scaleheight, alpha, k0, k1, beta
+
+     alpha=deltaz/tanh(1./k0)*2.
+     zkm1=0.
+     sig(1)=1.
+     do l=1, llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) &
+             *exp(-alpha/scaleheight*tanh((llm-k1)/k0) &
+                  *beta**(l-(llm-k1))/log(beta))
+        zk=-scaleheight*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2
+        zkm1=zk
+     enddo
+
+     sig(llm+1)=0.
+
+     bp(: llm) = EXP(1. - 1. / sig(: llm)**2)
+     bp(llmp1) = 0.
+
+     ap = pa * (sig - bp)
+  case("sigma")
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) = dsigmin + 7.0 * SIN(x)**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig(l) = sig(l+1) + dsig(l)
+     ENDDO
+
+     bp(1)=1.
+     bp(2: llm) = sig(2:llm)
+     bp(llmp1) = 0.
+     ap(:)=0.
+  case("tropo")
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) = dsigmin + 7.0 * SIN(x)**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig(l) = sig(l+1) + dsig(l)
+     ENDDO
+
+     bp(1)=1.
+     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
+     bp(llmp1) = 0.
+
+     ap(1)=0.
+     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
+  case("strato")
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
+             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig(l) = sig(l+1) + dsig(l)
+     ENDDO
+
+     bp(1)=1.
+     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
+     bp(llmp1) = 0.
+
+     ap(1)=0.
+     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
+  case("strato_correct")
+!==================================================================
+! Fredho 2014/05/18, Saint-Louis du Senegal
+! Cette version de la discretisation strato est corrige au niveau
+! du passage des sig aux ap, bp
+! la version precedente donne un coude dans l'epaisseur des couches
+! vers la tropopause
+!==================================================================
+
+
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
+             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig0(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig0(l) = sig0(l+1) + dsig(l)
+     ENDDO
+     sig=racinesig(sig0)
+
+     bp(1)=1.
+     bp(2:llm)=EXP(1.-1./sig(2: llm)**2)
+     bp(llmp1)=0.
+
+     ap(1)=0.
+     ap(2:llm)=pa*(sig(2:llm)-bp(2:llm))
+     ap(llm+1)=0.
+
+  CASE("strato_custom0") 
+!=======================================================
+! Version Transitoire
+    ! custumize strato distribution with specific alpha & beta values and function
+    ! depending on llm (experimental and temporary)!
+    SELECT CASE (llm)
+      CASE(55)
+        alpha=0.45
+        beta=4.0
+      CASE(63)
+        alpha=0.45
+        beta=5.0
+      CASE(71)
+        alpha=3.05
+        beta=65.
+      CASE(79)
+        alpha=3.20
+        ! alpha=2.05 ! FLOTT 79 (PLANTE)
+        beta=70.
+    END SELECT
+    ! Or used values provided by user in def file:
+    CALL getin("strato_alpha",alpha)
+    CALL getin("strato_beta",beta)
+    
+    ! Build geometrical distribution
+    scaleheight=7.
+    zz(1)=0.
+    IF (llm==55.OR.llm==63) THEN
+      DO l=1,llm
+        z=zz(l)/scaleheight
+        zz(l+1)=zz(l)+0.03+z*1.5*(1.-TANH(z-0.5))+alpha*(1.+TANH(z-1.5))     &
+                            +5.0*EXP((l-llm)/beta)
+      ENDDO
+    ELSEIF (llm==71) THEN !.OR.llm==79) THEN      ! FLOTT 79 (PLANTE)
+      DO l=1,llm
+        z=zz(l)
+        zz(l+1)=zz(l)+0.02+0.88*TANH(z/2.5)+alpha*(1.+TANH((z-beta)/15.))
+      ENDDO
+    ELSEIF (llm==79) THEN
+      DO l=1,llm
+        z=zz(l)
+        zz(l+1)=zz(l)+0.02+0.80*TANH(z/3.8)+alpha*(1+TANH((z-beta)/17.))     &
+                            +0.03*TANH(z/.25)
+      ENDDO
+    ENDIF ! of IF (llm==55.OR.llm==63) ...
+    
+
+    ! Build sigma distribution
+    sig0=EXP(-zz(:)/scaleheight)
+    sig0(llm+1)=0.
+!    sig=ridders(sig0)
+    sig=racinesig(sig0)
+    
+    ! Compute ap() and bp()
+    bp(1)=1.
+    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
+    bp(llm+1)=0.
+    ap=pa*(sig-bp)
+
+  CASE("strato_custom") 
+!===================================================================
+! David Cugnet, FranÃÂ§ois Lott, Lionel Guez, Ehouoarn Millour, Fredho
+! 2014/05
+! custumize strato distribution
+! Al the parameter are given in km assuming a given scalehigh
+    vert_scale=7.     ! scale hight
+    vert_dzmin=0.02   ! width of first layer
+    vert_dzlow=1.     ! dz in the low atmosphere
+    vert_z0low=8.     ! height at which resolution recches dzlow
+    vert_dzmid=3.     ! dz in the mid atmsophere
+    vert_z0mid=70.    ! height at which resolution recches dzmid
+    vert_h_mid=20.    ! width of the transition
+    vert_dzhig=11.    ! dz in the high atmsophere
+    vert_z0hig=80.    ! height at which resolution recches dz
+    vert_h_hig=20.    ! width of the transition
+!===================================================================
+
+    call getin('vert_scale',vert_scale)
+    call getin('vert_dzmin',vert_dzmin)
+    call getin('vert_dzlow',vert_dzlow)
+    call getin('vert_z0low',vert_z0low)
+    CALL getin('vert_dzmid',vert_dzmid)
+    CALL getin('vert_z0mid',vert_z0mid)
+    call getin('vert_h_mid',vert_h_mid)
+    call getin('vert_dzhig',vert_dzhig)
+    call getin('vert_z0hig',vert_z0hig)
+    call getin('vert_h_hig',vert_h_hig)
+
+    scaleheight=vert_scale ! for consistency with further computations
+    ! Build geometrical distribution
+    zz(1)=0.
+    DO l=1,llm
+       z=zz(l)
+       zz(l+1)=zz(l)+vert_dzmin+vert_dzlow*TANH(z/vert_z0low)+                &
+&      (vert_dzmid-vert_dzlow)* &
+&           (TANH((z-vert_z0mid)/vert_h_mid)-TANH((-vert_z0mid)/vert_h_mid)) &
+&     +(vert_dzhig-vert_dzmid-vert_dzlow)*                                  &
+&           (TANH((z-vert_z0hig)/vert_h_hig)-TANH((-vert_z0hig)/vert_h_hig))
+    ENDDO
+
+
+!===================================================================
+! Comment added Fredho 2014/05/18, Saint-Louis, Senegal
+! From approximate z to ap, bp, so that p=ap+bp*p0 and p/p0=exp(-z/H)
+! sig0 is p/p0
+! sig is an intermediate distribution introduce to estimate bp
+! 1.   sig0=exp(-z/H)
+! 2.   inversion of sig0=(1-pa/p0)*sig+(1-pa/p0)*exp(1-1/sig**2)
+! 3.   bp=exp(1-1/sig**2)
+! 4.   ap deduced from  the combination of 2 and 3 so that sig0=ap/p0+bp
+!===================================================================
+
+    sig0=EXP(-zz(:)/vert_scale)
+    sig0(llm+1)=0.
+    sig=racinesig(sig0)
+    bp(1)=1.
+    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
+    bp(llm+1)=0.
+    ap=pa*(sig-bp)
+
+  case("read")
+     ! Read "ap" and "bp". First line is skipped (title line). "ap"
+     ! should be in Pa. First couple of values should correspond to
+     ! the surface, that is : "bp" should be in descending order.
+     call new_unit(unit)
+     open(unit, file="hybrid.txt", status="old", action="read", &
+          position="rewind")
+     read(unit, fmt=*) ! skip title line
+     do l = 1, llm + 1
+        read(unit, fmt=*) ap(l), bp(l)
+     end do
+     close(unit)
+     call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., &
+          bp(llm + 1) == 0., "disvert: bad ap or bp values")
+  case default
+     call abort_gcm("disvert", 'Wrong value for "vert_sampling"', 1)
+  END select
+
+  DO l=1, llm
+     nivsigs(l) = REAL(l)
+  ENDDO
+
+  DO l=1, llmp1
+     nivsig(l)= REAL(l)
+  ENDDO
+
+  write(lunout, *)  trim(modname),': BP '
+  write(lunout, *) bp
+  write(lunout, *)  trim(modname),': AP '
+  write(lunout, *) ap
+
+  write(lunout, *) 'Niveaux de pressions approximatifs aux centres des'
+  write(lunout, *)'couches calcules pour une pression de surface =', preff
+  write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de '
+  write(lunout, *) scaleheight,' km'
+  DO l = 1, llm
+     dpres(l) = bp(l) - bp(l+1)
+     presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
+     write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', &
+          log(preff/presnivs(l))*scaleheight &
+          , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ &
+          max(ap(l+1)+bp(l+1)*preff, 1.e-10))
+  ENDDO
+
+  write(lunout, *) trim(modname),': PRESNIVS '
+  write(lunout, *) presnivs
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION ridders(sig) RESULT(sg)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Purpose: Search for s solving (Pa/Preff)*s+(1-Pa/Preff)*EXP(1-1./s**2)=sg
+! Notes:   Uses Ridders' method, quite robust. Initial bracketing: 0<=sg<=1.
+! Reference: Ridders, C. F. J. "A New Algorithm for Computing a Single Root of a
+!       Real Continuous Function" IEEE Trans. Circuits Systems 26, 979-980, 1979
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: sig(:)
+  REAL              :: sg(SIZE(sig))
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: it, ns, maxit
+  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
+!-------------------------------------------------------------------------------
+  ns=SIZE(sig); maxit=9999
+  c1=Pa/Preff; c2=1.-c1
+  DO l=1,ns
+    xx=HUGE(1.)
+    x1=0.0; f1=distrib(x1,c1,c2,sig(l))
+    x2=1.0; f2=distrib(x2,c1,c2,sig(l))
+    DO it=1,maxit
+      x3=0.5*(x1+x2); f3=distrib(x3,c1,c2,sig(l))
+      s=SQRT(f3**2-f1*f2);                 IF(s==0.) EXIT
+      x4=x3+(x3-x1)*(SIGN(1.,f1-f2)*f3/s); IF(ABS(10.*LOG(x4-xx))<=1E-5) EXIT
+      xx=x4; f4=distrib(x4,c1,c2,sig(l));  IF(f4==0.) EXIT
+      IF(SIGN(f3,f4)/=f3) THEN;      x1=x3; f1=f3; x2=xx; f2=f4
+      ELSE IF(SIGN(f1,f4)/=f1) THEN; x2=xx; f2=f4
+      ELSE IF(SIGN(f2,f4)/=f2) THEN; x1=xx; f1=f4
+      ELSE; CALL abort_gcm("ridders",'Algorithm failed (which is odd...')
+      END IF
+      IF(ABS(10.*LOG(ABS(x2-x1)))<=1E-5) EXIT       !--- ERROR ON SIG <= 0.01m            
+    END DO
+    IF(it==maxit+1) WRITE(lunout,'(a,i3)')'WARNING in ridder: failed to converg&
+     &e for level ',l
+    sg(l)=xx
+  END DO
+  sg(1)=1.; sg(ns)=0.
+
+END FUNCTION ridders
+
+FUNCTION racinesig(sig) RESULT(sg)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Fredho 2014/05/18
+! Purpose: Search for s solving (Pa/Preff)*sg+(1-Pa/Preff)*EXP(1-1./sg**2)=s
+! Notes:   Uses Newton Raphson search
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: sig(:)
+  REAL              :: sg(SIZE(sig))
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: it, ns, maxit
+  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
+!-------------------------------------------------------------------------------
+  ns=SIZE(sig); maxit=100
+  c1=Pa/Preff; c2=1.-c1
+  DO l=2,ns-1
+    sg(l)=sig(l)
+    DO it=1,maxit
+       f1=exp(1-1./sg(l)**2)*(1.-c1)
+       sg(l)=sg(l)-(c1*sg(l)+f1-sig(l))/(c1+2*f1*sg(l)**(-3))
+    ENDDO
+!   print*,'SSSSIG ',sig(l),sg(l),c1*sg(l)+exp(1-1./sg(l)**2)*(1.-c1)
+  ENDDO
+  sg(1)=1.; sg(ns)=0.
+
+END FUNCTION racinesig
+
+
+
+
+END SUBROUTINE disvert
+
+!-------------------------------------------------------------------------------
+
+FUNCTION distrib(x,c1,c2,x0) RESULT(res)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN) :: x, c1, c2, x0
+  REAL             :: res
+!-------------------------------------------------------------------------------
+  res=c1*x+c2*EXP(1-1/(x**2))-x0
+
+END FUNCTION distrib
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/disvert_noterre.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/disvert_noterre.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/disvert_noterre.F	(revision 222)
@@ -0,0 +1,330 @@
+! $Id: $
+      SUBROUTINE disvert_noterre
+
+c    Auteur :  F. Forget Y. Wanherdrick, P. Levan
+c    Nouvelle version 100% Mars !!
+c    On l'utilise aussi pour Venus et Titan, legerment modifiee.
+
+#ifdef CPP_IOIPSL
+      use IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      use ioipsl_getincom
+#endif
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "logic.h"
+#include "iniprint.h"
+c
+c=======================================================================
+c    Discretisation verticale en coordonnée hybride (ou sigma)
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+c
+      INTEGER l,ll
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz
+      real quoi,quand
+      REAL zsig(llm),sig(llm+1)
+      INTEGER np,ierr
+      integer :: ierr1,ierr2,ierr3,ierr4
+      REAL x
+
+      REAL SSUM
+      EXTERNAL SSUM
+      real newsig 
+      REAL dz0,dz1,nhaut,sig1,esig,csig,zz
+      real tt,rr,gg, prevz
+      real s(llm),dsig(llm) 
+
+      integer iz 
+      real z, ps,p
+      character(len=*),parameter :: modname="disvert_noterre"
+
+c
+c-----------------------------------------------------------------------
+c
+! Initializations:
+!      pi=2.*ASIN(1.) ! already done in iniconst
+      
+      hybrid=.true. ! default value for hybrid (ie: use hybrid coordinates)
+      CALL getin('hybrid',hybrid)
+      write(lunout,*) trim(modname),': hybrid=',hybrid
+
+! Ouverture possible de fichiers typiquement E.T.
+
+         open(99,file="esasig.def",status='old',form='formatted',
+     s   iostat=ierr2)
+         if(ierr2.ne.0) then
+              close(99)
+              open(99,file="z2sig.def",status='old',form='formatted',
+     s        iostat=ierr4)
+         endif
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans esasig.def:
+c   ----------------------------------------
+
+      IF(ierr2.eq.0) then
+
+c        Lecture de esasig.def :
+c        Systeme peu souple, mais qui respecte en theorie
+c        La conservation de l'energie (conversion Energie potentielle
+c        <-> energie cinetique, d'apres la note de Frederic Hourdin...
+
+         write(lunout,*)'*****************************'
+         write(lunout,*)'WARNING reading esasig.def'
+         write(lunout,*)'*****************************'
+         READ(99,*) scaleheight
+         READ(99,*) dz0
+         READ(99,*) dz1
+         READ(99,*) nhaut
+         CLOSE(99)
+
+         dz0=dz0/scaleheight
+         dz1=dz1/scaleheight
+
+         sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
+
+         esig=1.
+
+         do l=1,20
+            esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
+         enddo
+         csig=(1./sig1-1.)/(exp(esig)-1.)
+
+         DO L = 2, llm
+            zz=csig*(exp(esig*(l-1.))-1.)
+            sig(l) =1./(1.+zz)
+     &      * tanh(.5*(llm+1-l)/nhaut)
+         ENDDO
+         sig(1)=1.
+         sig(llm+1)=0.
+         quoi      = 1. + 2.* kappa
+         s( llm )  = 1.
+         s(llm-1) = quoi
+         IF( llm.gt.2 )  THEN
+            DO  ll = 2, llm-1
+               l         = llm+1 - ll
+               quand     = sig(l+1)/ sig(l)
+               s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
+            ENDDO
+         END IF
+c
+         snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
+         DO l = 1, llm
+            s(l)    = s(l)/ snorm
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   cas 2 on lit les options dans z2sig.def:
+c   ----------------------------------------
+
+      ELSE IF(ierr4.eq.0) then
+         write(lunout,*)'****************************'
+         write(lunout,*)'Reading z2sig.def'
+         write(lunout,*)'****************************'
+
+         READ(99,*) scaleheight
+         do l=1,llm
+            read(99,*) zsig(l)
+         end do
+         CLOSE(99)
+
+         sig(1) =1
+         do l=2,llm
+           sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + 
+     &                      exp(-zsig(l-1)/scaleheight) )
+         end do
+         sig(llm+1) =0
+
+c-----------------------------------------------------------------------
+      ELSE
+         write(lunout,*) 'didn t you forget something ??? '
+         write(lunout,*) 'We need file  z2sig.def ! (OR esasig.def)'
+         stop
+      ENDIF
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+        nivsigs(l) = REAL(l)
+      ENDDO
+
+      DO l=1,llmp1
+        nivsig(l)= REAL(l)
+      ENDDO
+
+ 
+c-----------------------------------------------------------------------
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
+c-----------------------------------------------------------------------
+c
+
+      if (hybrid) then  ! use hybrid coordinates
+         write(lunout,*) "*********************************"
+         write(lunout,*) "Using hybrid vertical coordinates"
+         write(lunout,*) 
+c        Coordonnees hybrides avec mod
+         DO l = 1, llm
+
+         call sig_hybrid(sig(l),pa,preff,newsig)
+            bp(l) = EXP( 1. - 1./(newsig**2)  )
+            ap(l) = pa * (newsig - bp(l) )
+         enddo
+         bp(llmp1) = 0.
+         ap(llmp1) = 0.
+      else ! use sigma coordinates
+         write(lunout,*) "********************************"
+         write(lunout,*) "Using sigma vertical coordinates"
+         write(lunout,*) 
+c        Pour ne pas passer en coordonnees hybrides
+         DO l = 1, llm
+            ap(l) = 0.
+            bp(l) = sig(l)
+         ENDDO
+         ap(llmp1) = 0.
+      endif
+
+      bp(llmp1) =   0.
+
+      write(lunout,*) trim(modname),': BP '
+      write(lunout,*)  bp
+      write(lunout,*) trim(modname),': AP '
+      write(lunout,*)  ap
+
+c     Calcul au milieu des couches :
+c     WARNING : le choix de placer le milieu des couches au niveau de
+c     pression intermédiaire est arbitraire et pourrait etre modifié.
+c     Le calcul du niveau pour la derniere couche 
+c     (on met la meme distance (en log pression)  entre P(llm)
+c     et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
+c     Specifique.  Ce choix est spécifié ici ET dans exner_milieu.F
+
+      DO l = 1, llm-1
+       aps(l) =  0.5 *( ap(l) +ap(l+1)) 
+       bps(l) =  0.5 *( bp(l) +bp(l+1)) 
+      ENDDO
+     
+      if (hybrid) then
+         aps(llm) = aps(llm-1)**2 / aps(llm-2) 
+         bps(llm) = 0.5*(bp(llm) + bp(llm+1))
+      else
+         bps(llm) = bps(llm-1)**2 / bps(llm-2) 
+         aps(llm) = 0.
+      end if
+
+      write(lunout,*) trim(modname),': BPs '
+      write(lunout,*)  bps
+      write(lunout,*) trim(modname),': APs'
+      write(lunout,*)  aps
+
+      DO l = 1, llm
+       presnivs(l) = aps(l)+bps(l)*preff
+       pseudoalt(l) = -scaleheight*log(presnivs(l)/preff)
+      ENDDO
+
+      write(lunout,*)trim(modname),' : PRESNIVS' 
+      write(lunout,*)presnivs 
+      write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ',
+     &                'height of ',scaleheight,' km)' 
+      write(lunout,*)pseudoalt
+
+c     --------------------------------------------------
+c     This can be used to plot the vertical discretization
+c     (> xmgrace -nxy testhybrid.tab )
+c     --------------------------------------------------
+c     open (53,file='testhybrid.tab')
+c     scaleheight=15.5
+c     do iz=0,34
+c       z = -5 + min(iz,34-iz)
+c     approximation of scale height for Venus
+c       scaleheight = 15.5 - z/55.*10.
+c       ps = preff*exp(-z/scaleheight)
+c       zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff)
+c       do l=2,llm
+c     approximation of scale height for Venus
+c          if (zsig(l-1).le.55.) then
+c             scaleheight = 15.5 - zsig(l-1)/55.*10.
+c          else
+c             scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2.
+c          endif
+c          zsig(l)= zsig(l-1)-scaleheight*
+c    .    log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps))
+c       end do
+c       write(53,'(I3,50F10.5)') iz, zsig
+c      end do
+c      close(53)
+c     --------------------------------------------------
+
+
+      RETURN
+      END
+
+c ************************************************************
+      subroutine sig_hybrid(sig,pa,preff,newsig)
+c     ----------------------------------------------
+c     Subroutine utilisee pour calculer des valeurs de sigma modifie
+c     pour conserver les coordonnees verticales decrites dans
+c     esasig.def/z2sig.def lors du passage en coordonnees hybrides
+c     F. Forget 2002
+c     Connaissant sig (niveaux "sigma" ou on veut mettre les couches)
+c     L'objectif est de calculer newsig telle que
+c       (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig
+c     Cela ne se résoud pas analytiquement: 
+c     => on résoud par iterration bourrine 
+c     ----------------------------------------------
+c     Information  : where exp(1-1./x**2) become << x
+c           x      exp(1-1./x**2) /x
+c           1           1
+c           0.68       0.5
+c           0.5        1.E-1
+c           0.391      1.E-2
+c           0.333      1.E-3
+c           0.295      1.E-4
+c           0.269      1.E-5
+c           0.248      1.E-6
+c        => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25
+
+
+      implicit none
+      real x1, x2, sig,pa,preff, newsig, F
+      integer j
+
+      newsig = sig
+      x1=0
+      x2=1
+      if (sig.ge.1) then
+            newsig= sig
+      else if (sig*preff/pa.ge.0.25) then
+        DO J=1,9999  ! nombre d''iteration max
+          F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig
+c         write(0,*) J, ' newsig =', newsig, ' F= ', F
+          if (F.gt.1) then
+              X2 = newsig
+              newsig=(X1+newsig)*0.5
+          else
+              X1 = newsig
+              newsig=(X2+newsig)*0.5
+          end if
+c         Test : on arete lorsque on approxime sig à moins de 0.01 m près 
+c         (en pseudo altitude) :
+          IF(abs(10.*log(F)).LT.1.E-5) goto 999
+        END DO
+       else   !    if (sig*preff/pa.le.0.25) then
+             newsig= sig*preff/pa
+       end if
+ 999   continue
+       Return
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diverg.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diverg.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diverg.F	(revision 222)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE diverg(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diverg_gam.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diverg_gam.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/diverg_gam.F	(revision 222)
@@ -0,0 +1,80 @@
+!
+! $Header$
+!
+      SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam ,
+     *                       unsapolnga,unsapolsga,  x, y,  div )
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+      REAL unsapolnga,unsapolsga
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+      INTEGER   l,ij
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     = (  
+     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
+     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
+     *         unsairegam( ij+1 )
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+        sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn 
+         div( ij + ip1jm, l ) =   sumyps 
+        ENDDO
+  10  CONTINUE
+c
+
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divergf.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divergf.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divergf.F	(revision 222)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE divergf(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divergst.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divergst.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divergst.F	(revision 222)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+      SUBROUTINE divergst(klevel,x,y,div)
+      IMPLICIT NONE
+c
+c     P. Le Van
+c
+c  ******************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y...
+c           x et y  etant des composantes contravariantes   ...
+c  ****************************************************************
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   -------------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER ij,l,i
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+
+      REAL SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1 ij = iip2, ip1jm - 1
+      div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
+   1  CONTINUE
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      div( ij,l ) = div( ij + iim,l )
+   3  CONTINUE
+c
+c     ....  calcul  aux poles  .....
+c
+c
+      DO 5 i  = 1,iim
+      aiy1(i)= y(i,l)
+      aiy2(i)= y(i+ip1jmi1,l)
+   5  CONTINUE
+      sumypn = SSUM ( iim,aiy1,1 )
+      sumyps = SSUM ( iim,aiy2,1 )
+      DO 7 i = 1,iip1
+      div(     i    , l ) = - sumypn/iim
+      div( i + ip1jm, l ) =   sumyps/iim
+   7  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divgrad.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divgrad.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divgrad.F	(revision 222)
@@ -0,0 +1,56 @@
+!
+! $Header$
+!
+      SUBROUTINE divgrad (klevel,h, lh, divgra )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c  Auteur :   P. Le Van
+c  ----------
+c
+c                              lh
+c      calcul de  (div( grad ))   de h  .....
+c      h  et lh  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+c
+      DO 10 iter = 1,lh
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1  )
+
+      CALL    grad (klevel,divgra, ghx  , ghy          )
+      CALL  diverg (klevel,  ghx , ghy  , divgra       )
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1)
+
+      DO 5 l = 1,klevel
+      DO 4  ij = 1, ip1jmp1
+      divgra( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divgrad2.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divgrad2.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/divgrad2.F	(revision 222)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
+c
+c     P. Le Van
+c
+c   ***************************************************************
+c
+c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
+c   ****************************************************************
+c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+c         divgra     est  un argument  de sortie pour le s-prg
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comdissipn.h"
+
+c    .......    variables en arguments   .......
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+      REAL divgra( ip1jmp1,klevel)
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+
+c
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+
+c
+      CALL laplacien( klevel, divgra, divgra )
+     
+      DO l = 1, klevel
+       DO ij = 1, ip1jmp1
+        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+       ENDDO
+      ENDDO
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+   
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+       CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
+     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
+      ENDDO
+c
+c    ...............................................................
+ 
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c
+      CALL laplacien ( klevel, divgra, divgra )
+c
+      DO l  = 1,klevel
+      DO ij = 1,ip1jmp1
+      divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dump2d.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dump2d.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dump2d.F	(revision 222)
@@ -0,0 +1,46 @@
+!
+! $Id: dump2d.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      SUBROUTINE dump2d(im,jm,z,nom_z)
+      IMPLICIT NONE
+      INTEGER im,jm
+      REAL z(im,jm)
+      CHARACTER (len=*) :: nom_z
+
+      INTEGER i,j,imin,illm,jmin,jllm
+      REAL zmin,zllm
+
+      WRITE(*,*) "dump2d: ",trim(nom_z)
+
+      zmin=z(1,1)
+      zllm=z(1,1)
+      imin=1
+      illm=1
+      jmin=1
+      jllm=1
+
+      DO j=1,jm
+         DO i=1,im
+            IF(z(i,j).GT.zllm) THEN
+               illm=i
+               jllm=j
+               zllm=z(i,j)
+            ENDIF
+            IF(z(i,j).LT.zmin) THEN
+               imin=i
+               jmin=j
+               zmin=z(i,j)
+            ENDIF
+         ENDDO
+      ENDDO
+
+      PRINT*,'MIN: ',zmin
+      PRINT*,'MAX: ',zllm
+
+      IF(zllm.GT.zmin) THEN
+       DO j=1,jm
+        WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
+       ENDDO
+      ENDIF
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dynetat0.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dynetat0.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dynetat0.F	(revision 222)
@@ -0,0 +1,498 @@
+!
+! $Id $
+!
+      SUBROUTINE dynetat0(fichnom,vcov,ucov,
+     .                    teta,q,masse,ps,phis,time0)
+
+      USE infotrac, only: tname, nqtot
+      use netcdf, only: nf90_open,NF90_NOWRITE,nf90_noerr,nf90_strerror,
+     &                  nf90_get_var, nf90_inq_varid, nf90_inq_dimid,
+     &                  nf90_inquire_dimension,nf90_close
+
+      use control_mod, only : planet_type, timestart
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / L.Fairhead
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Lecture de l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "logic.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+
+      CHARACTER(len=*),INTENT(IN) :: fichnom
+      REAL,INTENT(OUT) :: vcov(iip1,jjm,llm)
+      REAL,INTENT(OUT) :: ucov(iip1,jjp1,llm)
+      REAL,INTENT(OUT) :: teta(iip1,jjp1,llm)
+      REAL,INTENT(OUT) :: q(iip1,jjp1,llm,nqtot)
+      REAL,INTENT(OUT) :: masse(iip1,jjp1,llm)
+      REAL,INTENT(OUT) :: ps(iip1,jjp1)
+      REAL,INTENT(OUT) :: phis(iip1,jjp1)
+      REAL,INTENT(OUT) :: time0
+
+c   Variables 
+c
+      INTEGER length,iq
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid
+
+      character(len=12) :: start_file_type="earth" ! default start file type
+      INTEGER idecal
+
+
+      REAL,ALLOCATABLE :: time(:) ! times stored in start
+      INTEGER timelen ! number of times stored in the file
+      INTEGER indextime ! index of selected time
+      !REAL  hour_ini ! fraction of day of stored date. Equivalent of day_ini, but 0=<hour_ini<1
+
+      INTEGER edges(4),corner(4)
+      integer :: i
+
+c-----------------------------------------------------------------------
+
+c  Ouverture NetCDF du fichier etat initial
+
+      ierr=nf90_open(fichnom,NF90_NOWRITE,nid)
+      IF (ierr.NE.nf90_noerr) THEN
+        write(lunout,*)'dynetat0: Pb d''ouverture du fichier start.nc'
+        write(lunout,*)trim(nf90_strerror(ierr))
+        CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+c
+      ierr = nf90_inq_varid (nid, "controle", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <controle> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, tab_cntrl)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echoue pour <controle>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      !!! AS: idecal is a hack to be able to read planeto starts...
+      !!!     .... while keeping everything OK for LMDZ EARTH
+      if ((planet_type.eq."generic").or.(planet_type.eq."mars")) then
+          write(lunout,*)'dynetat0 : Planeto-like start file'
+          start_file_type="planeto"
+          idecal = 4
+          annee_ref  = 2000
+      else
+          write(lunout,*)'dynetat0 : Earth-like start file'
+          idecal = 5
+          annee_ref  = tab_cntrl(5)
+      endif
+
+
+      im         = tab_cntrl(1)
+      jm         = tab_cntrl(2)
+      lllm       = tab_cntrl(3)
+      if (start_file_type.eq."earth") then
+        day_ref    = tab_cntrl(4)
+      else
+        day_ini    = tab_cntrl(4)
+        day_ref=0
+      endif
+      rad        = tab_cntrl(idecal+1)
+      omeg       = tab_cntrl(idecal+2)
+      g          = tab_cntrl(idecal+3)
+      cpp        = tab_cntrl(idecal+4)
+      kappa      = tab_cntrl(idecal+5)
+      daysec     = tab_cntrl(idecal+6)
+      dtvr       = tab_cntrl(idecal+7)
+      etot0      = tab_cntrl(idecal+8)
+      ptot0      = tab_cntrl(idecal+9)
+      ztot0      = tab_cntrl(idecal+10)
+      stot0      = tab_cntrl(idecal+11)
+      ang0       = tab_cntrl(idecal+12)
+      pa         = tab_cntrl(idecal+13)
+      preff      = tab_cntrl(idecal+14)
+c
+      clon       = tab_cntrl(idecal+15)
+      clat       = tab_cntrl(idecal+16)
+      grossismx  = tab_cntrl(idecal+17)
+      grossismy  = tab_cntrl(idecal+18)
+c
+      IF ( tab_cntrl(idecal+19).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+c        dzoomx   = tab_cntrl(25)
+c        dzoomy   = tab_cntrl(26)
+c        taux     = tab_cntrl(28)
+c        tauy     = tab_cntrl(29)
+      ELSE
+        fxyhypb = . FALSE .
+        ysinus  = . FALSE .
+        IF( tab_cntrl(idecal+22).EQ.1. ) ysinus = . TRUE. 
+      ENDIF
+
+      if (planet_type=="mars") then ! so far this is only for Mars
+        hour_ini = tab_cntrl(29)
+      else
+        hour_ini=0
+      endif
+
+      if (start_file_type.eq."earth") then
+        day_ini = tab_cntrl(30)
+        itau_dyn = tab_cntrl(31)
+        start_time = tab_cntrl(32)
+      else
+        day_ini=tab_cntrl(4)
+        itau_dyn=0
+        start_time=0
+      endif
+c   .................................................................
+c
+c
+      write(lunout,*)'dynetat0: rad,omeg,g,cpp,kappa ',
+     &               rad,omeg,g,cpp,kappa
+
+      IF(   im.ne.iim           )  THEN
+          PRINT 1,im,iim
+          STOP
+      ELSE  IF( jm.ne.jjm       )  THEN
+          PRINT 2,jm,jjm
+          STOP
+      ELSE  IF( lllm.ne.llm     )  THEN
+          PRINT 3,lllm,llm
+          STOP
+      ENDIF
+
+      ierr=nf90_inq_varid(nid, "rlonu", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <rlonu> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, rlonu)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <rlonu>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "rlatu", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <rlatu> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, rlatu)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <rlatu>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "rlonv", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <rlonv> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, rlonv)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <rlonv>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "rlatv", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <rlatv> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, rlatv)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour rlatv"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "cu", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <cu> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, cu)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <cu>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "cv", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <cv> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, cv)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <cv>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "aire", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <aire> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, aire)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <aire>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr = nf90_inq_varid (nid, "phisinit", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <phisinit> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, phis)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <phisinit>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+! read time axis
+      ierr = nf90_inq_varid (nid, "temps", nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+        write(lunout,*)"dynetat0: Le champ <temps> est absent"
+        write(lunout,*)"dynetat0: J essaie <Time>"
+        ierr = nf90_inq_varid (nid, "Time", nvarid)
+        IF (ierr .NE. nf90_noerr) THEN
+           write(lunout,*)"dynetat0: Le champ <Time> est absent"
+           write(lunout,*)trim(nf90_strerror(ierr))
+           CALL ABORT_gcm("dynetat0", "", 1)
+        ENDIF
+        ! Get the length of the "Time" dimension
+        ierr = nf90_inq_dimid(nid,"Time",nvarid)
+        ierr = nf90_inquire_dimension(nid,nvarid,len=timelen)
+        allocate(time(timelen))
+        ! Then look for the "Time" variable
+        ierr  =nf90_inq_varid(nid,"Time",nvarid)
+        ierr = nf90_get_var(nid, nvarid, time)
+        IF (ierr .NE. nf90_noerr) THEN
+           write(lunout,*)"dynetat0: Lecture echouee <Time>"
+           write(lunout,*)trim(nf90_strerror(ierr))
+           CALL ABORT_gcm("dynetat0", "", 1)
+        ENDIF
+      ELSE   
+        ! Get the length of the "temps" dimension
+        ierr = nf90_inq_dimid(nid,"temps",nvarid)
+        ierr = nf90_inquire_dimension(nid,nvarid,len=timelen)
+        allocate(time(timelen))
+        ! Then look for the "temps" variable
+        ierr = nf90_inq_varid (nid, "temps", nvarid)
+        ierr = nf90_get_var(nid, nvarid, time)
+        IF (ierr .NE. nf90_noerr) THEN
+           write(lunout,*)"dynetat0: Lecture echouee <temps>"
+           write(lunout,*)trim(nf90_strerror(ierr))
+           CALL ABORT_gcm("dynetat0", "", 1)
+        ENDIF
+      ENDIF
+
+! select the desired time
+      IF (timestart .lt. 0) THEN  ! default: we use the last time value
+        indextime = timelen
+      ELSE  ! else we look for the desired value in the time axis
+       indextime = 0
+        DO i=1,timelen
+          IF (abs(time(i) - timestart) .lt. 0.01) THEN
+             indextime = i
+             EXIT
+          ENDIF
+        ENDDO
+        IF (indextime .eq. 0) THEN
+          write(lunout,*)"Time", timestart," is not in "
+     &                                      //trim(fichnom)//"!!"
+          write(lunout,*)"Stored times are:"
+          DO i=1,timelen
+             PRINT*, time(i)
+          ENDDO
+          CALL ABORT_gcm("dynetat0", "", 1)
+        ENDIF
+      ENDIF
+
+      if (planet_type=="mars") then
+        ! In start the absolute date is day_ini + hour_ini + time
+        ! For now on, in the GCM dynamics, it is day_ini + time0
+        time0 = time(indextime) + hour_ini
+        day_ini = day_ini + INT(time0)
+        time0 = time0 - INT(time0) ! time0 devient le nouveau hour_ini
+        hour_ini = time0
+      else
+        time0 = time(indextime) 
+      endif
+      
+      PRINT*, "dynetat0: Selected time ",time(indextime),
+     .        " at index ",indextime
+      
+      DEALLOCATE(time)
+
+! read vcov
+      corner(1)=1
+      corner(2)=1
+      corner(3)=1
+      corner(4)=indextime
+      edges(1)=iip1
+      edges(2)=jjm
+      edges(3)=llm
+      edges(4)=1
+      ierr=nf90_inq_varid(nid,"vcov",nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <vcov> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr=nf90_get_var(nid,nvarid,vcov,corner,edges)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <vcov>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+! read ucov
+      corner(1)=1
+      corner(2)=1
+      corner(3)=1
+      corner(4)=indextime
+      edges(1)=iip1
+      edges(2)=jjp1
+      edges(3)=llm
+      edges(4)=1
+      ierr=nf90_inq_varid(nid,"ucov",nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <ucov> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr=nf90_get_var(nid,nvarid,ucov,corner,edges)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <ucov>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+ 
+! read teta (same corner/edges as ucov)
+      ierr=nf90_inq_varid(nid,"teta",nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <teta> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr=nf90_get_var(nid,nvarid,teta,corner,edges)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <teta>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+! read tracers (same corner/edges as ucov)
+      IF(nqtot.GE.1) THEN
+      DO iq=1,nqtot
+        ierr= nf90_inq_varid(nid,tname(iq),nvarid)
+        IF (ierr .NE. nf90_noerr) THEN
+           write(lunout,*)"dynetat0: Le traceur <"//trim(tname(iq))//
+     &                    "> est absent"
+           write(lunout,*)"          Il est donc initialise a zero"
+           q(:,:,:,iq)=0.
+        ELSE
+           ierr=nf90_get_var(nid,nvarid,q(:,:,:,iq),corner,edges)
+          IF (ierr .NE. nf90_noerr) THEN
+            write(lunout,*)"dynetat0: Lecture echouee pour "
+     &                                //trim(tname(iq))
+            write(lunout,*)trim(nf90_strerror(ierr))
+            CALL ABORT_gcm("dynetat0", "", 1)
+          ENDIF
+        ENDIF
+      ENDDO
+      ENDIF
+
+!read masse (same corner/edges as ucov)
+      ierr=nf90_inq_varid(nid,"masse",nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <masse> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr=nf90_get_var(nid,nvarid,masse,corner,edges)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <masse>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+! read ps
+      corner(1)=1
+      corner(2)=1
+      corner(3)=indextime
+      edges(1)=iip1
+      edges(2)=jjp1
+      edges(3)=1
+      ierr=nf90_inq_varid(nid,"ps",nvarid)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Le champ <ps> est absent"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+      ierr=nf90_get_var(nid,nvarid,ps,corner,edges)
+      IF (ierr .NE. nf90_noerr) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <ps>"
+         write(lunout,*)trim(nf90_strerror(ierr))
+         CALL ABORT_gcm("dynetat0", "", 1)
+      ENDIF
+
+      ierr=nf90_close(nid)
+
+      if (planet_type/="mars") then
+       day_ini=day_ini+INT(time0) ! obsolete stuff ; 0<time<1 anyways
+       time0=time0-INT(time0)
+      endif
+
+  1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur  dtinteg =',i4//)
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dynredem.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dynredem.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/dynredem.F	(revision 222)
@@ -0,0 +1,800 @@
+!
+! $Id: dynredem.F 1635 2012-07-12 11:37:16Z lguez $
+!
+c
+      SUBROUTINE dynredem0(fichnom,iday_end,phis)
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE infotrac
+      use netcdf95, only: NF95_PUT_VAR
+      use control_mod, only : planet_type
+
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(iip1, jjp1)
+      CHARACTER*(*) fichnom
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+      character(len=12) :: start_file_type="earth" ! default start file type
+      INTEGER idecal
+
+c-----------------------------------------------------------------------
+      modname='dynredem0'
+
+#ifdef CPP_IOIPSL
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+#else
+! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
+      yyears0=0
+      mmois0=1
+      jjour0=1
+#endif        
+
+      !!! AS: idecal is a hack to be able to read planeto starts...
+      !!!     .... while keeping everything OK for LMDZ EARTH
+      if ((planet_type.eq."generic").or.(planet_type.eq."mars")) then
+          write(lunout,*) trim(modname),' : Planeto-like start file'
+          start_file_type="planeto"
+          idecal = 4
+      else
+          write(lunout,*) trim(modname),' : Earth-like start file'
+          idecal = 5
+      endif
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  = REAL(iim)
+       tab_cntrl(2)  = REAL(jjm)
+       tab_cntrl(3)  = REAL(llm)
+       if (start_file_type.eq."earth") then
+         tab_cntrl(4)=REAL(day_ref)
+       else
+         !tab_cntrl(4)=REAL(day_end)
+         tab_cntrl(4)=REAL(iday_end)
+       endif
+       tab_cntrl(5)  = REAL(annee_ref)
+       tab_cntrl(idecal+1)  = rad
+       tab_cntrl(idecal+2)  = omeg
+       tab_cntrl(idecal+3)  = g
+       tab_cntrl(idecal+4)  = cpp
+       tab_cntrl(idecal+5) = kappa
+       tab_cntrl(idecal+6) = daysec
+       tab_cntrl(idecal+7) = dtvr
+       tab_cntrl(idecal+8) = etot0
+       tab_cntrl(idecal+9) = ptot0
+       tab_cntrl(idecal+10) = ztot0
+       tab_cntrl(idecal+11) = stot0
+       tab_cntrl(idecal+12) = ang0
+       tab_cntrl(idecal+13) = pa
+       tab_cntrl(idecal+14) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(idecal+15)  = clon
+       tab_cntrl(idecal+16)  = clat
+       tab_cntrl(idecal+17)  = grossismx
+       tab_cntrl(idecal+18)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(idecal+19) = 1.
+       tab_cntrl(idecal+20) = dzoomx
+       tab_cntrl(idecal+21) = dzoomy
+       tab_cntrl(idecal+22) = 0.
+       tab_cntrl(idecal+23) = taux
+       tab_cntrl(idecal+24) = tauy
+      ELSE
+       tab_cntrl(idecal+19) = 0.
+       tab_cntrl(idecal+20) = dzoomx
+       tab_cntrl(idecal+21) = dzoomy
+       tab_cntrl(idecal+22) = 0.
+       tab_cntrl(idecal+23) = 0.
+       tab_cntrl(idecal+24) = 0.
+       IF( ysinus )  tab_cntrl(idecal+22) = 1.
+      ENDIF
+
+      if (start_file_type.eq."earth") then
+       tab_cntrl(idecal+25) = REAL(iday_end)
+       tab_cntrl(idecal+26) = REAL(itau_dyn + itaufin)
+c start_time: start_time of simulation (not necessarily 0.)
+       tab_cntrl(idecal+27) = start_time
+      endif
+
+      if (planet_type=="mars") then ! For Mars only
+        tab_cntrl(29)=hour_ini
+      endif
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         write(lunout,*)"dynredem0: Pb d ouverture du fichier "
+     &                  //trim(fichnom)
+         write(lunout,*)' ierr = ', ierr
+         CALL ABORT_GCM("DYNREDEM0", "", 1)
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      if (start_file_type.eq."earth") then
+        ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+        ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+        ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+        ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+        ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+        ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+        ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+        ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+      else
+        ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+        ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+        ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+        ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+        ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+        ierr = NF_DEF_DIM (nid, "altitude", llm, idim_s)
+        ierr = NF_DEF_DIM (nid, "interlayer", llmp1, idim_sig)
+        ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_tim)
+      endif
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,rlonu)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR (nid,nvarid,rlatu)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,rlonv)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,rlatv)
+c
+      if (start_file_type.eq."earth") then
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,nivsigs)
+c
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,nivsig)
+      endif ! of if (start_file_type.eq."earth")
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,ap)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,bp)
+c
+      if (start_file_type.ne."earth") then
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"aps",NF_DOUBLE,1,idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"aps",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 37,
+     .                       "Coef AS: hybrid pressure at midlayers")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,aps)
+c
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"bps",NF_DOUBLE,1,idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"bps",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 34,
+     .                       "Coef BS: hybrid sigma at midlayers")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,bps)
+      endif ! of if (start_file_type.ne."earth")
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,presnivs)
+c
+      if (start_file_type.ne."earth") then
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR(nid,"latitude",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+        ierr = NF_DEF_VAR(nid,"latitude",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+        ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .        "North latitude")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,rlatu*180/pi)
+c
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr=NF_DEF_VAR(nid,"longitude",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+        ierr=NF_DEF_VAR(nid,"longitude",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .        "East longitude")
+        ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,rlonv*180/pi)
+c
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1,
+     .       idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1,
+     .       idim_s,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"pseudo-alt")
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,pseudoalt)
+      endif ! of if (start_file_type.ne."earth")
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,cu)
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,cv)
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,aire)
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,phis)
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+      if (start_file_type.eq."earth") then
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      else ! start_file_type=="planeto"
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"Time",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"Time",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+      endif ! of if (start_file_type.eq."earth")
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nqtot.GE.1) THEN
+      DO iq=1,nqtot
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+      ENDIF
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      write(lunout,*)'dynredem0: iim,jjm,llm,iday_end',
+     &               iim,jjm,llm,iday_end
+      write(lunout,*)'dynredem0: rad,omeg,g,cpp,kappa',
+     &        rad,omeg,g,cpp,kappa
+
+      RETURN
+      END
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE dynredem1(fichnom,time,
+     .                     vcov,ucov,teta,q,masse,ps)
+      USE infotrac
+      USE control_mod, only : planet_type
+      use netcdf, only: NF90_get_VAR
+      use netcdf95, only: NF95_PUT_VAR
+ 
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "iniprint.h"
+
+
+      INTEGER l
+      REAL vcov(iip1,jjm,llm),ucov(iip1, jjp1,llm) 
+      REAL teta(iip1, jjp1,llm)                   
+      REAL ps(iip1, jjp1),masse(iip1, jjp1,llm)                   
+      REAL q(iip1, jjp1, llm, nqtot)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid, nid_trac, nvarid_trac
+      REAL trac_tmp(ip1jmp1,llm)      
+      INTEGER ierr, ierr_file 
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character(len=*),parameter :: modname='dynredem1'
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+      character(len=12) :: start_file_type="earth" ! default start file type
+
+      if ((planet_type.eq."generic").or.(planet_type.eq."mars")) then
+          write(lunout,*) trim(modname),' : Planeto-like start file'
+          start_file_type="planeto"
+      else
+          write(lunout,*) trim(modname),' : Earth-like start file'
+      endif 
+
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynredem1: Pb. d ouverture "//trim(fichnom)
+         CALL abort_gcm("dynredem1", "", 1)
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      if (start_file_type.eq."earth") then
+        ierr = NF_INQ_VARID(nid, "temps", nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+          write(lunout,*) NF_STRERROR(ierr)
+          abort_message='Variable temps n est pas definie'
+          CALL abort_gcm(modname,abort_message,ierr)
+        ENDIF
+      else
+        ierr = NF_INQ_VARID(nid,"Time", nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+          write(lunout,*) NF_STRERROR(ierr)
+          abort_message='Variable Time not found'
+          CALL abort_gcm(modname,abort_message,ierr)
+        ENDIF
+      endif ! of if (start_file_type.eq."earth") 
+      call NF95_PUT_VAR(nid,nvarid,time,start=(/nb/))
+      write(lunout,*) "dynredem1: Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      ierr = NF90_GET_VAR(nid, nvarid, tab_cntrl)
+      if (start_file_type=="earth") then
+        tab_cntrl(31) = REAL(itau_dyn + itaufin)
+      else
+        tab_cntrl(31) = 0
+      endif
+      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="Variable ucov n est pas definie"
+         ierr=1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,ucov,start=(/1,1,1,nb/))
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="Variable vcov n est pas definie"
+         ierr=1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,vcov,start=(/1,1,1,nb/))
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="Variable teta n est pas definie"
+         ierr=1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,teta,start=(/1,1,1,nb/))
+
+      IF (type_trac == 'inca') THEN
+! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc
+         ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
+         IF (ierr_file .NE.NF_NOERR) THEN
+            write(lunout,*)'dynredem1: Pb d''ouverture du fichier',
+     &                     ' start_trac.nc'
+            write(lunout,*)' ierr = ', ierr_file 
+         ENDIF
+      END IF
+
+      IF(nqtot.GE.1) THEN
+      do iq=1,nqtot 
+
+         IF (type_trac /= 'inca') THEN
+            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+            IF (ierr .NE. NF_NOERR) THEN
+               abort_message="Variable  tname(iq) n est pas definie"
+               ierr=1
+               CALL abort_gcm(modname,abort_message,ierr)
+            ENDIF
+            call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq),start=(/1,1,1,nb/))
+        ELSE ! type_trac = inca
+! lecture de la valeur du traceur dans start_trac.nc
+           IF (ierr_file .ne. 2) THEN
+             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
+             IF (ierr .NE. NF_NOERR) THEN
+                write(lunout,*) "dynredem1: ",trim(tname(iq)),
+     &                          " est absent de start_trac.nc"
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   abort_message="dynredem1: Variable "//
+     &                     trim(tname(iq))//" n est pas definie"
+                   ierr=1
+                   CALL abort_gcm(modname,abort_message,ierr)
+                ENDIF
+                call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
+                
+             ELSE
+                write(lunout,*) "dynredem1: ",trim(tname(iq)),
+     &              " est present dans start_trac.nc"
+               ierr = NF90_GET_VAR(nid_trac, nvarid_trac, trac_tmp)
+                IF (ierr .NE. NF_NOERR) THEN
+                   abort_message="dynredem1: Lecture echouee pour"//
+     &                    trim(tname(iq))
+                   ierr=1
+                   CALL abort_gcm(modname,abort_message,ierr)
+                ENDIF
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   abort_message="dynredem1: Variable "//
+     &                trim(tname(iq))//" n est pas definie"
+                   ierr=1
+                   CALL abort_gcm(modname,abort_message,ierr)
+                ENDIF
+                call NF95_PUT_VAR(nid, nvarid, trac_tmp)
+               
+             ENDIF ! IF (ierr .NE. NF_NOERR)
+! fin lecture du traceur
+          ELSE                  ! si il n'y a pas de fichier start_trac.nc
+!             print *, 'il n y a pas de fichier start_trac'
+             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+             IF (ierr .NE. NF_NOERR) THEN
+                abort_message="dynredem1: Variable "//
+     &                trim(tname(iq))//" n est pas definie"
+                   ierr=1
+                   CALL abort_gcm(modname,abort_message,ierr)
+             ENDIF
+             call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq),
+     &                  start=(/1,1,1,nb/))
+          ENDIF ! (ierr_file .ne. 2)
+       END IF   !type_trac
+      
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Variable masse n est pas definie"
+         ierr=1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,masse,start=(/1,1,1,nb/))
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Variable ps n est pas definie"
+         ierr=1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,ps,start=(/1,1,nb/))
+
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ener.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ener.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ener.h	(revision 222)
@@ -0,0 +1,18 @@
+!
+! $Id: ener.h 1447 2010-10-22 16:18:27Z jghattas $
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez Ã  n'utiliser que des ! pour les commentaires
+!                 et Ã  bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+! INCLUDE 'ener.h'
+
+      COMMON/ener/ang0,etot0,ptot0,ztot0,stot0,                         &
+     &            ang,etot,ptot,ztot,stot,rmsdpdt ,                     &
+     &            rmsv,gtot(llmm1)
+
+      REAL ang0,etot0,ptot0,ztot0,stot0,                                &
+     &     ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/enercin.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/enercin.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/enercin.F	(revision 222)
@@ -0,0 +1,98 @@
+!
+! $Header$
+!
+      SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i
+
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = iip2, ip1jm, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+
+      DO 3 i = 1, iim
+      ecinni(i) = vcov(    i  ,  l) * vcont(    i    ,l) * aire(   i   )
+      ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+   3  CONTINUE
+
+      ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+      ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+      DO 4 ij = 1,iip1
+      ecin(   ij     , l ) = ecinpn
+      ecin( ij+ ip1jm, l ) = ecinps
+   4  CONTINUE
+
+   5  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/exner_hyb_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/exner_hyb_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/exner_hyb_m.F90	(revision 222)
@@ -0,0 +1,146 @@
+module exner_hyb_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_hyb ( ngrid, ps, p, pks, pk, pkf )
+
+    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !                                 -------- z
+    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    !    on determine successivement , du haut vers le bas des couches, les 
+    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+    !
+    !
+    !
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom.h"
+    include "comvert.h"
+    include "serre.h"
+
+    INTEGER  ngrid
+    REAL p(ngrid,llmp1),pk(ngrid,llm)
+    real, optional:: pkf(ngrid,llm)
+    REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL unpl2k,dellta
+
+    logical,save :: firstcall=.true.
+    character(len=*),parameter :: modname="exner_hyb"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+
+       DO   ij  = 1, ngrid
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+       ENDDO
+
+       if (present(pkf)) then
+          pkf = pk
+          CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    unpl2k    = 1.+ 2.* kappa
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    DO   ij  = 1, ngrid
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+
+    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+    !
+    DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+    ENDDO
+    !
+    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+    !
+    DO l = llm -1 , 2 , -1
+       !
+       DO ij = 1, ngrid
+          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+          beta (ij,l)  =   p(ij,l  ) / dellta   
+       ENDDO
+    ENDDO
+
+    !  ***********************************************************************
+    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+    !
+    DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
+            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+    ENDDO
+    !
+    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+    !
+    DO l = 2, llm
+       DO   ij   = 1, ngrid
+          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+       ENDDO
+    ENDDO
+
+    if (present(pkf)) then
+       !    calcul de pkf
+       pkf = pk
+       CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_hyb
+
+end module exner_hyb_m
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/exner_milieu_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/exner_milieu_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/exner_milieu_m.F90	(revision 222)
@@ -0,0 +1,125 @@
+module exner_milieu_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_milieu ( ngrid, ps, p, pks, pk, pkf )
+    !
+    !     Auteurs :  F. Forget , Y. Wanherdrick
+    ! P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !     WARNING : CECI est une version speciale de exner_hyb originale
+    !               Utilise dans la version martienne pour pouvoir 
+    !               tourner avec des coordonnees verticales complexe
+    !              => Il ne verifie PAS la condition la proportionalite en 
+    !              energie totale/ interne / potentielle (F.Forget 2001)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    !
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom.h"
+    include "comvert.h"
+    include "serre.h"
+
+    INTEGER  ngrid
+    REAL p(ngrid,llmp1),pk(ngrid,llm)
+    real, optional:: pkf(ngrid,llm)
+    REAL ps(ngrid),pks(ngrid)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL dum1
+
+    logical,save :: firstcall=.true.
+    character(len=*),parameter :: modname="exner_milieu"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+
+       DO   ij  = 1, ngrid
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+       ENDDO
+
+       if (present(pkf)) then
+          pkf = pk
+          CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    DO   ij  = 1, ngrid
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+
+    !    .... Calcul de pk  pour la couche l 
+    !    --------------------------------------------
+    !
+    dum1 = cpp * (2*preff)**(-kappa) 
+    DO l = 1, llm-1
+       DO   ij   = 1, ngrid
+          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+       ENDDO
+    ENDDO
+
+    !    .... Calcul de pk  pour la couche l = llm ..
+    !    (on met la meme distance (en log pression)  entre Pk(llm)
+    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+    DO   ij   = 1, ngrid
+       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+    ENDDO
+
+    if (present(pkf)) then
+       !    calcul de pkf
+       pkf = pk
+       CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_milieu
+
+end module exner_milieu_m
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/extrapol.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/extrapol.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/extrapol.F	(revision 222)
@@ -0,0 +1,200 @@
+!
+! $Id: extrapol.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+C
+C
+      SUBROUTINE extrapol (pfild, kxlon, kylat, pmask,
+     .                   norsud, ldper, knbor, pwork)
+      IMPLICIT none
+c
+c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
+c Fill up missed values by using the neighbor points
+c
+      INTEGER kxlon, kylat ! longitude and latitude dimensions (Input)
+      INTEGER knbor ! minimum neighbor number (Input)
+      LOGICAL norsud ! True if field is from North to South (Input)
+      LOGICAL ldper ! True if take into account the periodicity (Input)
+      REAL pmask ! mask value (Input)
+      REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
+      REAL pwork(kxlon,kylat) ! working space
+c
+      REAL zwmsk
+      INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
+      INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates
+      REAL zmask(9)
+C
+C  We search over the eight closest neighbors
+C
+C            j+1  7  8  9
+C              j  4  5  6    Current point 5 --> (i,j)
+C            j-1  1  2  3
+C                i-1 i i+1
+c
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      incre = 0
+c
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         pwork(i,j) = pfild(i,j)
+      ENDDO
+      ENDDO
+c
+C* To avoid problems in floating point tests
+      zwmsk = pmask - 1.0
+c
+200   CONTINUE
+      incre = incre + 1
+      DO 99999 j = 1, kylat
+      DO 99999 i = 1, kxlon
+      IF (pfild(i,j).GT. zwmsk) THEN
+         pwork(i,j) = pfild(i,j)
+         inbor = 0
+         ideb = 1
+         ifin = 9
+C
+C* Fill up ix array
+         ix(1) = MAX (1,i-1)
+         ix(2) = i
+         ix(3) = MIN (kxlon,i+1)
+         ix(4) = MAX (1,i-1)
+         ix(5) = i
+         ix(6) = MIN (kxlon,i+1)
+         ix(7) = MAX (1,i-1)
+         ix(8) = i
+         ix(9) = MIN (kxlon,i+1)
+C
+C* Fill up iy array
+         jy(1) = MAX (1,j-1)
+         jy(2) = MAX (1,j-1)
+         jy(3) = MAX (1,j-1)
+         jy(4) = j
+         jy(5) = j
+         jy(6) = j
+         jy(7) = MIN (kylat,j+1)
+         jy(8) = MIN (kylat,j+1)
+         jy(9) = MIN (kylat,j+1)
+C
+C* Correct latitude bounds if southernmost or northernmost points
+         IF (j .EQ. 1) ideb = 4
+         IF (j .EQ. kylat) ifin = 6
+C
+C* Account for periodicity in longitude
+C
+         IF (ldper) THEN 
+            IF (i .EQ. kxlon) THEN
+               ix(3) = 1
+               ix(6) = 1
+               ix(9) = 1
+            ELSE IF (i .EQ. 1) THEN
+               ix(1) = kxlon
+               ix(4) = kxlon
+               ix(7) = kxlon
+            ENDIF
+         ELSE
+            IF (i .EQ. 1) THEN
+               ix(1) = i
+               ix(2) = i + 1
+               ix(3) = i
+               ix(4) = i + 1
+               ix(5) = i
+               ix(6) = i + 1
+            ENDIF 
+            IF (i .EQ. kxlon) THEN
+               ix(1) = i -1
+               ix(2) = i
+               ix(3) = i - 1
+               ix(4) = i
+               ix(5) = i - 1
+               ix(6) = i
+            ENDIF
+C
+            IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN 
+               jy(1) = MAX (1,j-1)
+               jy(2) = MAX (1,j-1)
+               jy(3) = j
+               jy(4) = j
+               jy(5) = MIN (kylat,j+1)
+               jy(6) = MIN (kylat,j+1)
+C
+               ideb = 1
+               ifin = 6
+               IF (j .EQ. 1) ideb = 3
+               IF (j .EQ. kylat) ifin = 4
+            ENDIF
+         ENDIF ! end for ldper test
+C
+C* Find unmasked neighbors
+C
+         DO 230 k = ideb, ifin
+            zmask(k) = 0.
+            ilon = ix(k)
+            jlat = jy(k)
+            IF (pfild(ilon,jlat) .LT. zwmsk) THEN
+               zmask(k) = 1.
+               inbor = inbor + 1
+            ENDIF
+ 230     CONTINUE
+C
+C* Not enough points around point P are unmasked; interpolation on P 
+C  will be done in a future call to extrap.
+C
+         IF (inbor .GE. knbor) THEN
+            pwork(i,j) = 0.
+            DO k = ideb, ifin
+               ilon = ix(k)
+               jlat = jy(k)
+               pwork(i,j) = pwork(i,j)
+     $                      + pfild(ilon,jlat) * zmask(k)/REAL(inbor)
+            ENDDO
+         ENDIF
+C
+      ENDIF
+99999 CONTINUE
+C
+C*    3. Writing back unmasked field in pfild
+C        ------------------------------------
+C
+C* pfild then contains:
+C     - Values which were not masked
+C     - Interpolated values from the inbor neighbors
+C     - Values which are not yet interpolated
+C
+      idoit = 0
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1
+         pfild(i,j) = pwork(i,j)
+      ENDDO
+      ENDDO
+c
+      IF (idoit .ne. 0) GOTO 200
+ccc      PRINT*, "Number of extrapolation steps incre =", incre
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/flumass.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/flumass.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/flumass.F	(revision 222)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
+     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
+     * pbarv( ip1jm,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+
+      REAL       SSUM
+
+
+      DO  5 l = 1,llm
+
+      DO  1 ij = iip2,ip1jm
+      pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1  CONTINUE
+
+      DO 3 ij = 1,ip1jm
+      pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      sairen = SSUM( iim,  aire(   1     ), 1 )
+      saireun= SSUM( iim, aireu(   1     ), 1 )
+      saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+      saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+      DO 20 l = 1,llm
+
+      ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+
+      pbaru(    1   ,l )=   pbarv(    1     ,l ) - ctn * aire(    1    )
+      pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 )
+
+      DO 11 i = 2,iim
+      pbaru(    i    ,l ) = pbaru(   i - 1   ,l )    +
+     *                      pbarv(    i      ,l ) - ctn * aire(   i    )
+
+      pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l )    -
+     *                      pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm)
+  11  CONTINUE
+      DO 12 i = 1,iim
+      apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+      apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+  12  CONTINUE
+      ctn0 = -SSUM( iim,apbarun,1 )/saireun
+      cts0 = -SSUM( iim,apbarus,1 )/saireus
+      DO 14 i = 1,iim
+      pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+      pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+  14  CONTINUE
+
+      pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+      pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+  20  CONTINUE
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxhyp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxhyp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxhyp.F	(revision 222)
@@ -0,0 +1,471 @@
+!
+! $Id: fxhyp.F 1674 2012-10-29 16:27:03Z emillour $
+!
+c
+c
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
+
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+c    Calcule les longitudes et derivees dans la grille du GCM pour une
+c     fonction f(x) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
+c     dzoom  etant  la distance totale de la zone du zoom
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
+c
+c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
+c   ********************************************************************
+
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+       LOGICAL scal180
+       PARAMETER ( scal180 = .TRUE. )
+
+c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
+c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
+c      sinon scal180 = .FALSE.
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,dzooma,tau,grossism
+
+c    ......   arguments  de  sortie  ......
+
+       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
+     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
+
+c     .... variables locales  ....
+c
+       REAL   dzoom
+       REAL(KIND=8) xlon(iip1),xprimm(iip1),xuv
+       REAL(KIND=8) xtild(0:nmax2)
+       REAL(KIND=8) fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
+       REAL(KIND=8) Xf(0:nmax2),xxpr(0:nmax2)
+       REAL(KIND=8) xvrai(iip1),xxprim(iip1) 
+       REAL(KIND=8) pi,depi,epsilon,xzoom,fa,fb
+       REAL(KIND=8) Xf1, Xfi , a0,a1,a2,a3,xi2
+       INTEGER i,it,ik,iter,ii,idif,ii1,ii2
+       REAL(KIND=8) xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL(KIND=8) champmin,champmax,decalx
+       INTEGER is2
+       SAVE is2
+
+       REAL(KIND=8) heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-3
+       xzoom    = xzoomdeg * pi/180. 
+c
+       if (iim==1) then
+
+          rlonm025(1)=-pi/2.
+          rlonv(1)=0.
+          rlonu(1)=pi
+          rlonp025(1)=pi/2.
+          rlonm025(2)=rlonm025(1)+depi
+          rlonv(2)=rlonv(1)+depi
+          rlonu(2)=rlonu(1)+depi
+          rlonp025(2)=rlonp025(1)+depi
+
+          xprimm025(:)=1.
+          xprimv(:)=1.
+          xprimu(:)=1.
+          xprimp025(:)=1.
+          champmin=depi
+          champmax=depi
+          return
+
+       endif
+
+           decalx   = .75
+       IF( grossism.EQ.1..AND.scal180 )  THEN
+           decalx   = 1.
+       ENDIF
+
+       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
+c
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * depi
+       ELSEIF( dzooma.LT. 25. ) THEN
+         WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) xzoom,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        xtild(i) = - pi + REAL(i) * depi /nmax2
+       ENDDO
+
+       DO i = nmax, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fhyp ( i ) = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fhyp ( i )  =   1.
+                ENDIF
+            ELSE
+                    fhyp ( i )  =  TANH ( fa/fb )
+            ENDIF
+         ENDIF
+        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
+        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+
+       ffdx = 0.
+
+       DO i = nmax +1,nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fxm   = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fxm   =   1.
+                ENDIF
+            ELSE
+                    fxm   =  TANH ( fa/fb )
+            ENDIF
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm  =  1.
+       IF ( xmoy.EQ. pi )  fxm  = -1.
+
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT_GCM("FXHYP", "", 1)
+       ENDIF
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = nmax, nmax2
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i =  nmax+1, nmax2
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+       Xf(0) = - pi
+
+       DO i =  nmax +1, nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm =  1.
+       IF ( xmoy.EQ. pi )  fxm = -1.
+       xxpr(i)    = beta + ( grossism - beta ) * fxm
+
+       ENDDO
+
+       DO i = nmax+1, nmax2
+        xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1, 4
+
+       IF( ik.EQ.1 )        THEN
+         xuv =  -0.25
+       ELSE IF ( ik.EQ.2 )  THEN
+         xuv =   0.
+       ELSE IF ( ik.EQ.3 )  THEN
+         xuv =   0.50
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+      xo1   = 0.
+
+      ii1=1
+      ii2=iim
+      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
+        ii1 = 2 
+        ii2 = iim+1
+      ENDIF
+      DO 1500 i = ii1, ii2
+
+      xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim) 
+
+      Xfi    = xlon2
+c
+      DO 250 it =  nmax2,0,-1
+      IF( Xfi.GE.Xf(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+
+350   CONTINUE
+
+c    ......  Calcul de   Xf(xi)    ...... 
+c
+      xi  = xtild(it)
+
+      IF(it.EQ.nmax2)  THEN
+       it       = nmax2 -1
+       Xf(it+1) = pi
+      ENDIF
+c  .....................................................................
+c
+c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
+c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
+c          et (Xf(it+1),xtild(it+1) )
+
+       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
+     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
+
+       Xf1     = Xf(it)
+       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
+
+       DO 500 iter = 1,300
+        xi = xi - ( Xf1 - Xfi )/ Xprimin
+
+        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
+         xo1      = xi
+         xi2      = xi * xi
+         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
+         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
+550   CONTINUE
+
+       xxprim(i) = depi/ ( REAL(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
+
+1500   CONTINUE
+
+
+
+       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
+         xvrai(1)    = xvrai(iip1)-depi
+         xxprim(1)   = xxprim(iip1)
+       ENDIF
+
+       DO i = 1 , iim
+        xlon(i)     = xvrai(i)
+        xprimm(i)   = xxprim(i)
+       ENDDO
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
+        ENDIF
+       ENDDO
+c
+c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
+c   ........................................................................
+
+       champmin =  1.e12
+       champmax = -1.e12
+       DO i = 1, iim
+        champmin = MIN( champmin,xvrai(i) )
+        champmax = MAX( champmax,xvrai(i) )
+       ENDDO
+
+      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
+                GO TO 1600
+      ELSE
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
+ 80       CONTINUE
+          is2 = i
+          ENDIF
+
+          IF( is2.NE. 1 )  THEN
+            DO ii = is2 , iim
+             xlon  (ii-is2+1) = xvrai(ii)
+             xprimm(ii-is2+1) = xxprim(ii)
+            ENDDO
+            DO ii = 1 , is2 -1
+             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
+             xprimm(ii+iim-is2+1) = xxprim(ii) 
+            ENDDO
+          ENDIF
+        ELSE 
+          IF( ik.EQ.1 )  THEN
+           DO i = iim,1,-1
+             IF( xvrai(i).LE. pi ) GO TO 90
+           ENDDO
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+           idif = iim -is2
+           DO ii = 1, is2
+            xlon  (ii+idif) = xvrai(ii)
+            xprimm(ii+idif) = xxprim(ii)
+           ENDDO
+           DO ii = 1, idif
+            xlon (ii)  = xvrai (ii+is2) - depi
+            xprimm(ii) = xxprim(ii+is2) 
+           ENDDO
+         ENDIF
+      ENDIF
+c
+c     .........   Fin  de la reorganisation   ............................
+
+ 1600    CONTINUE
+
+
+         xlon  ( iip1)  = xlon(1) + depi
+         xprimm( iip1 ) = xprimm (1 )
+       
+         DO i = 1, iim+1
+         xvrai(i) = xlon(i)*180./pi
+         ENDDO
+
+         IF( ik.EQ.1 )  THEN
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim +1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.2 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.3)   THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.4 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+
+         ENDIF
+
+5000    CONTINUE
+c
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+18     FORMAT(/)
+24     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
+68     FORMAT(1x,7f9.2)
+566    FORMAT(1x,7f9.4)
+
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxy.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxy.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxy.F	(revision 222)
@@ -0,0 +1,69 @@
+!
+! $Id: fxy.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+      IMPLICIT NONE
+
+c     Auteur  :  P. Le Van
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c           a tangente sinusoidale et eventuellement avec zoom  .
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "serre.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_new.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( REAL( j )        )
+         yprimu(j) = fyprim( REAL( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
+         rlatu1(j) = fy    ( REAL( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( REAL( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( REAL( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
+        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   REAL( i )          )
+           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
+        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
+        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  REAL( i )          )
+         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxyhyper.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxyhyper.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxyhyper.F	(revision 222)
@@ -0,0 +1,139 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy  ,   
+     ,                       xzoom, grossx, dzoomx,taux  ,
+     , rlatu,yprimu,rlatv,yprimv,rlatu1,  yprimu1,  rlatu2,  yprimu2  , 
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       IMPLICIT NONE
+c
+c      Auteur :  P. Le Van .
+c
+c      d'apres  formulations de R. Sadourny .
+c
+c
+c     Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp )
+c            par des  fonctions  a tangente hyperbolique .
+c
+c     Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom
+c                      et  yzoom )   :  
+c
+c     a) le grossissement du zoom  :  grossy  ( en y ) et grossx ( en x )
+c     b) l' extension     du zoom  :  dzoomy  ( en y ) et dzoomx ( en x )
+c     c) la raideur de la transition du zoom  :   taux et tauy   
+c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+
+c   .....  Arguments  ...
+c
+       REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+       REAL(KIND=8)  dxmin, dxmax , dymin, dymax
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy  , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  dymin,dymax                                               )
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax         )
+
+
+        DO i = 1, iip1
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         STOP 13
+       ENDIF
+c
+       IF(rlatu2(j).LE.rlatu(j+1))  THEN
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FY **** '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Latitudes  '
+        WRITE(6,*) ' *********** '
+        WRITE(6,18)
+        WRITE(6,3)  dymin, dymax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Longitudes  '
+        WRITE(6,*) ' ************ '
+        WRITE(6,18)
+        WRITE(6,3)  dxmin, dxmax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+        WRITE(6,18)
+c
+3      Format(1x, ' Au centre du zoom , la longueur de la maille est',
+     ,  ' d environ ',f8.2 ,' degres  ',
+     , ' alors que la maille en dehors de la zone du zoom est d environ
+     , ', f8.2,' degres ' )
+18      FORMAT(/)
+
+       RETURN
+       END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxysinus.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxysinus.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fxysinus.F	(revision 222)
@@ -0,0 +1,69 @@
+!
+! $Id: fxysinus.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+
+      IMPLICIT NONE
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c            avec y = Asin( j )  .
+c
+c     Auteur  :  P. Le Van
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_sin.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( REAL( j )        )
+         yprimu(j) = fyprim( REAL( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
+         rlatu1(j) = fy    ( REAL( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( REAL( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( REAL( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
+        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   REAL( i )          )
+           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
+        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
+        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  REAL( i )          )
+         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fyhyp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fyhyp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/fyhyp.F	(revision 222)
@@ -0,0 +1,378 @@
+!
+! $Id: fyhyp.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+c
+c
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau  ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  champmin,champmax                                            ) 
+
+cc    ...  Version du 01/04/2001 ....
+
+       IMPLICIT NONE
+c
+c    ...   Auteur :  P. Le Van  ... 
+c
+c    .......    d'apres  formulations  de R. Sadourny  .......
+c
+c     Calcule les latitudes et derivees dans la grille du GCM pour une
+c     fonction f(y) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc)
+c     dzoom  etant  la distance totale de la zone du zoom ( en radians )
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom   
+c
+c
+c N.B : Il vaut mieux avoir : grossism * dzoom  <  pi/2  (radians) ,en lati.
+c      ********************************************************************
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzooma,tau 
+c         ( rentres  par  run.def )
+
+c     .......  arguments  de sortie   .......
+c
+       REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+
+c
+c     .....     champs  locaux    .....
+c
+     
+       REAL   dzoom
+       REAL(KIND=8) ylat(jjp1), yprim(jjp1)
+       REAL(KIND=8) yuv
+       REAL(KIND=8) yt(0:nmax2)
+       REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2)
+       SAVE Ytprim, yt,Yf
+       REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2)
+       REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm
+       REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax
+       REAL(KIND=8) yfi,Yf1,ffdy
+       REAL(KIND=8) ypn,deply,y00
+       SAVE y00, deply
+
+       INTEGER i,j,it,ik,iter,jlat
+       INTEGER jpn,jjpn
+       SAVE jpn
+       REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m
+       REAL(KIND=8) fa(0:nmax2),fb(0:nmax2)
+       REAL y0min,y0max
+
+       REAL(KIND=8)     heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       pis2     = pi/2.
+       pisjm    = pi/ REAL(jjm)
+       epsilon  = 1.e-3
+       y0       =  yzoomdeg * pi/180. 
+
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * pi
+       ELSEIF( dzooma.LT. 12. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,18)
+       WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) y0,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        yt(i) = - pis2  + REAL(i)* pi /nmax2
+       ENDDO
+
+       heavyy0m = heavyside( -y0 )
+       heavyy0  = heavyside(  y0 )
+       y0min    = 2.*y0*heavyy0m - pis2
+       y0max    = 2.*y0*heavyy0  + pis2
+
+       fa = 999.999
+       fb = 999.999
+       
+       DO i = 0, nmax2 
+        IF( yt(i).LT.y0 )  THEN
+         fa (i) = tau*  (yt(i)-y0+dzoom/2. )
+         fb(i) =   (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) )
+        ELSEIF ( yt(i).GT.y0 )  THEN
+         fa(i) =   tau *(y0-yt(i)+dzoom/2. )
+         fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) 
+       ENDIF
+        
+       IF( 200.* fb(i) .LT. - fa(i) )   THEN
+         fhyp ( i) = - 1.
+       ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fhyp ( i) =   1.
+       ELSE  
+         fhyp(i) =  TANH ( fa(i)/fb(i) )
+       ENDIF
+
+       IF( yt(i).EQ.y0 )  fhyp(i) = 1.
+       IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT_GCM("FYHYP", "", 1)
+
+       ENDIF
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax2
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+
+c   .....  Calcul  de  Yf     ........
+
+       Yf(0) = - pis2
+       DO i = 1, nmax2
+        yypr(i)    = beta + ( grossism - beta ) * fxm(i)
+       ENDDO
+
+       DO i=1,nmax2
+        Yf(i)   = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) )
+       ENDDO
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1,4
+
+       IF( ik.EQ.1 )  THEN
+         yuv  = 0.
+         jlat = jjm + 1
+       ELSE IF ( ik.EQ.2 )  THEN
+         yuv  = 0.5
+         jlat = jjm 
+       ELSE IF ( ik.EQ.3 )  THEN
+         yuv  = 0.25
+         jlat = jjm 
+       ELSE IF ( ik.EQ.4 )  THEN
+         yuv  = 0.75
+         jlat = jjm 
+       ENDIF
+c
+       yo1   = 0.
+       DO 1500 j =  1,jlat
+        yo1   = 0.
+        ylon2 =  - pis2 + pisjm * ( REAL(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
+       DO 250 it =  nmax2,0,-1
+        IF( yfi.GE.Yf(it))  GO TO 350
+250    CONTINUE
+       it = 0
+350    CONTINUE
+
+       yi = yt(it)
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = pis2
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1),   
+     ,                  yt(it),yt(it+1) ,   a0,a1,a2,a3   )      
+
+       Yf1     = Yf(it)
+       Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi
+
+       DO 500 iter = 1,300
+         yi = yi - ( Yf1 - yfi )/ Yprimin
+
+        IF( ABS(yi-yo1).LE.epsilon)  GO TO 550
+         yo1      = yi
+         yi2      = yi * yi
+         Yf1      = a0 +  a1 * yi +     a2 * yi2  +     a3 * yi2 * yi
+         Yprimin  =       a1      + 2.* a2 *  yi  + 3.* a3 * yi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
+550   CONTINUE
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
+
+1500    CONTINUE
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         WRITE(6,*) ' PBS. avec  rlat(',j+1,') plus petit que rlat(',j,
+     ,  ')'
+         STOP 3
+        ENDIF
+       ENDDO
+
+       WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2'
+     , ,' et  pi/2 '
+c
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 
+          DO j = jlat,1,-1
+           IF( yvrai(j).LE. ypn ) GO TO 1502
+          ENDDO
+1502     CONTINUE
+
+         jpn   = j
+         y00   = yvrai(jpn)
+         deply = pis2 -  y00
+        ENDIF
+
+         DO  j = 1, jjm +1 - jpn
+           ylatt (j)  = -pis2 - y00  + yvrai(jpn+j-1)
+           yprimm(j)  = yprim(jpn+j-1)
+         ENDDO
+
+         jjpn  = jpn
+         IF( jlat.EQ. jjm ) jjpn = jpn -1
+
+         DO j = 1,jjpn 
+          ylatt (j + jjm+1 -jpn) = yvrai(j) + deply
+          yprimm(j + jjm+1 -jpn) = yprim(j)
+         ENDDO
+
+c      ***********   Fin de la reorganisation     *************
+c
+ 1600   CONTINUE
+
+       DO j = 1, jlat
+          ylat(j) =  ylatt( jlat +1 -j )
+         yprim(j) = yprimm( jlat +1 -j )
+       ENDDO
+  
+        DO j = 1, jlat
+         yvrai(j) = ylat(j)*180./pi
+        ENDDO
+
+        IF( ik.EQ.1 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U   apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 2 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*) ' YLAT   en V  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*)' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 3 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U + 0.75  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT en U + 0.25  apres ( en  deg. ) '
+c         WRITE(6,68)(yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,68) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+
+        ENDIF
+
+5000   CONTINUE
+c
+        WRITE(6,18)
+c
+c  .....     fin de la boucle  do 5000 .....
+
+        DO j = 1, jjm
+         ylat(j) = rrlatu(j) - rrlatu(j+1)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO j = 1, jjm
+         champmin = MIN( champmin, ylat(j) )
+         champmax = MAX( champmax, ylat(j) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+24     FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3)
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/geopot.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/geopot.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/geopot.F	(revision 222)
@@ -0,0 +1,64 @@
+!
+! $Header$
+!
+      SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    ....   calcul du geopotentiel aux milieux des couches    .....
+c    *******************************************************************
+c
+c     ....   l'integration se fait de bas en haut  ....
+c
+c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+c              phi               est un  argum. de sortie pour le s-pg .
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER ngrid
+      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
+     *       phi(ngrid,llm)
+
+
+c   Local:
+c   ------
+
+      INTEGER  l, ij
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+
+      DO   1  ij  = 1, ngrid
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+   1  CONTINUE
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = 1,ngrid
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_dyn_fi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_dyn_fi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_dyn_fi.F	(revision 222)
@@ -0,0 +1,38 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+c   traitement des poles
+      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
+      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
+
+c   traitement des point normaux
+      DO ifield=1,nfield
+         DO j=2,jm-1
+	    ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_ecrit_fi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_ecrit_fi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_ecrit_fi.F	(revision 222)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+	SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi)
+
+	IMPLICIT none
+
+c Transformer une variable de la grille d'ecriture a la grille physique
+	
+	INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield)
+c
+      INTEGER i, j, n, ig
+c
+c	print*,'iim jjm ',iim,jjm
+
+c modif par abd 21 02 01
+
+        jjm = jjmp1 - 1
+	do n = 1, nfield
+	    fi(1,n) = ecrit(1,1,n)
+            fi(nlon,n) = ecrit(1,jjm+1,n)
+         DO j = 2, jjm
+            ig = 2+(j-2)*iim
+            DO i = 1, iim
+	     fi(ig-1+i,n) = ecrit(i,j,n)
+            ENDDO
+         ENDDO
+      ENDDO
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_fi_dyn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_fi_dyn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_fi_dyn.F	(revision 222)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      DO ifield=1,nfield
+c   traitement des poles
+         DO i=1,im
+            pdyn(i,1,ifield)=pfi(1,ifield)
+            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+         ENDDO
+
+c   traitement des point normaux
+         DO j=2,jm-1
+	    ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
+	    pdyn(im,j,ifield)=pdyn(1,j,ifield)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_int_dyn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_int_dyn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_int_dyn.F	(revision 222)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      subroutine gr_int_dyn(champin,champdyn,iim,jp1)
+      implicit none
+c=======================================================================
+c   passage d'un champ interpole a un champ sur grille scalaire
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER iim
+      integer ip1, jp1
+      REAL champin(iim, jp1)
+      REAL champdyn(iim+1, jp1)
+
+      INTEGER i, j
+      real polenord, polesud
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      ip1 = iim + 1
+      polenord = 0.
+      polesud = 0.
+      do i = 1, iim
+        polenord = polenord + champin (i, 1)
+        polesud = polesud + champin (i, jp1)
+      enddo
+      polenord = polenord / iim
+      polesud = polesud / iim
+      do j = 1, jp1
+        do i = 1, iim
+          if (j .eq. 1) then
+            champdyn(i, j) = polenord
+          else if (j .eq. jp1) then
+            champdyn(i, j) = polesud
+          else
+            champdyn(i, j) = champin (i, j)
+          endif
+        enddo
+        champdyn(ip1, j) = champdyn(1, j)
+      enddo
+
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_u_scal.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_u_scal.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_u_scal.F	(revision 222)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_u_scal(nx,x_u,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=ip1jmp1,2,-1
+            x_scal(ij,l)=
+     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
+     s      /(aireu(ij)+aireu(ij-1))
+         ENDDO
+      ENDDO
+
+      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_v_scal.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_v_scal.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gr_v_scal.F	(revision 222)
@@ -0,0 +1,64 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_v_scal(nx,x_v,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=iip2,ip1jm
+            x_scal(ij,l)=
+     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
+     s      /(airev(ij-iip1)+airev(ij))
+         ENDDO
+         DO ij=1,iip1
+            x_scal(ij,l)=0.
+         ENDDO
+         DO ij=ip1jm+1,ip1jmp1
+            x_scal(ij,l)=0.
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grad.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grad.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grad.F	(revision 222)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+      SUBROUTINE  grad(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      INTEGER klevel
+      REAL  pg( ip1jmp1,klevel )
+      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+      INTEGER  l,ij
+c
+c
+      DO 6 l = 1,klevel
+c
+      DO 2  ij = 1, ip1jmp1 - 1
+      pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = iip1, ip1jmp1, iip1
+      pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      DO 4 ij = 1,ip1jm
+      pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradiv.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradiv.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradiv.F	(revision 222)
@@ -0,0 +1,57 @@
+!
+! $Header$
+!
+      SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c    Auteur :   P. Le Van
+c
+c   ***************************************************************
+c
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   ****************************************************************
+c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
+
+      REAL div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+c
+c
+      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+c
+      DO 10 iter = 1,ld
+c
+      CALL  diverg( klevel,  gdx , gdy, div          )
+      CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 )
+      CALL    grad( klevel,  div, gdx, gdy           )
+c
+      DO 5  l = 1, klevel
+      DO 3 ij = 1, ip1jmp1
+      gdx( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+      DO 4 ij = 1, ip1jm
+      gdy( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradiv2.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradiv2.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradiv2.F	(revision 222)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c     P. Le Van
+c
+c   **********************************************************
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   **********************************************************
+c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+c
+c     ........    variables en arguments      ........
+
+      INTEGER klevel
+      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL   gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL div(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      
+c    ........................................................
+c
+c
+      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+
+
+      CALL    divergf( klevel, gdx,   gdy , div )
+
+      IF( ld.GT.1 )   THEN
+
+        CALL laplacien ( klevel, div,  div     )
+
+c    ......  Iteration de l'operateur laplacien_gam   .......
+
+        DO iter = 1, ld -2
+         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
+     *                       unsapolnga1, unsapolsga1,  div, div       )
+        ENDDO
+
+      ENDIF
+
+
+       CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
+       CALL  grad  ( klevel,  div,   gdx,  gdy             )
+
+c
+       DO   l = 1, klevel
+         DO  ij = 1, ip1jmp1
+          gdx( ij,l ) = gdx( ij,l ) * nugrads
+         ENDDO
+         DO  ij = 1, ip1jm
+          gdy( ij,l ) = gdy( ij,l ) * nugrads
+         ENDDO
+       ENDDO
+c
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradsdef.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradsdef.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/gradsdef.h	(revision 222)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+      integer nfmx,imx,jmx,lmx,nvarmx
+      parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000)
+
+      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
+
+      integer imd(imx),jmd(jmx),lmd(lmx)
+      integer iid(imx),jid(jmx)
+      integer ifd(imx),jfd(jmx)
+      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
+
+      integer nvar(nfmx),ivar(nfmx)
+      logical firsttime(nfmx)
+
+      character*10 var(nvarmx,nfmx),fichier(nfmx)
+      character*40 title(nfmx),tvar(nvarmx,nfmx)
+
+      common/gradsdef/xd,yd,zd,dtime,
+     s   imd,jmd,lmd,iid,jid,ifd,jfd,
+     s   unit,irec,nvar,ivar,itime,nld,firsttime,
+     s   var,fichier,title,tvar
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grid_atob.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grid_atob.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grid_atob.F	(revision 222)
@@ -0,0 +1,971 @@
+!
+! $Id: grid_atob.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Aucune ponderation est consideree (voir grille_p)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+      REAL distans(2200*1100)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+c Calculer les limites des zones des nouveaux points
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c Determiner la zone sur laquelle chaque ancien point se trouve
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               number(ii,jj) = number(ii,jj) + 1.0
+               sortie(ii,jj) = sortie(ii,jj) + entree(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c Si aucun ancien point tombe sur une zone, c'est un probleme
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT_GCM("", "", 1)
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+      SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Consideration de la distance des points (voir grille_m)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(200),d(200)
+      REAL number(400,200)
+      INTEGER indx(400,200), indy(400,200)
+      REAL dist(400,200), distsom(400,200)
+c
+      IF (imar.GT.400 .OR. jmar.GT.200) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+      IF (imdep.GT.400 .OR. jmdep.GT.200) THEN
+         PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+c calculer les bords a et b de la nouvelle grille
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+c
+c calculer les bords c et d de la nouvelle grille
+c
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+c
+c trouver les indices (indx,indy) de la nouvelle grille sur laquelle
+c un point de l'ancienne grille est tombe.
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               indx(i,j) = ii
+               indy(i,j) = jj
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c faire une verification
+c
+
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN
+            PRINT*, 'Probleme grave,i,j,indx,indy=',
+     .              i,j,indx(i,j),indy(i,j)
+            CALL abort_gcm("", "", 1)
+         ENDIF
+      ENDDO
+      ENDDO
+
+c
+c calculer la distance des anciens points avec le nouveau point,
+c on prend ensuite une sorte d'inverse pour ponderation.
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         distsom(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2
+     .                     +(ydata(j)-y(indy(i,j)))**2 )
+         distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j))
+     .                                  + dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1.
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j))
+      ENDDO
+      ENDDO
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j))
+     .                                 + entree(i,j) * dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j))
+     .                                 + dist(i,j)
+      ENDDO
+      ENDDO
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT_GCM("", "", 1)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+      SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief,
+     .                    imar, jmar, x, y, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique
+c                           un champ indicateur (masque) terre/ocean
+c                           terre:1; ocean:0
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL relief(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL num_tot(2200,1100), num_oce(2200,1100)
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_oce(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+               IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) )
+     .             num_oce(ii,jj) = num_oce(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+c
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN
+              mask(i,j) = 0.
+           ELSE
+              mask(i,j) = 1.
+           ENDIF
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT_GCM("", "", 1)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c
+c
+
+
+      SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une
+c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur
+c fixe (0.001m).
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar), mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_tot(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              sortie(ii,jj)  = sortie(ii,jj) + LOG(entree(i,j))
+              num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+       IF (NINT(mask(i,j)).EQ.1) THEN
+         IF (num_tot(i,j) .GT. 0.0) THEN
+            sortie(i,j) = sortie(i,j) / num_tot(i,j)
+            sortie(i,j) = EXP(sortie(i,j))
+         ELSE
+            PRINT*, 'probleme,i,j=', i,j
+ccc            CALL ABORT_GCM("", "", 1)
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+       ELSE
+         sortie(i,j) = 0.001
+       ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+
+      SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01,
+     .                    imar, jmar, x, y, frac_ice)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la
+c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace
+c (entre 0 et 1) dans une grille plus grossiere.
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL glace01(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL frac_ice(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400), num_ice(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_ice(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+             num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+              IF (NINT(glace01(i,j)).EQ.1 ) 
+     .       num_ice(ii,jj) = num_ice(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF (num_ice(i,j).GT.0.001) THEN
+            frac_ice(i,j) = num_ice(i,j) / num_tot(i,j)
+           ELSE
+              frac_ice(i,j) = 0.0
+           ENDIF
+         ELSE
+           PRINT*, 'probleme,i,j=', i,j
+ccc           CALL ABORT_GCM("", "", 1)
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN
+            frac_ice(i,j) = 1.0
+         ELSE
+            frac_ice(i,j) = 0.0
+         ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+      SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief,
+     .                    immod, jmmod, xmod, ymod, rugs)
+c=======================================================================
+c Calculer la longueur de rugosite liee au relief en utilisant
+c l'ecart-type dans une maille de 1x1
+C=======================================================================
+      IMPLICIT none
+c
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      REAL amin, AMAX
+c
+      INTEGER imrel, jmrel
+      REAL xrel(imrel),yrel(jmrel)
+      REAL relief(imrel,jmrel)
+c
+      INTEGER immod, jmmod
+      REAL xmod(immod),ymod(jmmod)
+      REAL rugs(immod,jmmod)
+c
+      INTEGER imtmp, jmtmp
+      PARAMETER (imtmp=360,jmtmp=180)
+      REAL xtmp(imtmp), ytmp(jmtmp)
+      REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp)
+      REAL zzzz
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+c
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+c
+      IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN
+         PRINT*, 'immod ou jmmod trop grand', immod, jmmod
+         CALL ABORT_GCM("", "", 1)
+      ENDIF
+c
+c Calculs intermediares:
+c
+      xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0
+      DO i = 2, imtmp
+         xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp)
+      ENDDO
+      DO i = 1, imtmp
+         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+      ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0
+      DO j = 2, jmtmp
+         ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp)
+      ENDDO
+      DO j = 1, jmtmp
+         ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+c
+      a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0
+      b(1) = (xtmp(1)+xtmp(2))/2.0
+      DO i = 2, imtmp-1
+         a(i) = b(i-1)
+         b(i) = (xtmp(i)+xtmp(i+1))/2.0
+      ENDDO
+      a(imtmp) = b(imtmp-1)
+      b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0
+
+      c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0
+      d(1) = (ytmp(1)+ytmp(2))/2.0
+      DO j = 2, jmtmp-1
+         c(j) = d(j-1)
+         d(j) = (ytmp(j)+ytmp(j+1))/2.0
+      ENDDO
+      c(jmtmp) = d(jmtmp-1)
+      d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0
+
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         number(i,j) = 0.0
+         cham1tmp(i,j) = 0.0
+         cham2tmp(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imtmp
+      DO jj = 1, jmtmp
+        DO i = 1, imrel
+         IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmrel
+          IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j)
+              cham2tmp(ii,jj) = cham2tmp(ii,jj) 
+     .                              + relief(i,j)*relief(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         IF (number(i,j) .GT. 0.001) THEN
+         cham1tmp(i,j) = cham1tmp(i,j) / number(i,j)
+         cham2tmp(i,j) = cham2tmp(i,j) / number(i,j)
+         zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2
+         if (zzzz .lt. 0.0) then
+           if (zzzz .gt. -7.5) then
+             zzzz = 0.0
+             print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0'
+           else
+              stop 'Pb rugsoro, zzzz <-7.5'
+           endif
+         endif
+         cham2tmp(i,j) = SQRT(zzzz)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT_GCM("", "", 1)
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = cham2tmp(1,1)
+      AMAX = cham2tmp(1,1)
+      DO j = 1, jmtmp
+      DO i = 1, imtmp
+         IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j)
+         IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type 1x1:', amin, AMAX
+c
+c
+c
+      a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0
+      b(1) = (xmod(1)+xmod(2))/2.0
+      DO i = 2, immod-1
+         a(i) = b(i-1)
+         b(i) = (xmod(i)+xmod(i+1))/2.0
+      ENDDO
+      a(immod) = b(immod-1)
+      b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0
+
+      c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0
+      d(1) = (ymod(1)+ymod(2))/2.0
+      DO j = 2, jmmod-1
+         c(j) = d(j-1)
+         d(j) = (ymod(j)+ymod(j+1))/2.0
+      ENDDO
+      c(jmmod) = d(jmmod-1)
+      d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         number(i,j) = 0.0
+         rugs(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, immod
+      DO jj = 1, jmmod
+        DO i = 1, imtmp
+         IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmtmp
+          IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              rugs(ii,jj) = rugs(ii,jj)
+     .                       + LOG(MAX(0.001_8,cham2tmp(i,j)))
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         IF (number(i,j) .GT. 0.001) THEN
+         rugs(i,j) = rugs(i,j) / number(i,j)
+         rugs(i,j) = EXP(rugs(i,j))
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT_GCM("", "", 1)
+         CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imtmp*jmtmp,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imtmp*jmtmp
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imtmp + 1
+         i_proche = ij_proche - (j_proche-1)*imtmp
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche)))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type du modele:', amin, AMAX
+c
+      DO j = 1, jmmod
+      DO i = 1, immod
+         rugs(i,j) = rugs(i,j) / AMAX * 20.0
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Longueur de rugosite du modele:', amin, AMAX
+c
+      RETURN
+      END
+c
+      SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance)
+c
+c Auteur: Laurent Li (le 30 decembre 1996)
+c
+c Ce programme calcule la distance minimale (selon le grand cercle)
+c entre deux points sur la terre
+c
+c Input:
+      INTEGER im, jm ! dimensions
+      REAL rf_lon ! longitude du point de reference (degres)
+      REAL rf_lat ! latitude du point de reference (degres)
+      REAL rlon(im), rlat(jm) ! longitude et latitude des points
+c
+c Output:
+      REAL distance(im,jm) ! distances en metre
+c
+      REAL rlon1, rlat1
+      REAL rlon2, rlat2
+      REAL dist
+      REAL pa, pb, p, pi
+c
+      REAL radius
+      PARAMETER (radius=6371229.)
+c
+      pi = 4.0 * ATAN(1.0)
+c
+      DO 9999 j = 1, jm
+      DO 9999 i = 1, im
+c
+      rlon1=rf_lon
+      rlat1=rf_lat
+      rlon2=rlon(i)
+      rlat2=rlat(j)
+      pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a
+      pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b
+      p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens)
+c
+      dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p))
+      dist = radius * dist
+      distance(i,j) = dist
+c
+ 9999 CONTINUE
+c
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90	(revision 222)
@@ -0,0 +1,237 @@
+!
+! $Header$
+!
+! This subroutine creates the file grilles_gcm.nc containg longitudes and
+! latitudes in degrees for grid u and v. This subroutine is called from
+! ce0l if grilles_gcm_netcdf=TRUE. This subroutine corresponds to the first 
+! part in the program create_fausse_var.
+!
+SUBROUTINE grilles_gcm_netcdf_sub(masque,phis)
+
+  IMPLICIT NONE
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comconst.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "comvert.h"
+  INCLUDE "netcdf.inc"
+  INCLUDE "serre.h"
+
+
+  REAL,DIMENSION(iip1,jjp1),INTENT(IN)  :: masque ! masque terre/mer
+  REAL,DIMENSION(iip1,jjp1),INTENT(IN)  :: phis   ! geopotentiel au sol
+
+  REAL temp(iim+1,jjm+1)
+  ! Attributs netcdf sortie
+  INTEGER ncid_out,rcode_out
+  INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid,out_levid
+  INTEGER out_varid
+  INTEGER out_lonudim,out_lonvdim
+  INTEGER out_latudim,out_latvdim,out_dim(3)
+  INTEGER out_levdim
+
+  INTEGER, PARAMETER :: longcles = 20
+  REAL  clesphy0(longcles)
+
+  INTEGER start(4),COUNT(4)
+
+  INTEGER status,i,j
+  REAL rlatudeg(jjp1),rlatvdeg(jjm),rlevdeg(llm)
+  REAL rlonudeg(iip1),rlonvdeg(iip1)
+
+  REAL dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
+  REAL acoslat,dxkm,dykm,resol(iip1,jjp1)
+  REAL,DIMENSION(iip1,jjp1)  :: phis_loc
+  INTEGER masque_int(iip1,jjp1)
+  INTEGER :: phis_id
+  INTEGER :: area_id
+  INTEGER :: mask_id
+  
+  rad = 6400000
+  omeg = 7.272205e-05
+  g = 9.8
+  kappa = 0.285716
+  daysec = 86400
+  cpp = 1004.70885
+
+  preff = 101325.
+  pa= 50000.
+
+  CALL conf_gcm( 99, .TRUE. , clesphy0 )
+  CALL iniconst
+  CALL inigeom
+
+  DO j=1,jjp1
+     rlatudeg(j)=rlatu(j)*180./pi
+  ENDDO
+  DO j=1,jjm
+     rlatvdeg(j)=rlatv(j)*180./pi
+  ENDDO
+
+  DO i=1,iip1
+     rlonudeg(i)=rlonu(i)*180./pi + 360.
+     rlonvdeg(i)=rlonv(i)*180./pi + 360.
+  ENDDO
+
+
+  !  2 ----- OUVERTURE DE LA SORTIE NETCDF
+  ! ---------------------------------------------------
+  ! CREATION OUTPUT
+  ! ouverture fichier netcdf de sortie out
+  status=NF_CREATE('grilles_gcm.nc',NF_NOCLOBBER,ncid_out)
+  status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
+  status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
+  status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
+  status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
+
+
+  !   Longitudes en u
+  status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, out_lonuid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', 12,'degrees_east')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',9,'Longitude en u')
+
+  !   Longitudes en v
+  status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, out_lonvid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', 12,'degrees_east')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', 9,'Longitude en v')
+
+  !   Latitude en u
+  status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, out_latuid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', 13,'degrees_north')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', 8,'Latitude en u')
+
+  !  Latitude en v
+  status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, out_latvid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', 13,'degrees_north')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', 8,'Latitude en v')
+
+  !   ecriture de la grille u
+  out_dim(1)=out_lonudim
+  out_dim(2)=out_latudim
+  status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, out_varid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point u')
+
+  !   ecriture de la grille v
+  out_dim(1)=out_lonvdim
+  out_dim(2)=out_latvdim
+  status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, out_varid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point v')
+
+  !   ecriture de la grille u
+  out_dim(1)=out_lonvdim
+  out_dim(2)=out_latudim
+  status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, out_varid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',16,'Grille aux point u')
+
+  status=NF_ENDDEF(ncid_out)
+  ! 5) ----- FERMETURE DES FICHIERS NETCDF------------------
+  ! --------------------------------------------------------
+  ! 3-b- Ecriture de la grille pour la sortie
+  ! rajoute l'ecriture de la grille
+
+#ifdef NC_DOUBLE
+  status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+  status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+  status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+  status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#else
+  status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+  status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+  status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+  status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#endif
+
+  start(1)=1
+  start(2)=1
+  start(3)=1
+  start(4)=1
+
+  COUNT(1)=iim+1
+  COUNT(2)=jjm+1
+  COUNT(3)=1
+  COUNT(4)=1
+
+  DO j=1,jjm+1
+     DO i=1,iim+1
+        temp(i,j)=MOD(i,2)+MOD(j,2)
+     ENDDO
+  ENDDO
+
+#ifdef NC_DOUBLE
+  status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, count,temp)
+#else
+  status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, count,temp)
+#endif
+
+  ! On re-ouvre le fichier pour rajouter 4 nouvelles variables necessaire pour INCA
+! lev - phis - aire - mask
+  rlevdeg(:) = presnivs
+  phis_loc(:,:) = phis(:,:)/g
+
+! niveaux de pression verticaux
+  status = NF_REDEF (ncid_out)
+  status=NF_DEF_DIM(ncid_out,'lev',llm,out_levdim)
+  
+! fields
+  out_dim(1)=out_lonvdim
+  out_dim(2)=out_latudim
+
+  status = nf_def_var(ncid_out,'phis',NF_FLOAT,2,out_dim,phis_id)
+  CALL handle_err(status)
+  status = nf_def_var(ncid_out,'aire',NF_FLOAT,2,out_dim,area_id)
+  CALL handle_err(status)
+  status = nf_def_var(ncid_out,'mask',NF_INT  ,2,out_dim,mask_id)
+  CALL handle_err(status)
+
+  status=NF_ENDDEF(ncid_out)
+
+  ! ecriture des variables
+#ifdef NC_DOUBLE
+  status=NF_PUT_VARA_DOUBLE(ncid_out,out_levid,1,llm,rlevdeg)
+#else
+  status=NF_PUT_VARA_REAL(ncid_out,out_levid,1,llm,rlevdeg)
+#endif
+
+  start(1)=1
+  start(2)=1
+  start(3)=1
+  start(4)=0
+  COUNT(1)=iip1
+  COUNT(2)=jjp1
+  COUNT(3)=1
+  COUNT(4)=0
+
+  status = nf_put_vara_double(ncid_out, phis_id,start,count, phis_loc)
+  status = nf_put_vara_double(ncid_out, area_id,start,count, aire)
+  masque_int(:,:) = nINT(masque(:,:))
+  status = nf_put_vara_int(ncid_out, mask_id,start,count,masque_int)
+  CALL handle_err(status)
+  
+  ! fermeture du fichier netcdf
+  CALL ncclos(ncid_out,rcode_out)
+
+END SUBROUTINE grilles_gcm_netcdf_sub
+
+
+
+SUBROUTINE handle_err(status)
+  INCLUDE "netcdf.inc"
+
+  INTEGER status
+  IF (status.NE.nf_noerr) THEN
+     PRINT *,NF_STRERROR(status)
+     CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1)
+  ENDIF
+END SUBROUTINE handle_err
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/heavyside.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/heavyside.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/heavyside.F	(revision 222)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+c
+c
+       FUNCTION heavyside(a)
+
+c      ...   P. Le Van  ....
+c
+       IMPLICIT NONE
+
+       REAL(KIND=8) heavyside , a
+
+       IF ( a.LE.0. )  THEN
+         heavyside = 0.
+       ELSE
+         heavyside = 1.
+       ENDIF
+
+       RETURN
+       END
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/infotrac.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/infotrac.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/infotrac.F90	(revision 222)
@@ -0,0 +1,436 @@
+! $Id$
+!
+MODULE infotrac
+
+! nqtot : total number of tracers and higher order of moment, water vapor and liquid included
+  INTEGER, SAVE :: nqtot
+
+! nbtr : number of tracers not including higher order of moment or water vapor or liquid
+!        number of tracers used in the physics
+  INTEGER, SAVE :: nbtr
+
+! Name variables
+  CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
+  CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics
+
+! iadv  : index of trasport schema for each tracer
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iadv
+
+! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the 
+!         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
+
+! conv_flg(it)=0 : convection desactivated for tracer number it 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: conv_flg
+! pbl_flg(it)=0  : boundary layer diffusion desactivaded for tracer number it 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: pbl_flg
+
+  CHARACTER(len=4),SAVE :: type_trac
+ 
+CONTAINS
+
+  SUBROUTINE infotrac_init
+    USE control_mod
+#ifdef REPROBUS
+    USE CHEM_REP, ONLY : Init_chem_rep_trac
+#endif
+    IMPLICIT NONE
+!=======================================================================
+!
+!   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+!   -------
+!   Modif special traceur F.Forget 05/94
+!   Modif M-A Filiberti 02/02 lecture de traceur.def
+!
+!   Objet:
+!   ------
+!   GCM LMD nouvelle grille
+!
+!=======================================================================
+!   ... modification de l'integration de q ( 26/04/94 ) ....
+!-----------------------------------------------------------------------
+! Declarations
+
+    INCLUDE "dimensions.h"
+    INCLUDE "iniprint.h"
+
+! Local variables
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv  ! index of horizontal trasport schema
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv  ! index of vertical trasport schema
+
+    CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0  ! tracer short name
+    CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA
+    CHARACTER(len=3), DIMENSION(30) :: descrq
+    CHARACTER(len=1), DIMENSION(3)  :: txts
+    CHARACTER(len=2), DIMENSION(9)  :: txtp
+    CHARACTER(len=23)               :: str1,str2
+  
+    INTEGER :: nqtrue  ! number of tracers read from tracer.def, without higer order of moment
+    INTEGER :: iq, new_iq, iiq, jq, ierr, ierr2, ierr3
+    
+    character(len=80) :: line ! to store a line of text
+ 
+    character(len=*),parameter :: modname="infotrac_init"
+!-----------------------------------------------------------------------
+! Initialization :
+!
+    txts=(/'x','y','z'/)
+    txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/)
+
+    descrq(14)='VLH'
+    descrq(10)='VL1'
+    descrq(11)='VLP'
+    descrq(12)='FH1'
+    descrq(13)='FH2'
+    descrq(16)='PPM'
+    descrq(17)='PPS'
+    descrq(18)='PPP'
+    descrq(20)='SLP'
+    descrq(30)='PRA'
+    
+    IF (planet_type=='earth') THEN
+     ! Coherence test between parameter type_trac, config_inca and preprocessing keys
+     IF (type_trac=='inca') THEN
+       WRITE(lunout,*) 'You have choosen to couple with INCA chemestry model : type_trac=', &
+            type_trac,' config_inca=',config_inca
+       IF (config_inca/='aero' .AND. config_inca/='chem') THEN
+          WRITE(lunout,*) 'Incoherence between type_trac and config_inca. Model stops. Modify run.def'
+          CALL abort_gcm('infotrac_init','Incoherence between type_trac and config_inca',1)
+       END IF
+#ifndef INCA
+       WRITE(lunout,*) 'To run this option you must add cpp key INCA and compile with INCA code'
+       CALL abort_gcm('infotrac_init','You must compile with cpp key INCA',1)
+#endif
+     ELSE IF (type_trac=='repr') THEN
+       WRITE(lunout,*) 'You have choosen to couple with REPROBUS chemestry model : type_trac=', type_trac
+#ifndef REPROBUS
+       WRITE(lunout,*) 'To run this option you must add cpp key REPROBUS and compile with REPRPBUS code'
+       CALL abort_gcm('infotrac_init','You must compile with cpp key REPROBUS',1)
+#endif
+     ELSE IF (type_trac == 'lmdz') THEN
+       WRITE(lunout,*) 'Tracers are treated in LMDZ only : type_trac=', type_trac
+     ELSE
+       WRITE(lunout,*) 'type_trac=',type_trac,' not possible. Model stops'
+       CALL abort_gcm('infotrac_init','bad parameter',1)
+     END IF
+
+     ! Test if config_inca is other then none for run without INCA
+     IF (type_trac/='inca' .AND. config_inca/='none') THEN
+       WRITE(lunout,*) 'config_inca will now be changed to none as you do not couple with INCA model'
+       config_inca='none'
+     END IF
+    ELSE
+     type_trac='plnt'  ! planets... May want to dissociate between each later.
+    ENDIF ! of IF (planet_type=='earth')
+
+!-----------------------------------------------------------------------
+!
+! 1) Get the true number of tracers + water vapor/liquid
+!    Here true tracers (nqtrue) means declared tracers (only first order)
+!
+!-----------------------------------------------------------------------
+    IF (planet_type=='earth') THEN
+     IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN
+       OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
+       IF(ierr.EQ.0) THEN
+          WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
+          READ(90,*) nqtrue
+       ELSE 
+          WRITE(lunout,*) trim(modname),': Problem in opening traceur.def'
+          WRITE(lunout,*) trim(modname),': WARNING using defaut values'
+          nqtrue=4 ! Defaut value
+       END IF
+       ! For Earth, water vapour & liquid tracers are not in the physics
+       nbtr=nqtrue-2
+     ELSE ! type_trac=inca
+       ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F 
+       nqtrue=nbtr+2
+     END IF
+
+     IF (nqtrue < 2) THEN
+       WRITE(lunout,*) trim(modname),': nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum'
+       CALL abort_gcm('infotrac_init','Not enough tracers',1)
+     END IF
+
+! Transfert number of tracers to Reprobus
+     IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+       CALL Init_chem_rep_trac(nbtr)
+#endif
+     END IF
+
+    ELSE  ! not Earth
+       OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
+       IF(ierr.EQ.0) THEN
+          WRITE(lunout,*) 'Open traceur.def : ok'
+          READ(90,*) nqtrue
+       ELSE 
+          WRITE(lunout,*) 'Problem in opening traceur.def'
+          WRITE(lunout,*) 'ATTENTION using defaut values: nqtrue=1'
+          nqtrue=1 ! Defaut value
+       END IF
+       ! Other planets (for now); we have the same number of tracers
+       ! in the dynamics than in the physics
+       nbtr=nqtrue
+     
+    ENDIF  ! planet_type
+!
+! Allocate variables depending on nqtrue and nbtr
+!
+    ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue))
+    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr))
+    conv_flg(:) = 1 ! convection activated for all tracers
+    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
+
+!-----------------------------------------------------------------------
+! 2)     Choix  des schemas d'advection pour l'eau et les traceurs
+!
+!     iadv = 1    schema  transport type "humidite specifique LMD"
+!     iadv = 2    schema   amont
+!     iadv = 14   schema  Van-leer + humidite specifique 
+!                            Modif F.Codron
+!     iadv = 10   schema  Van-leer (retenu pour l'eau vapeur et liquide)
+!     iadv = 11   schema  Van-Leer pour hadv et version PPM (Monotone) pour vadv
+!     iadv = 12   schema  Frederic Hourdin I
+!     iadv = 13   schema  Frederic Hourdin II
+!     iadv = 16   schema  PPM Monotone(Collela & Woodward 1984)
+!     iadv = 17   schema  PPM Semi Monotone (overshoots autorisés)
+!     iadv = 18   schema  PPM Positif Defini (overshoots undershoots autorisés)
+!     iadv = 20   schema  Slopes
+!     iadv = 30   schema  Prather
+!
+!        Dans le tableau q(ij,l,iq) : iq = 1  pour l'eau vapeur
+!                                     iq = 2  pour l'eau liquide
+!       Et eventuellement             iq = 3,nqtot pour les autres traceurs
+!
+!        iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+!------------------------------------------------------------------------
+!
+!    Get choice of advection schema from file tracer.def or from INCA
+!---------------------------------------------------------------------
+    IF (planet_type=='earth') THEN
+     IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN
+       IF(ierr.EQ.0) THEN
+          ! Continue to read tracer.def
+          DO iq=1,nqtrue
+             READ(90,*) hadv(iq),vadv(iq),tnom_0(iq)
+          END DO
+          CLOSE(90)  
+       ELSE ! Without tracer.def, set default values (for Earth!)
+         if ((nqtrue==4).and.(planet_type=="earth")) then
+          hadv(1) = 14
+          vadv(1) = 14
+          tnom_0(1) = 'H2Ov'
+          hadv(2) = 10
+          vadv(2) = 10
+          tnom_0(2) = 'H2Ol'
+          hadv(3) = 10
+          vadv(3) = 10
+          tnom_0(3) = 'RN'
+          hadv(4) = 10
+          vadv(4) = 10
+          tnom_0(4) = 'PB'
+         else
+           ! Error message, we need a traceur.def file
+           write(lunout,*) trim(modname),&
+           ': Cannot set default tracer names!'
+           write(lunout,*) trim(modname),' Make a traceur.def file!!!'
+           CALL abort_gcm('infotrac_init','Need a traceur.def file!',1)
+         endif ! of if (nqtrue==4)
+       END IF
+       
+       WRITE(lunout,*) trim(modname),': Valeur de traceur.def :'
+       WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue
+       DO iq=1,nqtrue
+          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq)
+       END DO
+
+     ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
+! le module de chimie fournit les noms des traceurs
+! et les schemas d'advection associes.
+     
+#ifdef INCA
+       CALL init_transport( &
+            hadv, &
+            vadv, &
+            conv_flg, &
+            pbl_flg,  &
+            tracnam)
+#endif
+       tnom_0(1)='H2Ov'
+       tnom_0(2)='H2Ol'
+
+       DO iq =3,nqtrue
+          tnom_0(iq)=tracnam(iq-2)
+       END DO
+
+     END IF ! type_trac
+
+    ELSE  ! not Earth
+       IF(ierr.EQ.0) THEN
+          ! Continue to read tracer.def
+          DO iq=1,nqtrue
+             !READ(90,*) hadv(iq),vadv(iq),tnom_0(iq)
+            ! try to be smart when reading traceur.def
+            read(90,'(80a)') line ! store the line from traceur.def
+            ! assume format is hadv,vadv,tnom_0
+            read(line,*,iostat=ierr2) hadv(iq),vadv(iq),tnom_0(iq)
+            if (ierr2.ne.0) then
+              ! maybe format is tnom0,hadv,vadv
+              read(line,*,iostat=ierr3) tnom_0(iq),hadv(iq),vadv(iq)
+              if (ierr3.ne.0) then
+                ! assume only tnom0 is provided (havd and vad default to 10)
+                read(line,*) tnom_0(iq)
+                hadv(iq)=10
+                vadv(iq)=10
+              endif
+            endif ! of if(ierr2.ne.0)
+          END DO ! of DO iq=1,nqtrue
+          CLOSE(90)  
+       ELSE ! Without tracer.def
+          hadv(1) = 10
+          vadv(1) = 10
+          tnom_0(1) = 'dummy'
+       END IF
+       
+       WRITE(lunout,*) trim(modname),': Valeur de traceur.def :'
+       WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue
+       DO iq=1,nqtrue
+          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq)
+       END DO
+
+    ENDIF  ! planet_type
+
+!-----------------------------------------------------------------------
+!
+! 3) Verify if advection schema 20 or 30 choosen
+!    Calculate total number of tracers needed: nqtot
+!    Allocate variables depending on total number of tracers
+!-----------------------------------------------------------------------
+    new_iq=0
+    DO iq=1,nqtrue
+       ! Add tracers for certain advection schema
+       IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN
+          new_iq=new_iq+1  ! no tracers added
+       ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN
+          new_iq=new_iq+4  ! 3 tracers added
+       ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN
+          new_iq=new_iq+10 ! 9 tracers added
+       ELSE
+          WRITE(lunout,*) trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
+          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1)
+       END IF
+    END DO
+    
+    IF (new_iq /= nqtrue) THEN
+       ! The choice of advection schema imposes more tracers
+       ! Assigne total number of tracers
+       nqtot = new_iq
+
+       WRITE(lunout,*) trim(modname),': The choice of advection schema for one or more tracers'
+       WRITE(lunout,*) 'makes it necessary to add tracers'
+       WRITE(lunout,*) trim(modname)//': ',nqtrue,' is the number of true tracers'
+       WRITE(lunout,*) trim(modname)//': ',nqtot, ' is the total number of tracers needed'
+
+    ELSE
+       ! The true number of tracers is also the total number
+       nqtot = nqtrue
+    END IF
+
+!
+! Allocate variables with total number of tracers, nqtot
+!
+    ALLOCATE(tname(nqtot), ttext(nqtot))
+    ALLOCATE(iadv(nqtot), niadv(nqtot))
+
+!-----------------------------------------------------------------------
+!
+! 4) Determine iadv, long and short name
+!
+!-----------------------------------------------------------------------
+    new_iq=0
+    DO iq=1,nqtrue
+       new_iq=new_iq+1
+
+       ! Verify choice of advection schema
+       IF (hadv(iq)==vadv(iq)) THEN
+          iadv(new_iq)=hadv(iq)
+       ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN
+          iadv(new_iq)=11
+       ELSE
+          WRITE(lunout,*)trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
+
+          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1)
+       END IF
+      
+       str1=tnom_0(iq)
+       tname(new_iq)= tnom_0(iq)
+       IF (iadv(new_iq)==0) THEN
+          ttext(new_iq)=trim(str1)
+       ELSE
+          ttext(new_iq)=trim(tnom_0(iq))//descrq(iadv(new_iq))
+       END IF
+
+       ! schemas tenant compte des moments d'ordre superieur
+       str2=ttext(new_iq)
+       IF (iadv(new_iq)==20) THEN
+          DO jq=1,3
+             new_iq=new_iq+1
+             iadv(new_iq)=-20
+             ttext(new_iq)=trim(str2)//txts(jq)
+             tname(new_iq)=trim(str1)//txts(jq)
+          END DO
+       ELSE IF (iadv(new_iq)==30) THEN
+          DO jq=1,9
+             new_iq=new_iq+1
+             iadv(new_iq)=-30
+             ttext(new_iq)=trim(str2)//txtp(jq)
+             tname(new_iq)=trim(str1)//txtp(jq)
+          END DO
+       END IF
+    END DO
+
+!
+! Find vector keeping the correspodence between true and total tracers
+!
+    niadv(:)=0
+    iiq=0
+    DO iq=1,nqtot
+       IF(iadv(iq).GE.0) THEN
+          ! True tracer
+          iiq=iiq+1
+          niadv(iiq)=iq
+       ENDIF
+    END DO
+
+
+    WRITE(lunout,*) trim(modname),': Information stored in infotrac :'
+    WRITE(lunout,*) trim(modname),': iadv  niadv tname  ttext :'
+    DO iq=1,nqtot
+       WRITE(lunout,*) iadv(iq),niadv(iq),&
+       ' ',trim(tname(iq)),' ',trim(ttext(iq))
+    END DO
+
+!
+! Test for advection schema. 
+! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) .
+!
+    DO iq=1,nqtot
+       IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN
+          WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
+          CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1)
+       ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN
+          WRITE(lunout,*)trim(modname),'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
+          CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1)
+       END IF
+    END DO
+
+!-----------------------------------------------------------------------
+! Finalize :
+!
+    DEALLOCATE(tnom_0, hadv, vadv)
+    DEALLOCATE(tracnam)
+
+  END SUBROUTINE infotrac_init
+
+END MODULE infotrac
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniacademic.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniacademic.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniacademic.F90	(revision 222)
@@ -0,0 +1,278 @@
+!
+! $Id: iniacademic.F90 1625 2012-05-09 13:14:48Z lguez $
+!
+SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+
+  USE filtreg_mod
+  USE infotrac, ONLY : nqtot
+  USE control_mod, ONLY: day_step,planet_type
+#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 Write_Field
+  use exner_hyb_m, only: exner_hyb
+  use exner_milieu_m, only: exner_milieu
+
+  !   Author:    Frederic Hourdin      original: 15/01/93
+  ! The forcing defined here is from Held and Suarez, 1994, Bulletin
+  ! of the American Meteorological Society, 75, 1825.
+
+  IMPLICIT NONE
+
+  !   Declararations:
+  !   ---------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comconst.h"
+  include "comgeom.h"
+  include "academic.h"
+  include "ener.h"
+  include "temps.h"
+  include "iniprint.h"
+  include "logic.h"
+
+  !   Arguments:
+  !   ----------
+
+  real time_0
+
+  !   variables dynamiques
+  REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+  REAL teta(ip1jmp1,llm)                 ! temperature potentielle
+  REAL q(ip1jmp1,llm,nqtot)               ! champs advectes
+  REAL ps(ip1jmp1)                       ! pression  au sol
+  REAL masse(ip1jmp1,llm)                ! masse d'air
+  REAL phis(ip1jmp1)                     ! geopotentiel au sol
+
+  !   Local:
+  !   ------
+
+  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 phi(ip1jmp1,llm)                  ! geopotentiel
+  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
+  real tetastrat ! potential temperature in the stratosphere, in K
+  real tetajl(jjp1,llm)
+  INTEGER i,j,l,lsup,ij
+
+  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
+  REAL k_f,k_c_a,k_c_s         ! Constantes de rappel
+  LOGICAL ok_geost             ! Initialisation vent geost. ou nul
+  LOGICAL ok_pv                ! Polar Vortex
+  REAL phi_pv,dphi_pv,gam_pv   ! Constantes pour polar vortex 
+
+  real zz,ran1
+  integer idum
+
+  REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
+  
+  character(len=*),parameter :: modname="iniacademic"
+  character(len=80) :: abort_message
+
+  !-----------------------------------------------------------------------
+  ! 1. Initializations for Earth-like case
+  ! --------------------------------------
+  !
+  ! initialize planet radius, rotation rate,...
+  call conf_planete
+
+  time_0=0.
+  day_ref=1
+  annee_ref=0
+
+  im         = iim
+  jm         = jjm
+  day_ini    = 1
+  dtvr    = daysec/REAL(day_step)
+  zdtvr=dtvr
+  etot0      = 0.
+  ptot0      = 0.
+  ztot0      = 0.
+  stot0      = 0.
+  ang0       = 0.
+
+  if (llm == 1) then
+     ! specific initializations for the shallow water case
+     kappa=1
+  endif
+
+  CALL iniconst
+  CALL inigeom
+  CALL inifilr
+
+  if (llm == 1) then
+     ! initialize fields for the shallow water case, if required
+     if (.not.read_start) then
+        phis(:)=0.
+        q(:,:,:)=0
+        CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps)
+     endif
+  endif
+
+  academic_case: if (iflag_phys >= 2) then
+     ! initializations
+
+     ! 1. local parameters
+     ! by convention, winter is in the southern hemisphere
+     ! Geostrophic wind or no wind?
+     ok_geost=.TRUE.
+     CALL getin('ok_geost',ok_geost)
+     ! Constants for Newtonian relaxation and friction
+     k_f=1.                !friction 
+     CALL getin('k_j',k_f)
+     k_f=1./(daysec*k_f)
+     k_c_s=4.  !cooling surface
+     CALL getin('k_c_s',k_c_s)
+     k_c_s=1./(daysec*k_c_s)
+     k_c_a=40. !cooling free atm
+     CALL getin('k_c_a',k_c_a)
+     k_c_a=1./(daysec*k_c_a)
+     ! Constants for Teta equilibrium profile
+     teta0=315.     ! mean Teta (S.H. 315K)
+     CALL getin('teta0',teta0)
+     ttp=200.       ! Tropopause temperature (S.H. 200K)
+     CALL getin('ttp',ttp)
+     eps=0.         ! Deviation to N-S symmetry(~0-20K)
+     CALL getin('eps',eps)
+     delt_y=60.     ! Merid Temp. Gradient (S.H. 60K)
+     CALL getin('delt_y',delt_y)
+     delt_z=10.     ! Vertical Gradient (S.H. 10K)
+     CALL getin('delt_z',delt_z)
+     ! Polar vortex
+     ok_pv=.false.
+     CALL getin('ok_pv',ok_pv)
+     phi_pv=-50.            ! Latitude of edge of vortex
+     CALL getin('phi_pv',phi_pv)
+     phi_pv=phi_pv*pi/180.
+     dphi_pv=5.             ! Width of the edge
+     CALL getin('dphi_pv',dphi_pv)
+     dphi_pv=dphi_pv*pi/180.
+     gam_pv=4.              ! -dT/dz vortex (in K/km)
+     CALL getin('gam_pv',gam_pv)
+
+     ! 2. Initialize fields towards which to relax
+     ! Friction
+     knewt_g=k_c_a
+     DO l=1,llm
+        zsig=presnivs(l)/preff
+        knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3)
+        kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3)
+     ENDDO
+     DO j=1,jjp1
+        clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4
+     ENDDO
+
+     ! Potential temperature 
+     DO l=1,llm
+        zsig=presnivs(l)/preff
+        tetastrat=ttp*zsig**(-kappa)
+        tetapv=tetastrat
+        IF ((ok_pv).AND.(zsig.LT.0.1)) THEN
+           tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g)
+        ENDIF
+        DO j=1,jjp1
+           ! Troposphere
+           ddsin=sin(rlatu(j))
+           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
+                -delt_z*(1.-ddsin*ddsin)*log(zsig)
+           if (planet_type=="giant") then
+             tetajl(j,l)=teta0+(delt_y*                   &
+                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
+                / ((rlatu(j)*3.14159*eps+0.0001)**2))     &
+                -delt_z*log(zsig)
+           endif
+           ! Profil stratospherique isotherme (+vortex)
+           w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2.
+           tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv             
+           tetajl(j,l)=MAX(tetajl(j,l),tetastrat)  
+        ENDDO
+     ENDDO
+
+     !          CALL writefield('theta_eq',tetajl)
+
+     do l=1,llm
+        do j=1,jjp1
+           do i=1,iip1
+              ij=(j-1)*iip1+i
+              tetarappel(ij,l)=tetajl(j,l)
+           enddo
+        enddo
+     enddo
+
+     ! 3. Initialize fields (if necessary)
+     IF (.NOT. read_start) THEN
+        ! surface pressure
+        if (iflag_phys>2) then
+           ! specific value for CMIP5 aqua/terra planets
+           ! "Specify the initial dry mass to be equivalent to
+           !  a global mean surface pressure (101325 minus 245) Pa."
+           ps(:)=101080.  
+        else
+           ! use reference surface pressure
+           ps(:)=preff
+        endif
+        
+        ! ground geopotential
+        phis(:)=0.
+
+        CALL pression ( ip1jmp1, ap, bp, ps, p       )
+        if (pressure_exner) then
+          CALL exner_hyb( ip1jmp1, ps, p, pks, pk)
+        else
+          call exner_milieu(ip1jmp1,ps,p,pks,pk)
+        endif
+        CALL massdair(p,masse)
+
+        ! bulk initialization of temperature
+        teta(:,:)=tetarappel(:,:)
+
+        ! geopotential
+        CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
+
+        ! winds
+        if (ok_geost) then
+           call ugeostr(phi,ucov)
+        else
+           ucov(:,:)=0.
+        endif
+        vcov(:,:)=0.
+
+        ! bulk initialization of tracers
+        if (planet_type=="earth") then
+           ! Earth: first two tracers will be water
+           do i=1,nqtot
+              if (i == 1) q(:,:,i)=1.e-10
+              if (i == 2) q(:,:,i)=1.e-15
+              if (i.gt.2) q(:,:,i)=0.
+           enddo
+        else
+           q(:,:,:)=0
+        endif ! of if (planet_type=="earth")
+
+        ! add random perturbation to temperature
+        idum  = -1
+        zz = ran1(idum)
+        idum  = 0
+        do l=1,llm
+           do ij=iip2,ip1jm
+              teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum))
+           enddo
+        enddo
+
+        ! maintain periodicity in longitude
+        do l=1,llm
+           do ij=1,ip1jmp1,iip1
+              teta(ij+iim,l)=teta(ij,l)
+           enddo
+        enddo
+
+     ENDIF ! of IF (.NOT. read_start)
+  endif academic_case
+
+END SUBROUTINE iniacademic
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniconst.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniconst.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniconst.F90	(revision 222)
@@ -0,0 +1,84 @@
+!
+! $Id: iniconst.F90 1625 2012-05-09 13:14:48Z lguez $
+!
+SUBROUTINE iniconst
+
+  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
+
+  IMPLICIT NONE
+  !
+  !      P. Le Van
+  !
+  !   Declarations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comconst.h"
+  include "temps.h"
+  include "comvert.h"
+  include "iniprint.h"
+
+  character(len=*),parameter :: modname="iniconst"
+  character(len=80) :: abort_message
+  !
+  !
+  !
+  !-----------------------------------------------------------------------
+  !   dimension des boucles:
+  !   ----------------------
+
+  im      = iim
+  jm      = jjm
+  lllm    = llm
+  imp1    = iim 
+  jmp1    = jjm + 1
+  lllmm1  = llm - 1
+  lllmp1  = llm + 1
+
+  !-----------------------------------------------------------------------
+
+  dtphys  = iphysiq * dtvr
+  unsim   = 1./iim
+  pi      = 2.*ASIN( 1. )
+
+  !-----------------------------------------------------------------------
+  !
+
+  r       = cpp * kappa
+
+  write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
+  !
+  !-----------------------------------------------------------------------
+
+  ! vertical discretization: default behavior depends on planet_type flag
+  if (planet_type=="earth") then
+     disvert_type=1
+  else
+     disvert_type=2
+  endif
+  ! but user can also specify using one or the other in run.def:
+  call getin('disvert_type',disvert_type)
+  write(lunout,*) trim(modname),': disvert_type=',disvert_type
+
+  pressure_exner = disvert_type == 1 ! default value
+  call getin('pressure_exner', pressure_exner)
+
+  if (disvert_type==1) then
+     ! standard case for Earth (automatic generation of levels)
+     call disvert()
+  else if (disvert_type==2) then
+     ! standard case for planets (levels generated using z2sig.def file)
+     call disvert_noterre
+  else
+     write(abort_message,*) "Wrong value for disvert_type: ", disvert_type
+     call abort_gcm(modname,abort_message,0)
+  endif
+
+END SUBROUTINE iniconst
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inidissip.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inidissip.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inidissip.F90	(revision 222)
@@ -0,0 +1,338 @@
+!
+! $Id: inidissip.F90 1502 2011-03-21 16:07:54Z jghattas $
+!
+SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  , &
+     tetagdiv,tetagrot,tetatemp, vert_prof_dissip)
+  !=======================================================================
+  !   Initialization for horizontal (lateral) dissipation
+  !  - in all cases, there is a multiplicative coefficient which increases
+  !    the dissipation in the higher levels of the atmosphere, but there
+  !    are different ways of seting the vertical profile of this coefficient
+  !    (see code below).
+  !  - the call to dissipation, every 'dissip_period' dynamical time step,
+  !    can be imposed via 'dissip_period=...' in run.def (or via the
+  !    'idissip=...' flag, but this flag should become obsolete, and is
+  !    overridden by the 'dissip_period' flag). Note that setting 
+  !    dissip_period=0 has the special meaning of requesting an "optimal"
+  !    value for "dissip_period" (then taken as the largest possible value)
+  !  - the three characteristic time scales (relative to the smallest
+  !    longitudinal grid mesh size), which are privided in run.def, which 
+  !    are used for the dissipations steps are:
+  !     tetagdiv : time scale for the gradient of the divergence of velocities
+  !     tetagrot : time scale for the curl of the curl of velocities
+  !     tetatemp : time scale for the laplacian of the potential temperature
+  !=======================================================================
+
+  USE control_mod, only : dissip_period,iperiod,planet_type
+
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissipn.h"
+  include "comconst.h"
+  include "comvert.h"
+  include "logic.h"
+  include "iniprint.h"
+
+  LOGICAL,INTENT(in) :: lstardis
+  INTEGER,INTENT(in) :: nitergdiv,nitergrot,niterh
+  REAL,INTENT(in) :: tetagdiv,tetagrot,tetatemp
+
+  integer, INTENT(in):: vert_prof_dissip ! Vertical profile of horizontal dissipation
+  ! For the Earth model:
+  ! Allowed values:
+  ! 0: rational fraction, function of pressure
+  ! 1: tanh of altitude
+  ! For planets:
+  ! 0: use fac_mid (read from run.def)
+  ! 1: use fac_mid, fac_up, startalt, delta (hard coded in inidissip.F90)
+! Local variables:
+  REAL fact,zvert(llm),zz
+  REAL zh(ip1jmp1),zu(ip1jmp1), gx(ip1jmp1), divgra(ip1jmp1)
+  real zv(ip1jm), gy(ip1jm), deltap(ip1jmp1,llm)
+  REAL ullm,vllm,umin,vmin,zhmin,zhmax
+  REAL zllm
+
+  INTEGER l,ij,idum,ii
+  REAL tetamin
+  REAL pseudoz
+  REAL Pup
+  character (len=80) :: abort_message
+
+  REAL ran1
+  logical,save :: firstcall=.true.
+  real,save :: fac_mid,fac_up,startalt,delta,middle
+
+  if (firstcall) then
+    firstcall=.false.
+    if ((planet_type.ne."earth").and.(vert_prof_dissip.eq.1)) then
+      ! initialize values for dissipation variation along the vertical (Mars)
+      fac_mid=3 ! coefficient for lower/middle atmosphere
+      fac_up=30 ! coefficient for upper atmosphere
+      startalt=70. ! altitude (in km) for the transition from middle to upper atm.
+      delta=30.! Size (in km) of the transition region between middle/upper atm.
+
+      middle=startalt+delta/2
+      write(lunout,*)"inidissip: multiplicative factors in altitude:", &
+        " fac_mid=",fac_mid," fac_up=",fac_up
+      write(lunout,*)" transition mid/up : startalt (km) =",startalt, &
+        " delta (km) =",delta
+    endif
+  endif !of if firstcall
+
+  !-----------------------------------------------------------------------
+  !
+  !   calcul des valeurs propres des operateurs par methode iterrative:
+  !   -----------------------------------------------------------------
+
+  crot     = -1.
+  cdivu    = -1.
+  cdivh    = -1.
+
+  !   calcul de la valeur propre de divgrad:
+  !   --------------------------------------
+  idum = 0
+  DO l = 1, llm
+     DO ij = 1, ip1jmp1
+        deltap(ij,l) = 1.
+     ENDDO
+  ENDDO
+
+  idum  = -1
+  zh(1) = RAN1(idum)-.5
+  idum  = 0
+  DO ij = 2, ip1jmp1
+     zh(ij) = RAN1(idum) -.5
+  ENDDO
+
+  CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
+
+  CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+  IF ( zhmin .GE. zhmax  )     THEN
+     write(lunout,*)'  Inidissip  zh min max  ',zhmin,zhmax
+     abort_message='probleme generateur alleatoire dans inidissip'
+     call abort_gcm('inidissip',abort_message,1)
+  ENDIF
+
+  zllm = ABS( zhmax )
+  DO l = 1,50
+     IF(lstardis) THEN
+        CALL divgrad2(1,zh,deltap,niterh,divgra)
+     ELSE
+        CALL divgrad (1,zh,niterh,divgra)
+     ENDIF
+
+     zllm  = ABS(maxval(divgra))
+     zh = divgra / zllm
+  ENDDO
+
+  IF(lstardis) THEN
+     cdivh = 1./ zllm
+  ELSE
+     cdivh = zllm ** ( -1./niterh )
+  ENDIF
+
+  !   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
+  !   -----------------------------------------------------------------
+  write(lunout,*)'inidissip: calcul des valeurs propres'
+
+  DO    ii = 1, 2
+     !
+     DO ij = 1, ip1jmp1
+        zu(ij)  = RAN1(idum) -.5
+     ENDDO
+     CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
+     DO ij = 1, ip1jm
+        zv(ij) = RAN1(idum) -.5
+     ENDDO
+     CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
+
+     CALL minmax(iip1*jjp1,zu,umin,ullm )
+     CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+     ullm = ABS ( ullm )
+     vllm = ABS ( vllm )
+
+     DO    l = 1, 50
+        IF(ii.EQ.1) THEN
+           !cccc             CALL covcont( 1,zu,zv,zu,zv )
+           IF(lstardis) THEN
+              CALL gradiv2( 1,zu,zv,nitergdiv,gx,gy )
+           ELSE
+              CALL gradiv ( 1,zu,zv,nitergdiv,gx,gy )
+           ENDIF
+        ELSE
+           IF(lstardis) THEN
+              CALL nxgraro2( 1,zu,zv,nitergrot,gx,gy )
+           ELSE
+              CALL nxgrarot( 1,zu,zv,nitergrot,gx,gy )
+           ENDIF
+        ENDIF
+
+        zllm = max(abs(maxval(gx)), abs(maxval(gy)))
+        zu = gx / zllm
+        zv = gy / zllm
+     end DO
+
+     IF ( ii.EQ.1 ) THEN
+        IF(lstardis) THEN
+           cdivu  = 1./zllm
+        ELSE
+           cdivu  = zllm **( -1./nitergdiv )
+        ENDIF
+     ELSE
+        IF(lstardis) THEN
+           crot   = 1./ zllm
+        ELSE
+           crot   = zllm **( -1./nitergrot )
+        ENDIF
+     ENDIF
+
+  end DO
+
+  !   petit test pour les operateurs non star:
+  !   ----------------------------------------
+
+  !     IF(.NOT.lstardis) THEN
+  fact    = rad*24./REAL(jjm)
+  fact    = fact*fact
+  write(lunout,*)'inidissip: coef u ', fact/cdivu, 1./cdivu
+  write(lunout,*)'inidissip: coef r ', fact/crot , 1./crot
+  write(lunout,*)'inidissip: coef h ', fact/cdivh, 1./cdivh
+  !     ENDIF
+
+  !-----------------------------------------------------------------------
+  !   variation verticale du coefficient de dissipation:
+  !   --------------------------------------------------
+  
+  if (planet_type.eq."earth") then
+
+   if (vert_prof_dissip == 1) then
+     do l=1,llm
+        pseudoz=8.*log(preff/presnivs(l))
+        zvert(l)=1+ &
+             (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. &
+             *(dissip_factz-1.)
+     enddo
+   else
+     DO l=1,llm
+        zvert(l)=1.
+     ENDDO
+     fact=2.
+     DO l = 1, llm
+        zz      = 1. - preff/presnivs(l)
+        zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
+     ENDDO
+   endif ! of if (vert_prof_dissip == 1)
+
+  else ! other planets
+  
+   if (vert_prof_dissip == 0) then
+! First step: going from 1 to dissip_fac_mid (in gcm.def)
+!============
+    DO l=1,llm
+     zz      = 1. - preff/presnivs(l)
+     zvert(l)= dissip_fac_mid -( dissip_fac_mid-1.)/( 1.+zz*zz )
+    ENDDO
+
+    write(lunout,*) 'Dissipation : '
+    write(lunout,*) 'Multiplication de la dissipation en altitude :'
+    write(lunout,*) '  dissip_fac_mid =', dissip_fac_mid
+
+! Second step if ok_strato:  from dissip_fac_mid to dissip_fac_up (in gcm.def)
+!==========================
+! Utilisation de la fonction tangente hyperbolique pour augmenter
+! arbitrairement la dissipation et donc la stabilite du modele a 
+! partir d'une certaine altitude.
+
+!   Le facteur multiplicatif de basse atmosphere etant deja pris 
+!   en compte, il faut diviser le facteur multiplicatif de haute 
+!   atmosphere par celui-ci.
+
+    if (ok_strato) then
+
+     Pup = dissip_pupstart*exp(-0.5*dissip_deltaz/dissip_hdelta)
+     do l=1,llm
+      zvert(l)= zvert(l)*(1.0+( (dissip_fac_up/dissip_fac_mid-1) &
+                *(1-(0.5*(1+tanh(-6./dissip_deltaz*              &
+               (-dissip_hdelta*log(presnivs(l)/Pup))  ))))  ))
+     enddo 
+
+     write(*,*) '  dissip_fac_up =', dissip_fac_up
+     write(*,*) 'Transition mid /up:  Pupstart,delta =',           &
+                   dissip_pupstart,'Pa', dissip_deltaz , '(km)'
+
+    endif ! of if (ok_strato)
+   elseif (vert_prof_dissip==1) then
+    DO l=1,llm
+     zz      = 1. - preff/presnivs(l)
+!     zvert(l)= dissip_fac_mid -( dissip_fac_mid-1.)/( 1.+zz*zz )
+     zvert(l)= fac_mid -( fac_mid-1.)/( 1.+zz*zz )
+     
+     zvert(l)= zvert(l)*(1.0+((fac_up/fac_mid-1)*    &
+                (1-(0.5*(1+tanh(-6./                 &
+                delta*(scaleheight*(-log(presnivs(l)/preff))-middle))))) &
+                ))
+    ENDDO
+    write(lunout,*) "inidissip: vert_prof_disip=1, scaleheight=",scaleheight
+    write(lunout,*) "           fac_mid=",fac_mid,", fac_up=",fac_up
+    
+   else
+     write(lunout,*) 'wrong value for vert_prof_dissip:',vert_prof_dissip
+     abort_message='wrong value for vert_prof_dissip'
+     call abort_gcm('inidissip',abort_message,1)
+   endif ! of (vert_prof_dissip == 0)
+  endif ! of if (planet_type.eq."earth")
+
+
+  write(lunout,*)'inidissip: Time constants for lateral dissipation'
+
+  tetamin =  1.e+6
+
+  DO l=1,llm
+     tetaudiv(l)   = zvert(l)/tetagdiv
+     tetaurot(l)   = zvert(l)/tetagrot
+     tetah(l)      = zvert(l)/tetatemp
+
+     IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
+     IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
+     IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
+  ENDDO
+
+  ! If dissip_period=0 calculate value for dissipation period, else keep value read from gcm.def
+  IF (dissip_period == 0) THEN
+     dissip_period = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+     write(lunout,*)'inidissip: tetamin dtvr iperiod dissip_period(intermed) ',tetamin,dtvr,iperiod,dissip_period
+     dissip_period = MAX(iperiod,dissip_period)
+  END IF
+
+  dtdiss  = dissip_period * dtvr
+  write(lunout,*)'inidissip: dissip_period=',dissip_period,' dtdiss=',dtdiss,' dtvr=',dtvr
+
+  write(lunout,*)'pseudoZ(km)  zvert    dt(tetagdiv)   dt(tetagrot)   dt(divgrad)'
+  DO l = 1,llm
+     write(lunout,'(f6.1,x,4(1pe14.7,x))') &
+     pseudoalt(l),zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l),dtdiss*tetah(l)
+     ! test if disipation is not too strong (for Explicit Euler time marching)
+     if (dtdiss*tetaudiv(l).gt.1.9) then
+       write(lunout,*)"STOP : lateral dissipation is too intense and will"
+       write(lunout,*)"       generate instabilities in the model !"
+       write(lunout,*)" You must increase tetagdiv (or increase dissip_period"
+       write(lunout,*)"                             or increase day_stap)"
+     endif
+     if (dtdiss*tetaurot(l).gt.1.9) then
+       write(lunout,*)"STOP : lateral dissipation is too intense and will"
+       write(lunout,*)"       generate instabilities in the model !"
+       write(lunout,*)" You must increase tetaurot (or increase dissip_period"
+       write(lunout,*)"                             or increase day_stap)"
+     endif
+     if (dtdiss*tetah(l).gt.1.9) then
+       write(lunout,*)"STOP : lateral dissipation is too intense and will"
+       write(lunout,*)"       generate instabilities in the model !"
+       write(lunout,*)" You must increase tetah (or increase dissip_period"
+       write(lunout,*)"                          or increase day_stap)"
+     endif
+  ENDDO ! of DO l=1,llm
+
+END SUBROUTINE inidissip
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inigeom.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inigeom.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inigeom.F	(revision 222)
@@ -0,0 +1,699 @@
+!
+! $Id: inigeom.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+c
+c
+      SUBROUTINE inigeom
+c
+c     Auteur :  P. Le Van
+c
+c   ............      Version  du 01/04/2001     ........................
+c
+c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+c     endroits que les aires aireij1,..aireij4 .
+
+c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "serre.h"
+#include "logic.h"
+#include "comdissnew.h"
+
+c-----------------------------------------------------------------------
+c   ....  Variables  locales   ....
+c
+      INTEGER  i,j,itmax,itmay,iter
+      REAL cvu(iip1,jjp1),cuv(iip1,jjm)
+      REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
+      REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm
+      REAL coslatm,coslatp,radclatm,radclatp
+      REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1),
+     *     cuij4(iip1,jjp1)
+      REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1),
+     *     cvij4(iip1,jjp1)
+      REAL rlonvv(iip1),rlatuu(jjp1)
+      REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) ,
+     *     yprimv(jjm),yprimu(jjp1)
+      REAL gamdi_gdiv, gamdi_grot, gamdi_h
+ 
+      REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),
+     ,  xprimp025(iip1)
+      SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
+      SAVE rlonm025,xprimm025,rlonp025,xprimp025
+
+      REAL      SSUM
+c
+c
+c   ------------------------------------------------------------------
+c   -                                                                -
+c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+c   -                                                                -
+c   ------------------------------------------------------------------
+c
+c      les coef. ( cu, cv ) permettent de passer des vitesses naturelles
+c      aux vitesses covariantes et contravariantes , ou vice-versa ...
+c
+c
+c     on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
+c             v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
+c
+c       on en tire :  u(covariant) = cu * cu * u(contravariant)
+c                     v(covariant) = cv * cv * v(contravariant)
+c
+c
+c     on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
+c                                                          =     =
+c                                           et   - jm/2    <  Y  < jm/2
+c                                                          =     =
+c
+c      ...................................................
+c      ...................................................
+c      .  x  est la longitude du point  en radians       .
+c      .  y  est la  latitude du point  en radians       .
+c      .                                                 .
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+c      .        aire(i,j) =  cu(i,j) * cv(j)             .
+c      .                                                 .
+c      . y, dx/dX, dy/dY calcules aux points concernes   .
+c      .                                                 .
+c      ...................................................
+c      ...................................................
+c
+c
+c
+c                                                           ,
+c    cv , bien que dependant de j uniquement,sera ici indice aussi en i
+c          pour un adressage plus facile en  ij  .
+c
+c
+c
+c  **************  aux points  u  et  v ,           *****************
+c      xprimu et xprimv sont respectivement les valeurs de  dx/dX
+c      yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
+c      rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
+c      cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
+c
+c  **************  aux points u, v, scalaires, et z  ****************
+c      cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
+c
+c
+c
+c         Exemple de distribution de variables sur la grille dans le
+c             domaine de travail ( X,Y ) .
+c     ................................................................
+c                  DX=DY= 1
+c
+c   
+c        +     represente  un  point scalaire ( p.exp  la pression )
+c        >     represente  la composante zonale du  vent
+c        V     represente  la composante meridienne du vent
+c        o     represente  la  vorticite
+c
+c       ----  , car aux poles , les comp.zonales covariantes sont nulles
+c
+c
+c
+c         i ->
+c
+c         1      2      3      4      5      6      7      8
+c  j
+c  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c
+c      Ci-dessus,  on voit que le nombre de pts.en longitude est egal
+c                 a   IM = 8
+c      De meme ,   le nombre d'intervalles entre les 2 poles est egal
+c                 a   JM = 4
+c
+c      Les points scalaires ( + ) correspondent donc a des valeurs
+c       entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
+c
+c      Les vents    U       ( > ) correspondent a des valeurs  semi-
+c       entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
+c
+c      Les vents    V       ( V ) correspondent a des valeurs entieres
+c       de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
+c
+c
+c
+      WRITE(6,3) 
+ 3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
+     * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
+     *  5x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux 
+     * '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
+c
+c
+      IF( nitergdiv.NE.2 ) THEN
+        gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. )
+      ELSE
+        gamdi_gdiv = 0.
+      ENDIF
+      IF( nitergrot.NE.2 ) THEN
+        gamdi_grot = coefdis/ ( REAL(nitergrot) -2. )
+      ELSE
+        gamdi_grot = 0.
+      ENDIF
+      IF( niterh.NE.2 ) THEN
+        gamdi_h = coefdis/ ( REAL(niterh) -2. )
+      ELSE
+        gamdi_h = 0.
+      ENDIF
+
+      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+     *  nitergdiv,nitergrot,niterh
+c
+      pi    = 2.* ASIN(1.)
+c
+      WRITE(6,990) 
+
+c     ----------------------------------------------------------------
+c
+      IF( .NOT.fxyhypb )   THEN
+c
+c
+       IF( ysinus )  THEN
+c
+        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+c
+c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
+
+        CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ELSE
+c
+        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+
+c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
+c
+ 
+        pxo   = clon *pi /180.
+        pyo   = 2.* clat* pi /180.
+c
+c  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
+c
+        itmax = 10
+        eps   = .1e-7
+c
+        xo1 = 0.
+        DO 10 iter = 1, itmax
+        x1  = xo1
+        f   = x1+ alphax *SIN(x1-pxo)
+        df  = 1.+ alphax *COS(x1-pxo)
+        x1  = x1 - f/df
+        xdm = ABS( x1- xo1 )
+        IF( xdm.LE.eps )GO TO 11
+        xo1 = x1
+ 10     CONTINUE
+ 11     CONTINUE
+c
+        transx = xo1
+
+        itmay = 10
+        eps   = .1e-7
+C
+        yo1  = 0.
+        DO 15 iter = 1,itmay
+        y1   = yo1
+        f    = y1 + alphay* SIN(y1-pyo)
+        df   = 1. + alphay* COS(y1-pyo)
+        y1   = y1 -f/df
+        ydm  = ABS(y1-yo1)
+        IF(ydm.LE.eps) GO TO 17
+        yo1  = y1
+ 15     CONTINUE
+c
+ 17     CONTINUE
+        transy = yo1
+
+        CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,              rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ENDIF
+c
+      ELSE
+c
+c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+c   .....................................................................
+
+      WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+ 
+       CALL fxyhyper( clat, grossismy, dzoomy, tauy    , 
+     ,                clon, grossismx, dzoomx, taux    ,
+     , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2  ,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 )
+
+  
+      ENDIF
+c
+c  -------------------------------------------------------------------
+
+c
+      rlatu(1)    =     ASIN(1.)
+      rlatu(jjp1) =  - rlatu(1)
+c
+c
+c   ....  calcul  aux  poles  ....
+c
+      yprimu(1)      = 0.
+      yprimu(jjp1)   = 0.
+c
+c
+      un4rad2 = 0.25 * rad * rad
+c
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c   -                                                                  -
+c   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
+c   -      et de   fext ,  force de coriolis  extensive  .             -
+c   -                                                                  -
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c
+c
+c
+c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+c   affectees 4 aires entourant P , calculees respectivement aux points
+c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+c
+c           ,
+c   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
+c   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
+c   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
+c   point (i,j) .
+c   On definit en outre les coefficients  alpha comme etant egaux a
+c    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
+c
+c   De meme, toute aire centree en 1 point U est egale a la somme des
+c   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
+c    Idem pour  airev, airez .
+c
+c       On a ,pour chaque maille :    dX = dY = 1
+c
+c
+c                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+c
+c
+c
+c
+c
+c   ....................................................................
+c
+c    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
+c   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
+c   taires cuij et les 4 elongat. cvij qui sont calculees aux memes 
+c     endroits  que les aireij   .    
+c
+c   ....................................................................
+c
+c     .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
+c
+c
+      DO 35 j = 1, jjp1
+c
+      IF ( j. eq. 1 )  THEN
+c
+      yprm           = yprimu1(j)
+      rlatm          = rlatu1(j)
+c
+      coslatm        = COS( rlatm )
+      radclatm       = 0.5* rad * coslatm
+c
+      DO 30 i = 1, iim
+      xprp           = xprimp025( i )
+      xprm           = xprimm025( i )
+      aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
+      aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
+      cuij2  ( i,1 ) = radclatm * xprp
+      cuij3  ( i,1 ) = radclatm * xprm
+      cvij2  ( i,1 ) = 0.5* rad * yprm
+      cvij3  ( i,1 ) = cvij2(i,1)
+  30  CONTINUE
+c
+      DO  i = 1, iim
+      aireij1( i,1 ) = 0.
+      aireij4( i,1 ) = 0.
+      cuij1  ( i,1 ) = 0.
+      cuij4  ( i,1 ) = 0.
+      cvij1  ( i,1 ) = 0.
+      cvij4  ( i,1 ) = 0.
+      ENDDO
+c
+      END IF
+c
+      IF ( j. eq. jjp1 )  THEN
+       yprp               = yprimu2(j-1)
+       rlatp              = rlatu2 (j-1)
+ccc       yprp             = fyprim( REAL(j) - 0.25 )
+ccc       rlatp            = fy    ( REAL(j) - 0.25 )
+c
+      coslatp             = COS( rlatp )
+      radclatp            = 0.5* rad * coslatp
+c
+      DO 31 i = 1,iim
+        xprp              = xprimp025( i )
+        xprm              = xprimm025( i )
+        aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
+        aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
+        cuij1(i,jjp1)     = radclatp * xprp
+        cuij4(i,jjp1)     = radclatp * xprm
+        cvij1(i,jjp1)     = 0.5 * rad* yprp
+        cvij4(i,jjp1)     = cvij1(i,jjp1)
+ 31   CONTINUE
+c
+       DO   i    = 1, iim
+        aireij2( i,jjp1 ) = 0.
+        aireij3( i,jjp1 ) = 0.
+        cvij2  ( i,jjp1 ) = 0.
+        cvij3  ( i,jjp1 ) = 0.
+        cuij2  ( i,jjp1 ) = 0.
+        cuij3  ( i,jjp1 ) = 0.
+       ENDDO
+c
+      END IF
+c
+
+      IF ( j .gt. 1 .AND. j .lt. jjp1 )  THEN
+c
+        rlatp    = rlatu2 ( j-1 )
+        yprp     = yprimu2( j-1 )
+        rlatm    = rlatu1 (  j  )
+        yprm     = yprimu1(  j  )
+cc         rlatp    = fy    ( REAL(j) - 0.25 )
+cc         yprp     = fyprim( REAL(j) - 0.25 )
+cc         rlatm    = fy    ( REAL(j) + 0.25 )
+cc         yprm     = fyprim( REAL(j) + 0.25 )
+
+         coslatm  = COS( rlatm )
+         coslatp  = COS( rlatp )
+         radclatp = 0.5* rad * coslatp
+         radclatm = 0.5* rad * coslatm
+c
+         ai14            = un4rad2 * coslatp * yprp
+         ai23            = un4rad2 * coslatm * yprm
+         DO 32 i = 1,iim
+         xprp            = xprimp025( i )
+         xprm            = xprimm025( i )
+      
+         aireij1 ( i,j ) = ai14 * xprp
+         aireij2 ( i,j ) = ai23 * xprp
+         aireij3 ( i,j ) = ai23 * xprm
+         aireij4 ( i,j ) = ai14 * xprm
+         cuij1   ( i,j ) = radclatp * xprp
+         cuij2   ( i,j ) = radclatm * xprp
+         cuij3   ( i,j ) = radclatm * xprm
+         cuij4   ( i,j ) = radclatp * xprm
+         cvij1   ( i,j ) = 0.5* rad * yprp
+         cvij2   ( i,j ) = 0.5* rad * yprm
+         cvij3   ( i,j ) = cvij2(i,j)
+         cvij4   ( i,j ) = cvij1(i,j)
+  32     CONTINUE
+c
+      END IF
+c
+c    ........       periodicite   ............
+c
+         cvij1   (iip1,j) = cvij1   (1,j)
+         cvij2   (iip1,j) = cvij2   (1,j)
+         cvij3   (iip1,j) = cvij3   (1,j)
+         cvij4   (iip1,j) = cvij4   (1,j)
+         cuij1   (iip1,j) = cuij1   (1,j)
+         cuij2   (iip1,j) = cuij2   (1,j)
+         cuij3   (iip1,j) = cuij3   (1,j)
+         cuij4   (iip1,j) = cuij4   (1,j)
+         aireij1 (iip1,j) = aireij1 (1,j )
+         aireij2 (iip1,j) = aireij2 (1,j )
+         aireij3 (iip1,j) = aireij3 (1,j )
+         aireij4 (iip1,j) = aireij4 (1,j )
+        
+  35  CONTINUE
+c
+c    ..............................................................
+c
+      DO 37 j = 1, jjp1
+      DO 36 i = 1, iim
+      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
+     *                          aireij4(i,j)
+      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+  36  CONTINUE
+c
+c
+      aire    (iip1,j) = aire    (1,j)
+      alpha1  (iip1,j) = alpha1  (1,j)
+      alpha2  (iip1,j) = alpha2  (1,j)
+      alpha3  (iip1,j) = alpha3  (1,j)
+      alpha4  (iip1,j) = alpha4  (1,j)
+      alpha1p2(iip1,j) = alpha1p2(1,j)
+      alpha1p4(iip1,j) = alpha1p4(1,j)
+      alpha2p3(iip1,j) = alpha2p3(1,j)
+      alpha3p4(iip1,j) = alpha3p4(1,j)
+  37  CONTINUE
+c
+
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                                aireij3(i+1,j)
+      unsaire    ( i,j)= 1./ aire(i,j)
+      unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
+      unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
+      airesurg   ( i,j)= aire(i,j)/ g
+  41  CONTINUE
+      aireu     (iip1,j)  = aireu  (1,j)
+      unsaire   (iip1,j)  = unsaire(1,j)
+      unsair_gam1(iip1,j) = unsair_gam1(1,j)
+      unsair_gam2(iip1,j) = unsair_gam2(1,j)
+      airesurg   (iip1,j) = airesurg(1,j)
+  42  CONTINUE
+c
+c
+      DO 48 j = 1,jjm
+c
+        DO i=1,iim
+         airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+         DO i=1,iim
+          airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) +
+     *                           aireij4(i+1,j+1)
+          unsairez(i,j) = 1./ airez
+          unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
+          fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
+         ENDDO
+        airev     (iip1,j)  = airev(1,j)
+        unsairez  (iip1,j)  = unsairez(1,j)
+        fext      (iip1,j)  = fext(1,j)
+        unsairz_gam(iip1,j) = unsairz_gam(1,j)
+c
+  48  CONTINUE
+c
+c
+c    .....      Calcul  des elongations cu,cv, cvu     .........
+c
+      DO    j   = 1, jjm
+       DO   i  = 1, iim
+       cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
+       cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
+       cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
+       unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
+       ENDDO
+       DO   i  = 1, iim
+       cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
+       cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
+       cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
+       cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
+       cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
+       ENDDO
+       cv       (iip1,j)  = cv       (1,j)
+       cvu      (iip1,j)  = cvu      (1,j)
+       unscv2   (iip1,j)  = unscv2   (1,j)
+       cuv      (iip1,j)  = cuv      (1,j)
+       cuvsurcv (iip1,j)  = cuvsurcv (1,j)
+       cvsurcuv (iip1,j)  = cvsurcuv (1,j)
+       cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
+       cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
+       cvscuvgam(iip1,j)  = cvscuvgam(1,j)
+      ENDDO
+
+      DO  j     = 2, jjm
+        DO   i  = 1, iim
+        cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
+        unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
+        cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
+        cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
+        cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) 
+        cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    ) 
+        cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
+        ENDDO
+        cu       (iip1,j)  = cu(1,j)
+        unscu2   (iip1,j)  = unscu2(1,j)
+        cvusurcu (iip1,j)  = cvusurcu(1,j)
+        cusurcvu (iip1,j)  = cusurcvu(1,j)
+        cvuscugam1(iip1,j) = cvuscugam1(1,j)
+        cvuscugam2(iip1,j) = cvuscugam2(1,j)
+        cuscvugam (iip1,j) = cuscvugam(1,j)
+      ENDDO
+
+c
+c   ....  calcul aux  poles  ....
+c
+      DO    i      =  1, iip1
+        cu    ( i, 1 )  =   0.
+        unscu2( i, 1 )  =   0.
+        cvu   ( i, 1 )  =   0.
+c
+        cu    (i, jjp1) =   0.
+        unscu2(i, jjp1) =   0.
+        cvu   (i, jjp1) =   0.
+      ENDDO
+c
+c    ..............................................................
+c
+      DO j = 1, jjm
+        DO i= 1, iim
+         airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
+         aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
+        ENDDO
+         airvscu2  (iip1,j)  = airvscu2(1,j)
+         aivscu2gam(iip1,j)  = aivscu2gam(1,j)
+      ENDDO
+
+      DO j=2,jjm
+        DO i=1,iim
+         airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
+         aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot ) 
+        ENDDO
+         airuscv2  (iip1,j)  = airuscv2  (1,j)
+         aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
+      ENDDO
+
+c
+c   calcul des aires aux  poles :
+c   -----------------------------
+c
+      apoln       = SSUM(iim,aire(1,1),1)
+      apols       = SSUM(iim,aire(1,jjp1),1)
+      unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
+      unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
+      unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
+      unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
+c
+c-----------------------------------------------------------------------
+c     gtitre='Coriolis version ancienne'
+c     gfichier='fext1'
+c     CALL writestd(fext,iip1*jjm)
+c
+c   changement F. Hourdin calcul conservatif pour fext
+c   constang contient le produit a * cos ( latitude ) * omega
+c
+      DO i=1,iim
+         constang(i,1) = 0.
+      ENDDO
+      DO j=1,jjm-1
+        DO i=1,iim
+         constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
+        ENDDO
+      ENDDO
+      DO i=1,iim
+         constang(i,jjp1) = 0.
+      ENDDO
+c
+c   periodicite en longitude
+c
+      DO j=1,jjm
+        fext(iip1,j)     = fext(1,j)
+      ENDDO
+      DO j=1,jjp1
+        constang(iip1,j) = constang(1,j)
+      ENDDO
+
+c fin du changement
+
+c
+c-----------------------------------------------------------------------
+c
+       WRITE(6,*) '   ***  Coordonnees de la grille  *** '
+       WRITE(6,995)
+c
+       WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,iip1
+         rlonvv(i) = rlonv(i)*180./pi
+        ENDDO
+       WRITE(6,400) rlonvv
+c
+       WRITE(6,995)
+       WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjm
+         rlatuu(i)=rlatv(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjm)
+c
+        DO i=1,iip1
+          rlonvv(i)=rlonu(i)*180./pi
+        ENDDO
+       WRITE(6,995)
+       WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
+       WRITE(6,995)
+       WRITE(6,400) rlonvv
+       WRITE(6,995)
+
+       WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjp1
+         rlatuu(i)=rlatu(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjp1)
+       WRITE(6,995)
+c
+444    format(f10.3,f6.0)
+400    FORMAT(1x,8f8.2)
+990    FORMAT(//)
+995    FORMAT(/)
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inigrads.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inigrads.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inigrads.F	(revision 222)
@@ -0,0 +1,93 @@
+!
+! $Header$
+!
+      subroutine inigrads(if,im
+     s  ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz
+     s  ,dt,file,titlel)
+
+
+      implicit none
+
+      integer if,im,jm,lm,i,j,l
+      real x(im),y(jm),z(lm),fx,fy,fz,dt
+      real xmin,xmax,ymin,ymax
+
+      character(len=*),intent(in) :: file
+      character(len=*),intent(in) :: titlel
+
+#include "gradsdef.h"
+
+c     data unit/66,32,34,36,38,40,42,44,46,48/
+      integer nf
+      save nf
+      data nf/0/
+
+      unit(1)=66
+      unit(2)=32
+      unit(3)=34
+      unit(4)=36
+      unit(5)=38
+      unit(6)=40
+      unit(7)=42
+      unit(8)=44
+      unit(9)=46
+
+      if (if.le.nf) stop'verifier les appels a inigrads'
+
+      print*,'Entree dans inigrads'
+
+      nf=if
+      title(if)=titlel
+      ivar(if)=0
+
+      fichier(if)=trim(file)
+
+      firsttime(if)=.true.
+      dtime(if)=dt
+
+      iid(if)=1
+      ifd(if)=im
+      imd(if)=im
+      do i=1,im
+         xd(i,if)=x(i)*fx
+         if(xd(i,if).lt.xmin) iid(if)=i+1
+         if(xd(i,if).le.xmax) ifd(if)=i
+      enddo
+      print*,'On stoke du point ',iid(if),'  a ',ifd(if),' en x'
+
+      jid(if)=1
+      jfd(if)=jm
+      jmd(if)=jm
+      do j=1,jm
+         yd(j,if)=y(j)*fy
+         if(yd(j,if).gt.ymax) jid(if)=j+1
+         if(yd(j,if).ge.ymin) jfd(if)=j
+      enddo
+      print*,'On stoke du point ',jid(if),'  a ',jfd(if),' en y'
+
+      print*,'Open de dat'
+      print*,'file=',file
+      print*,'fichier(if)=',fichier(if)
+
+      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
+      print*,trim(file)//'.dat'
+
+      OPEN (unit(if)+1,FILE=trim(file)//'.dat'
+     s   ,FORM='unformatted',
+     s   ACCESS='direct'
+     s  ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1))
+
+      print*,'Open de dat ok'
+
+      lmd(if)=lm
+      do l=1,lm
+         zd(l,if)=z(l)*fz
+      enddo
+
+      irec(if)=0
+
+      print*,if,imd(if),jmd(if),lmd(if)
+      print*,'if,imd(if),jmd(if),lmd(if)'
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniprint.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniprint.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/iniprint.h	(revision 222)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!
+! gestion des impressions de sorties et de débogage
+! lunout:    unité du fichier dans lequel se font les sorties 
+!                           (par defaut 6, la sortie standard)
+! prt_level: niveau d'impression souhaité (0 = minimum)
+!
+      INTEGER lunout, prt_level
+      COMMON /comprint/ lunout, prt_level
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/initial0.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/initial0.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/initial0.F	(revision 222)
@@ -0,0 +1,12 @@
+!
+! $Header$
+!
+      SUBROUTINE initial0(n,x)
+      IMPLICIT NONE
+      INTEGER n,i
+      REAL x(n)
+      DO 10 i=1,n
+         x(i)=0.
+10    CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inter_barxy_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inter_barxy_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/inter_barxy_m.F90	(revision 222)
@@ -0,0 +1,453 @@
+!
+! $Id$
+!
+module inter_barxy_m
+
+  ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ
+
+  implicit none
+
+  private
+  public inter_barxy
+
+contains
+
+  SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint)
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+
+    include "dimensions.h"
+    ! (for "iim", "jjm")
+
+    include "paramet.h"
+    ! (for other included files)
+
+    include "comgeom2.h"
+    ! (for "aire", "apoln", "apols")
+
+    REAL, intent(in):: dlonid(:)
+    ! (longitude from input file, in rad, from -pi to pi)
+
+    REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:)
+
+    REAL, intent(in):: rlatimod(:)
+    ! (latitude angle, in degrees or rad, in strictly decreasing order)
+
+    real, intent(out):: champint(:, :)
+    ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les
+    ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U)
+    ! Si taille de la seconde dim = jjm, on veut interpoler sur les
+    ! jjm latitudes rlatv du modele (latitudes de V) 
+
+    ! Variables local to the procedure:
+
+    REAL champy(iim, size(champ, 2))
+    integer j, i, jnterfd, jmods
+
+    REAL yjmod(size(champint, 2))
+    ! (angle, in degrees, in strictly increasing order)
+
+    REAL   yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order
+    LOGICAL decrois ! "dlatid" is in decreasing order
+
+    !-----------------------------------
+
+    jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), &
+         "inter_barxy jnterfd")
+    jmods = size(champint, 2)
+    call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)")
+    call assert((/size(rlonimod), size(champint, 1)/) == iim, &
+         "inter_barxy iim")
+    call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods')
+    call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)")
+
+    ! Check decreasing order for "rlatimod":
+    DO i = 2, jjm
+       IF (rlatimod(i) >= rlatimod(i-1)) stop &
+            '"inter_barxy": "rlatimod" should be strictly decreasing'
+    ENDDO
+
+    yjmod(:jjm) = ord_coordm(rlatimod)
+    IF (jmods == jjm + 1) THEN
+       IF (90. - yjmod(jjm) < 0.01) stop &
+            '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.'
+    ELSE
+       ! jmods = jjm
+       IF (ABS(yjmod(jjm) - 90.) > 0.01) stop &
+            '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.'
+    ENDIF
+
+    if (jmods == jjm + 1) yjmod(jjm + 1) = 90.
+
+    DO j = 1, jnterfd + 1
+       champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod)
+    ENDDO
+
+    CALL ord_coord(dlatid, yjdat, decrois) 
+    IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1)
+    DO i = 1, iim
+       champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod)
+    ENDDO
+    champint(:, :) = champint(:, jmods:1:-1)
+
+    IF (jmods == jjm + 1) THEN
+       ! Valeurs uniques aux poles
+       champint(:, 1) = SUM(aire(:iim,  1) * champint(:, 1)) / apoln
+       champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) &
+            * champint(:, jjm + 1)) / apols
+    ENDIF
+
+  END SUBROUTINE inter_barxy
+
+  !******************************
+
+  function inter_barx(dlonid, fdat, rlonimod) 
+
+    !        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
+    !            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
+
+    !     idat : indice du champ de donnees, de 1 a idatmax
+    !     imod : indice du champ du modele,  de 1 a  imodmax
+    !     fdat(idat) : champ de donnees (entrees)
+    !     inter_barx(imod) : champ du modele (sorties)
+    !     dlonid(idat): abscisses des interfaces des mailles donnees
+    !     rlonimod(imod): abscisses des interfaces des mailles modele
+    !      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
+    !      ( Les abscisses sont exprimees en degres)
+
+    use assert_eq_m, only: assert_eq
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: dlonid(:)
+    real, intent(in):: fdat(:)
+    real, intent(in):: rlonimod(:)
+
+    real inter_barx(size(rlonimod))
+
+    !    ...  Variables locales ... 
+
+    INTEGER idatmax, imodmax
+    REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
+    REAL  fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) 
+    REAL  xxim(size(rlonimod))
+
+    REAL x0, xim0, dx, dxm
+    REAL chmin, chmax, pi
+
+    INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
+
+    !-----------------------------------------------------
+
+    idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
+    imodmax = size(rlonimod)
+
+    pi = 2. * ASIN(1.)
+
+    !   REDEFINITION DE L'ORIGINE DES ABSCISSES
+    !    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
+    DO imod = 1, imodmax
+       xxim(imod) = rlonimod(imod)
+    ENDDO
+
+    CALL minmax( imodmax, xxim, chmin, chmax)
+    IF( chmax.LT.6.50 )   THEN
+       DO imod = 1, imodmax
+          xxim(imod) = xxim(imod) * 180./pi
+       ENDDO
+    ENDIF
+
+    xim0 = xxim(imodmax) - 360.
+
+    DO imod = 1, imodmax
+       xxim(imod) = xxim(imod) - xim0
+    ENDDO
+
+    idatmax1 = idatmax +1
+
+    DO idat = 1, idatmax
+       xxd(idat) = dlonid(idat)
+    ENDDO
+
+    CALL minmax( idatmax, xxd, chmin, chmax)
+    IF( chmax.LT.6.50 )  THEN
+       DO idat = 1, idatmax
+          xxd(idat) = xxd(idat) * 180./pi
+       ENDDO
+    ENDIF
+
+    DO idat = 1, idatmax
+       xxd(idat) = MOD( xxd(idat) - xim0, 360. )
+       fdd(idat) = fdat (idat)
+    ENDDO
+
+    i = 2
+    DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
+       i = i + 1
+    ENDDO
+    IF (xxd(i) < xxd(i-1)) THEN
+       ichang = i
+       !  ***  reorganisation  des longitudes entre 0. et 360. degres ****
+       nid = idatmax - ichang +1
+       DO i = 1, nid
+          xchan (i) = xxd(i+ichang -1 )
+          fdchan(i) = fdd(i+ichang -1 )
+       ENDDO
+       DO i=1, ichang -1
+          xchan (i+ nid) = xxd(i)
+          fdchan(i+nid) = fdd(i) 
+       ENDDO
+       DO i =1, idatmax
+          xxd(i) = xchan(i)
+          fdd(i) = fdchan(i)
+       ENDDO
+    end IF
+
+    !    translation des champs de donnees par rapport
+    !    a la nouvelle origine, avec redondance de la
+    !       maille a cheval sur les bords
+
+    id0 = 0
+    id1 = 0
+
+    DO idat = 1, idatmax
+       IF ( xxd( idatmax1- idat ).LT.360.) exit
+       id1 = id1 + 1
+    ENDDO
+
+    DO idat = 1, idatmax
+       IF (xxd(idat).GT.0.) exit
+       id0 = id0 + 1
+    END DO
+
+    IF( id1 /= 0 ) then
+       DO idat = 1, id1
+          xxid(idat) = xxd(idatmax - id1 + idat) - 360.
+          fxd (idat) = fdd(idatmax - id1 + idat)     
+       END DO
+       DO idat = 1, idatmax - id1
+          xxid(idat + id1) = xxd(idat)
+          fxd (idat + id1) = fdd(idat)
+       END DO
+    end IF
+
+    IF(id0 /= 0) then
+       DO idat = 1, idatmax - id0
+          xxid(idat) = xxd(idat + id0)
+          fxd (idat) = fdd(idat + id0)
+       END DO
+
+       DO idat = 1, id0
+          xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
+          fxd  (idatmax - id0 + idat) =  fdd(idat)   
+       END DO
+    else 
+       DO idat = 1, idatmax
+          xxid(idat)  = xxd(idat)
+          fxd (idat)  = fdd(idat)
+       ENDDO
+    end IF
+    xxid(idatmax1) = xxid(1) + 360.
+    fxd (idatmax1) = fxd(1)
+
+    !   initialisation du champ du modele
+
+    inter_barx(:) = 0.
+
+    ! iteration
+
+    x0   = xim0
+    dxm  = 0.
+    imod = 1
+    idat = 1
+
+    do while (imod <= imodmax)
+       do while (xxim(imod).GT.xxid(idat))
+          dx   = xxid(idat) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
+          x0   = xxid(idat)
+          idat = idat + 1
+       end do
+       IF (xxim(imod).LT.xxid(idat)) THEN
+          dx   = xxim(imod) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
+          x0   = xxim(imod)
+          dxm  = 0.
+          imod = imod + 1
+       ELSE
+          dx   = xxim(imod) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
+          x0   = xxim(imod)
+          dxm  = 0.
+          imod = imod + 1
+          idat = idat + 1
+       END IF
+    end do
+
+  END function inter_barx
+
+  !******************************
+
+  function inter_bary(yjdat, fdat, yjmod)
+
+    ! Interpolation barycentrique basÃ©e sur les aires.
+    ! Version unidimensionnelle, en latitude.
+    ! L'indice 1 correspond Ã  l'interface maille 1 -- maille 2.
+
+    use assert_m, only: assert
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: yjdat(:)
+    ! (angles, ordonnÃ©es des interfaces des mailles des donnÃ©es, in
+    ! degrees, in increasing order)
+
+    REAL, intent(in):: fdat(:) ! champ de donnÃ©es
+
+    REAL, intent(in):: yjmod(:)
+    ! (ordonnÃ©es des interfaces des mailles du modÃšle)
+    ! (in degrees, in strictly increasing order)
+
+    REAL inter_bary(size(yjmod)) ! champ du modÃšle
+
+    ! Variables local to the procedure:
+
+    REAL y0, dy, dym 
+    INTEGER jdat ! indice du champ de donnÃ©es
+    integer jmod ! indice du champ du modÃšle
+
+    !------------------------------------
+
+    call assert(size(yjdat) == size(fdat), "inter_bary")
+
+    ! Initialisation des variables
+    inter_bary(:) = 0.
+    y0    = -90.
+    dym   = 0.
+    jmod  = 1
+    jdat  = 1
+
+    do while (jmod <= size(yjmod))
+       do while (yjmod(jmod) > yjdat(jdat))
+          dy         = yjdat(jdat) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat)
+          y0         = yjdat(jdat)
+          jdat       = jdat + 1
+       end do
+       IF (yjmod(jmod) < yjdat(jdat)) THEN
+          dy         = yjmod(jmod) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
+          y0         = yjmod(jmod)
+          dym        = 0.
+          jmod       = jmod + 1
+       ELSE
+          ! {yjmod(jmod) == yjdat(jdat)}
+          dy         = yjmod(jmod) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
+          y0         = yjmod(jmod)
+          dym        = 0.
+          jmod       = jmod + 1
+          jdat       = jdat + 1
+       END IF
+    end do
+    ! Le test de fin suppose que l'interface 0 est commune aux deux
+    ! grilles "yjdat" et "yjmod".
+
+  END function inter_bary
+
+  !******************************
+
+  SUBROUTINE ord_coord(xi, xo, decrois)
+
+    ! This procedure receives an array of latitudes.
+    ! It converts them to degrees if they are in radians.
+    ! If the input latitudes are in decreasing order, the procedure
+    ! reverses their order.
+    ! Finally, the procedure adds 90Â° as the last value of the array.
+
+    use assert_eq_m, only: assert_eq
+
+    IMPLICIT NONE
+
+    include "comconst.h"
+    ! (for "pi")
+
+    REAL, intent(in):: xi(:)
+    ! (latitude, in degrees or radians, in increasing or decreasing order)
+    ! ("xi" should contain latitudes from pole to pole.
+    ! "xi" should contain the latitudes of the boundaries of grid
+    ! cells, not the centers of grid cells.
+    ! So the extreme values should not be 90Â° and -90Â°.)
+
+    REAL, intent(out):: xo(:) ! angles in degrees
+    LOGICAL, intent(out):: decrois
+
+    ! Variables  local to the procedure:
+    INTEGER nmax, i
+
+    !--------------------
+
+    nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord")
+
+    ! Check monotonicity:
+    decrois = xi(2) < xi(1)
+    DO i = 3, nmax
+       IF (decrois .neqv. xi(i) < xi(i-1)) stop &
+            '"ord_coord":  latitudes are not monotonic'
+    ENDDO
+
+    IF (abs(xi(1)) < pi) then
+       ! "xi" contains latitudes in radians
+       xo(:nmax) = xi(:) * 180. / pi
+    else
+       ! "xi" contains latitudes in degrees
+       xo(:nmax) = xi(:)
+    end IF
+
+    IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN
+       print *, "ord_coord"
+       PRINT *, '"xi" should contain the latitudes of the boundaries of ' &
+            // 'grid cells, not the centers of grid cells.'
+       STOP
+    ENDIF
+
+    IF (decrois) xo(:nmax) = xo(nmax:1:- 1)
+    xo(nmax + 1) = 90.
+
+  END SUBROUTINE ord_coord
+
+  !***********************************
+
+  function ord_coordm(xi)
+
+    ! This procedure converts to degrees, if necessary, and inverts the
+    ! order.
+
+    IMPLICIT NONE
+
+    include "comconst.h"
+    ! (for "pi")
+
+    REAL, intent(in):: xi(:) ! angle, in rad or degrees
+    REAL ord_coordm(size(xi)) ! angle, in degrees
+
+    !-----------------------------
+
+    IF (xi(1) < 6.5) THEN
+       ! "xi" is in rad
+       ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi
+    else
+       ! "xi" is in degrees
+       ord_coordm(:) = xi(size(xi):1:-1)
+    ENDIF
+
+  END function ord_coordm
+
+end module inter_barxy_m
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/interpost.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/interpost.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/interpost.F	(revision 222)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+        subroutine interpost(q,qppm)
+
+       implicit none
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c Arguments   
+      real   q(iip1,jjp1,llm)
+      real   qppm(iim,jjp1,llm)
+c Local
+      integer l,i,j
+  
+c RE-INVERSION DES NIVEAUX
+c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+c On passe donc des niveaux de Lin à ceux du LMDZ
+           
+        do l=1,llm
+          do j=1,jjp1
+             do i=1,iim
+                 q(i,j,l)=qppm(i,j,llm-l+1)
+             enddo
+          enddo
+         enddo
+            
+c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
+
+         do l=1,llm
+           do j=1,jjp1
+            q(iip1,j,l)=q(1,j,l)
+           enddo
+         enddo
+  
+      
+       return
+
+       end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/interpre.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/interpre.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/interpre.F	(revision 222)
@@ -0,0 +1,133 @@
+!
+! $Id: interpre.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+       subroutine interpre(q,qppm,w,fluxwppm,masse,
+     s            apppm,bpppm,massebx,masseby,pbaru,pbarv,
+     s            unatppm,vnatppm,psppm)
+
+      USE control_mod
+
+       implicit none
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+
+c---------------------------------------------------
+c Arguments     
+      real   apppm(llm+1),bpppm(llm+1)
+      real   q(iip1,jjp1,llm),qppm(iim,jjp1,llm)
+c---------------------------------------------------
+      real   masse(iip1,jjp1,llm) 
+      real   massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)      
+      real   w(iip1,jjp1,llm+1)
+      real   fluxwppm(iim,jjp1,llm)
+      real   pbaru(iip1,jjp1,llm )
+      real   pbarv(iip1,jjm,llm)
+      real   unatppm(iim,jjp1,llm)
+      real   vnatppm(iim,jjp1,llm)
+      real   psppm(iim,jjp1)
+c---------------------------------------------------
+c Local
+      real   vnat(iip1,jjp1,llm)
+      real   unat(iip1,jjp1,llm)
+      real   fluxw(iip1,jjp1,llm)
+      real   smass(iip1,jjp1)
+c----------------------------------------------------
+      integer l,ij,i,j
+
+c       CALCUL DE LA PRESSION DE SURFACE
+c       Les coefficients ap et bp sont passés en common 
+c       Calcul de la pression au sol en mb optimisée pour 
+c       la vectorialisation
+                   
+         do j=1,jjp1
+             do i=1,iip1
+                smass(i,j)=0.
+             enddo
+         enddo
+
+         do l=1,llm
+             do j=1,jjp1
+                 do i=1,iip1
+                    smass(i,j)=smass(i,j)+masse(i,j,l)
+                 enddo
+             enddo
+         enddo
+      
+         do j=1,jjp1
+             do i=1,iim
+                 psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01
+             end do
+         end do                        
+       
+c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS
+c Le programme ppm3d travaille avec les composantes
+c de vitesse et pas les flux, on doit donc passer de l'un à l'autre
+c Dans le même temps, on fait le changement d'orientation du vent en v
+      do l=1,llm
+          do j=1,jjm
+              do i=1,iip1
+                  vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)             
+              enddo
+          enddo
+          do  i=1,iim
+          vnat(i,jjp1,l)=0.
+          enddo
+          do j=1,jjp1
+              do i=1,iip1
+                  unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)
+              enddo
+          enddo
+      enddo
+              
+c CALCUL DU FLUX MASSIQUE VERTICAL
+c Flux en l=1 (sol) nul
+      fluxw=0.        
+      do l=1,llm
+           do j=1,jjp1
+              do i=1,iip1              
+               fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j)
+C               print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l),
+C     c                      'w(i,j,l)=',w(i,j,l)
+              enddo
+           enddo
+      enddo
+      
+c INVERSION DES NIVEAUX
+c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+c On passe donc des niveaux du LMDZ à ceux de Lin
+     
+      do l=1,llm+1
+          apppm(l)=ap(llm+2-l)
+          bpppm(l)=bp(llm+2-l)         
+      enddo 
+     
+      do l=1,llm
+          do j=1,jjp1
+             do i=1,iim     
+                 unatppm(i,j,l)=unat(i,j,llm-l+1)
+                 vnatppm(i,j,l)=vnat(i,j,llm-l+1)
+                 fluxwppm(i,j,l)=fluxw(i,j,llm-l+1)
+                 qppm(i,j,l)=q(i,j,llm-l+1)                              
+             enddo
+          enddo                                
+      enddo
+   
+      return
+      end
+
+
+
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/invert_lat.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/invert_lat.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/invert_lat.F90	(revision 222)
@@ -0,0 +1,21 @@
+
+SUBROUTINE invert_lat(xsize,ysize,vsize,field)
+
+    IMPLICIT NONE
+ 
+! Input variables
+    INTEGER, INTENT(IN) :: xsize,ysize,vsize
+    REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field
+! Local variables
+    REAL, DIMENSION (xsize,ysize,vsize)                :: f_aux
+    INTEGER :: l,j
+ 
+    DO l=1,vsize
+        DO j=1,ysize
+            f_aux(:,j,l)=field(:,ysize+1-j,l)
+	END DO
+    END DO
+    
+    field=f_aux
+
+    END SUBROUTINE invert_lat
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/juldate.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/juldate.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/juldate.F	(revision 222)
@@ -0,0 +1,33 @@
+!
+! $Id: juldate.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+	subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)
+c	Sous-routine de changement de date:
+c	gregorien>>>date julienne
+c	En entree:an,mois,jour,heure,min.,sec.
+c	En sortie:tjd
+	implicit real (a-h,o-z)
+	frac=((os/60.+om)/60.+oh)/24.
+	ojou=dble(ijou)+frac
+	    year=dble(ian)
+	    rmon=dble(imoi)
+	if (imoi .le. 2) then
+	    year=year-1.
+	    rmon=rmon+12.
+	endif
+	cf=year+(rmon/100.)+(ojou/10000.)
+	if (cf .ge. 1582.1015) then
+	    a=int(year/100)
+	    b=2-a+int(a/4)
+	else
+	    b=0
+	endif
+	tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou)
+     +   +1720994.5+b
+        tjdsec=(ojou-int(ojou))+(tjd-int(tjd))
+        tjd=int(tjd)+int(tjdsec)
+	tjdsec=tjdsec-int(tjdsec)
+	return
+	end
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien.F	(revision 222)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien ( klevel, teta, divgra )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c    ....     calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .........      variables  en arguments   ..............
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    .......................................................
+
+
+c
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+      CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_gam.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_gam.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_gam.F	(revision 222)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam ,
+     *                        unsapolnga, unsapolsga, teta, divgra )
+
+c  P. Le Van
+c
+c   ************************************************************
+c
+c      ....   calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c    klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    ............     variables  en arguments    ..........
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
+     *     unsapolnga, unsapolsga
+c
+c    ...........    variables  locales    .................
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    ......................................................
+
+c
+c
+c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+c
+      CALL   grad ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_rot.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_rot.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_rot.F	(revision 222)
@@ -0,0 +1,39 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
+c
+c    P. Le Van
+c
+c   ************************************************************
+c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+c   ************************************************************
+c
+c     klevel et rotin  sont des arguments  d'entree pour le s-prog
+c      rotout           est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c 
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+c   ........................................................
+c
+c
+      CALL  filtreg ( rotin ,   jjm, klevel,   2, 1, .FALSE., 1 )
+
+      CALL   nxgrad ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_rotgam.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_rotgam.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/laplacien_rotgam.F	(revision 222)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c   ........................................................
+c
+c
+
+      CALL   nxgrad_gam ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil ( klevel, ghx  ,   ghy , rotout )
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jm
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limx.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limx.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limx.F	(revision 222)
@@ -0,0 +1,110 @@
+!
+! $Header$
+!
+      SUBROUTINE limx(s0,sx,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+      real sx(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL q(ip1jmp1,llm)
+      real dxq(ip1jmp1,llm)
+
+
+      REAL new_m,zm
+      real dxqu(ip1jmp1)
+      real adxqu(ip1jmp1),dxqmax(ip1jmp1)
+
+      Logical extremum,first
+      save first
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      EXTERNAL filtreg
+
+      data first/.true./
+
+
+       DO  l = 1,llm
+         DO  ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dxq(ij,l) = sx(ij,l) /sm(ij,l)
+         ENDDO
+       ENDDO
+
+c   calcul de la pente a droite et a gauche de la maille
+
+      do l = 1, llm
+         do ij=iip2,ip1jm-1
+            dxqu(ij)=q(ij+1,l)-q(ij,l)
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqu(ij)=dxqu(ij-iim)
+         enddo
+
+         do ij=iip2,ip1jm
+            adxqu(ij)=abs(dxqu(ij))
+         enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+         do ij=iip2+1,ip1jm
+            dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqmax(ij-iim)=dxqmax(ij)
+         enddo
+
+c   calcul de la pente avec limitation
+
+         do ij=iip2+1,ip1jm
+            if(     dxqu(ij-1)*dxqu(ij).gt.0.
+     &         .and. dxq(ij,l)*dxqu(ij).gt.0.) then
+              dxq(ij,l)=
+     &         sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
+            else
+c   extremum local
+               dxq(ij,l)=0.
+            endif
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         enddo
+
+         DO  ij=1,ip1jmp1
+               sx(ij,l) = dxq(ij,l)*sm(ij,l)
+         ENDDO
+
+       ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limy.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limy.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limy.F	(revision 222)
@@ -0,0 +1,194 @@
+!
+! $Header$
+!
+      SUBROUTINE limy(s0,sy,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL q(ip1jmp1,llm)
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      real sigv,dyq(ip1jmp1),dyqv(ip1jm)
+      real adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2
+      Logical extremum,first
+      save first
+
+      real convpn,convps,convmpn,convmps
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      save sinlon,coslon,sinlondlon,coslondlon
+c
+c
+      REAL      SSUM
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      EXTERNAL filtreg
+
+      data first/.true./
+
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+      endif
+
+c
+
+      do l = 1, llm
+c
+         DO ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dyq(ij) = sy(ij,l) / sm ( ij,l )
+         ENDDO
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      airej2 = SSUM( iim, aire(iip2), 1 )
+      airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      do ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      do ij=iip2,ip1jm
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      enddo
+
+c   calcul des pentes aux poles
+
+c   calcul des pentes limites aux poles
+
+c     print*,dyqv(iip1+1)
+c     appn=abs(dyq(1)/dyqv(iip1+1))
+c     print*,dyq(ip1jm+1)
+c     print*,dyqv(ip1jm-iip1+1)
+c     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+c     do ij=2,iim
+c        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+c        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+c     enddo
+c     appn=min(pente_max/appn,1.)
+c     apps=min(pente_max/apps,1.)
+
+
+c   cas ou on a un extremum au pole
+
+c     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+c    &   appn=0.
+c     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+c    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+c    &   apps=0.
+
+c   limitation des pentes aux poles
+c     do ij=1,iip1
+c        dyq(ij)=appn*dyq(ij)
+c        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+c     enddo
+
+c   test
+c      do ij=1,iip1
+c         dyq(iip1+ij)=0.
+c         dyq(ip1jm+ij-iip1)=0.
+c      enddo
+c      do ij=1,ip1jmp1
+c         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+c      enddo
+
+      if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+     &   then
+         do ij=1,iip1
+            dyqmax(ij)=0.
+         enddo
+      else
+         do ij=1,iip1
+            dyqmax(ij)=pente_max*abs(dyqv(ij))
+         enddo
+      endif
+
+      if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+     & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+     &then
+         do ij=ip1jm+1,ip1jmp1
+            dyqmax(ij)=0.
+         enddo
+      else
+         do ij=ip1jm+1,ip1jmp1
+            dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+         enddo
+      endif
+
+c   calcul des pentes limitees
+
+      do ij=1,ip1jmp1
+         if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then
+            dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))
+         else
+            dyq(ij)=0.
+         endif
+      enddo
+
+         DO ij=1,ip1jmp1
+               sy(ij,l) = dyq(ij) * sm ( ij,l )
+        ENDDO
+
+      enddo ! fin de la boucle sur les couches verticales
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limz.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limz.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/limz.F	(revision 222)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE limz(s0,sz,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+      real sz(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL q(ip1jmp1,llm)
+      real dzq(ip1jmp1,llm)
+
+
+      REAL new_m,zm
+      real dzqw(ip1jmp1)
+      real adzqw(ip1jmp1),dzqmax(ip1jmp1)
+
+      Logical extremum,first
+      save first
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      EXTERNAL filtreg
+
+      data first/.true./
+
+
+       DO  l = 1,llm
+         DO  ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dzq(ij,l) = sz(ij,l) /sm(ij,l)
+         ENDDO
+       ENDDO
+
+c   calcul de la pente en haut et en bas de la maille
+       do ij=1,ip1jmp1
+       do l = 1, llm-1
+            dzqw(l)=q(ij,l+1)-q(ij,l)
+         enddo
+            dzqw(llm)=0.
+
+         do  l=1,llm
+            adzqw(l)=abs(dzqw(l))
+         enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+         do l=2,llm-1
+            dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l))
+         enddo
+
+c   calcul de la pente avec limitation
+
+         do l=2,llm-1
+            if(     dzqw(l-1)*dzqw(l).gt.0.
+     &         .and. dzq(ij,l)*dzqw(l).gt.0.) then
+              dzq(ij,l)=
+     &         sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l))
+            else
+c   extremum local
+               dzq(ij,l)=0.
+            endif
+         enddo
+
+         DO  l=1,llm
+               sz(ij,l) = dzq(ij,l)*sm(ij,l)
+         ENDDO
+
+       ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massbar.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massbar.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massbar.F	(revision 222)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE massbar(  masse, massebx, masseby )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO  ij = 1, ip1jmp1 - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jmp1, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+         DO  ij = 1,ip1jm
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massbarxy.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massbarxy.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massbarxy.F	(revision 222)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE massbarxy(  masse, massebxy )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = 1, ip1jm - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massdair.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massdair.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/massdair.F	(revision 222)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE massdair( p, masse )
+c
+c *********************************************************************
+c       ....  Calcule la masse d'air  dans chaque maille   ....
+c *********************************************************************
+c
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..    p                      est  un argum. d'entree pour le s-pg ...
+c  ..  masse                    est un  argum.de sortie pour le s-pg ...
+c     
+c  ....  p est defini aux interfaces des llm couches   .....
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c  .....   arguments  ....
+c
+      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
+
+c   ....  Variables locales  .....
+
+      INTEGER l,ij
+      REAL massemoyn, massemoys
+
+      REAL SSUM
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO    ij     = 1, ip1jmp1
+         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+        ENDDO
+c
+        DO   ij = 1, ip1jmp1,iip1
+         masse(ij+ iim,l) = masse(ij,l)
+        ENDDO
+c
+c       DO    ij     = 1,  iim
+c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
+c       ENDDO
+c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+c       DO    ij     = 1, iip1
+c        masse(   ij   ,l )    = massemoyn
+c        masse(ij+ip1jm,l )    = massemoys
+c       ENDDO
+       
+100   CONTINUE
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/minmax.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/minmax.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/minmax.F	(revision 222)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+       SUBROUTINE minmax(imax, xi, zmin, zmax )
+c
+c      P. Le Van
+
+       INTEGER imax
+       REAL    xi(imax)
+       REAL    zmin,zmax
+       INTEGER i
+
+       zmin = xi(1)
+       zmax = xi(1)
+
+       DO i = 2, imax
+         zmin = MIN( zmin,xi(i) )
+         zmax = MAX( zmax,xi(i) )
+       ENDDO
+
+       RETURN
+       END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/minmax2.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/minmax2.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/minmax2.F	(revision 222)
@@ -0,0 +1,20 @@
+!
+! $Header$
+!
+       SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax )
+c
+       INTEGER lmax,jmax,imax
+       REAL xi(imax*jmax*lmax) 
+       REAL zmin,zmax
+       INTEGER i
+    
+       zmin = xi(1)
+       zmax = xi(1)
+
+       DO i = 2, imax*jmax*lmax
+         zmin = MIN( zmin,xi(i) )
+         zmax = MAX( zmax,xi(i) )
+       ENDDO
+
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrad.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrad.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrad.F	(revision 222)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrad (klevel, rot, x, y )
+c
+c     P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrad_gam.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrad_gam.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrad_gam.F	(revision 222)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrad_gam( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgradst.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgradst.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgradst.F	(revision 222)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgradst (klevel,rot, x, y )
+c
+      IMPLICIT NONE
+c     Auteur :  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y(ij,l)=( rot(ij,l) - rot(ij-1,l))
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgraro2.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgraro2.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgraro2.F	(revision 222)
@@ -0,0 +1,68 @@
+!
+! $Header$
+!
+       SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
+c
+c      P.Le Van .
+c   ***********************************************************
+c                                 lr
+c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+c
+c    ......  variables en arguments  .......
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL rot(ip1jm,llm) , signe, nugradrs
+      INTEGER l,ij,iter,lr
+c    ........................................................
+c
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+c
+      CALL     rotatf     ( klevel, grx, gry, rot )
+c
+      CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
+
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+        CALL laplacien_rotgam ( klevel, rot, rot )
+      ENDDO
+c
+c
+      CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
+      CALL nxgrad ( klevel, rot, grx, gry )
+c
+      DO    l = 1, klevel
+         DO  ij = 1, ip1jm
+          gry( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+         DO  ij = 1, ip1jmp1
+          grx( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrarot.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrarot.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/nxgrarot.F	(revision 222)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
+c   ***********************************************************
+c
+c    Auteur :  P.Le Van  
+c
+c                                 lr
+c      calcul de  ( nXgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+      REAL rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      DO 10 iter = 1,lr
+      CALL  rotat (klevel,grx, gry, rot )
+      CALL filtreg( rot, jjm, klevel, 2,1, .false.,2)
+      CALL nxgrad (klevel,rot, grx, gry )
+c
+      DO 5  l = 1, klevel
+      DO 2 ij = 1, ip1jm
+      gry( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      DO 3 ij = 1, ip1jmp1
+      grx( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/paramet.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/paramet.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/paramet.h	(revision 222)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1,iip2=iim+2,iip3=iim+3                       &
+     &    ,jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pbar.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pbar.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pbar.F	(revision 222)
@@ -0,0 +1,124 @@
+!
+! $Header$
+!
+      SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c *********************************************************************
+c
+c          pext               est  un argum. d'entree  pour le s-pg ..
+c     pbarx,pbary et pbarxy  sont des argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+
+#include "comgeom.h"
+
+      REAL pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
+      REAL pbary(  ip1jm  ),  pbarxy(  ip1jm  )
+
+      INTEGER   ij
+
+
+
+      DO 1 ij = 1, ip1jmp1 - 1
+      pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
+   1  CONTINUE
+
+c    .... correction pour pbarx( iip1,j) .....
+
+c    ...    pbarx(iip1,j)= pbarx(1,j) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jmp1, iip1
+      pbarx( ij ) = pbarx( ij - iim )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     +
+     *              pext( ij+iip1 ) * alpha1p4( ij+iip1 )
+   3  CONTINUE
+
+
+      DO 5 ij = 1, ip1jm - 1
+      pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     pbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      pbarxy( ij ) = pbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pentes_ini.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pentes_ini.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pentes_ini.F	(revision 222)
@@ -0,0 +1,478 @@
+!
+! $Header$
+!
+      SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
+      IMPLICIT NONE
+
+c=======================================================================
+c   Adaptation LMDZ:  A.Armengaud (LGGE)
+c   ----------------
+c
+c   ********************************************************************
+c   Transport des traceurs par la methode des pentes
+c   ********************************************************************
+c   Reference possible : Russel. G.L., Lerner J.A.:
+c         A new Finite-Differencing Scheme for Traceur Transport 
+c         Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 
+c   ********************************************************************
+c   q,w,masse,pbaru et pbarv 
+c                      sont des arguments d'entree  pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c   Arguments:
+c   ----------
+      integer mode
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL q( iip1,jjp1,llm,0:3)
+      REAL w( ip1jmp1,llm )
+      REAL masse( iip1,jjp1,llm)
+c   Local:
+c   ------
+      LOGICAL limit
+      REAL sm ( iip1,jjp1, llm )
+      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+      real masn,mass,zz
+      INTEGER i,j,l,iq
+
+c  modif Fred 24 03 96
+
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      save sinlon,coslon,sinlondlon,coslondlon
+      real dyn1,dyn2,dys1,dys2
+      real qpn,qps,dqzpn,dqzps
+      real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1)
+      real qmin,zq,pente_max
+c
+      REAL      SSUM
+      integer ismax,ismin,lati,latf
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      logical first
+      save first
+c   fin modif
+
+c      EXTERNAL masskg
+      EXTERNAL advx
+      EXTERNAL advy
+      EXTERNAL advz
+
+c  modif Fred 24 03 96
+      data first/.true./
+
+      limit = .TRUE.
+      pente_max=2
+c     if (mode.eq.1.or.mode.eq.3) then
+c     if (mode.eq.1) then
+      if (mode.ge.1) then
+        lati=2
+        latf=jjm
+      else
+        lati=1
+        latf=jjp1
+      endif
+
+      qmin=0.4995
+      qmin=0.
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+            print*,coslondlon(i),sinlondlon(i)
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1)
+         print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1)
+        DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+         q ( i,j,l,1 )=0.
+         q ( i,j,l,2 )=0.
+         q ( i,j,l,3 )=0.  
+         ENDDO
+         ENDDO
+        ENDDO
+        
+      endif
+c   Fin modif Fred
+
+c *** q contient les qqtes de traceur avant l'advection 
+
+c *** Affectation des tableaux S a partir de Q
+c *** Rem : utilisation de SCOPY ulterieurement
+ 
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+             s0( i,j,llm+1-l ) = q ( i,j,l,0 )
+             sx( i,j,llm+1-l ) = q ( i,j,l,1 )
+             sy( i,j,llm+1-l ) = q ( i,j,l,2 )
+             sz( i,j,llm+1-l ) = q ( i,j,l,3 )
+         ENDDO
+        ENDDO
+       ENDDO
+
+c      PRINT*,'----- S0 just before conversion -------'
+c      PRINT*,'S0(16,12,1)=',s0(16,12,1) 
+c      PRINT*,'Q(16,12,1,4)=',q(16,12,1,4)
+
+c *** On calcule la masse d'air en kg
+
+       DO  l = 1,llm
+         DO  j = 1,jjp1
+           DO  i = 1,iip1
+            sm ( i,j,llm+1-l)=masse( i,j,l )
+          ENDDO
+         ENDDO
+       ENDDO
+
+c *** On converti les champs S en atome (resp. kg) 
+c *** Les routines d'advection traitent les champs
+c *** a advecter si ces derniers sont en atome (resp. kg)
+c *** A optimiser !!!
+
+       DO  l = 1,llm
+         DO  j = 1,jjp1
+           DO  i = 1,iip1
+               s0(i,j,l) = s0(i,j,l) * sm ( i,j,l )
+               sx(i,j,l) = sx(i,j,l) * sm ( i,j,l )
+               sy(i,j,l) = sy(i,j,l) * sm ( i,j,l )
+               sz(i,j,l) = sz(i,j,l) * sm ( i,j,l )
+           ENDDO
+         ENDDO
+       ENDDO
+
+c       ss0 = 0.
+c       DO l = 1,llm
+c        DO j = 1,jjp1
+c         DO i = 1,iim
+c            ss0 = ss0 + s0 ( i,j,l )
+c         ENDDO
+c        ENDDO
+c       ENDDO
+c       PRINT*, 'valeur tot s0 avant advection=',ss0
+
+c *** Appel des subroutines d'advection en X, en Y et en Z
+c *** Advection avec "time-splitting"
+      
+c-----------------------------------------------------------
+c      PRINT*,'----- S0 just before ADVX -------'
+c      PRINT*,'S0(16,12,1)=',s0(16,12,1)
+
+c-----------------------------------------------------------
+c      do l=1,llm
+c         do j=1,jjp1
+c          do i=1,iip1
+c             zq=s0(i,j,l)/sm(i,j,l)
+c            if(zq.lt.qmin)
+c    ,       print*,'avant advx1, s0(',i,',',j,',',l,')=',zq
+c          enddo
+c         enddo
+c      enddo
+CCC
+       if(mode.eq.2) then
+          do l=1,llm
+            s0s=0.
+            s0n=0.
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            smn=0.
+            sms=0.
+            do i=1,iim
+               smn=smn+sm(i,1,l)
+               sms=sms+sm(i,jjp1,l)
+               s0n=s0n+s0(i,1,l)
+               s0s=s0s+s0(i,jjp1,l)
+               zz=sy(i,1,l)/sm(i,1,l)
+               dyn1=dyn1+sinlondlon(i)*zz
+               dyn2=dyn2+coslondlon(i)*zz
+               zz=sy(i,jjp1,l)/sm(i,jjp1,l)
+               dys1=dys1+sinlondlon(i)*zz
+               dys2=dys2+coslondlon(i)*zz
+            enddo
+            do i=1,iim
+               sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i)
+               sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i)
+            enddo
+            do i=1,iim
+               s0(i,1,l)=s0n/smn+sy(i,1,l)
+               s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l)
+            enddo
+
+            s0(iip1,1,l)=s0(1,1,l)
+            s0(iip1,jjp1,l)=s0(1,jjp1,l)
+
+            do i=1,iim
+               sxn(i)=s0(i+1,1,l)-s0(i,1,l)
+               sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l)
+c   on rerentre les masses
+            enddo
+            do i=1,iim
+               sy(i,1,l)=sy(i,1,l)*sm(i,1,l)
+               sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l)
+               s0(i,1,l)=s0(i,1,l)*sm(i,1,l)
+               s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l)
+            enddo
+            sxn(iip1)=sxn(1)
+            sxs(iip1)=sxs(1)
+            do i=1,iim
+               sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l)
+               sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l)
+            enddo
+            s0(iip1,1,l)=s0(1,1,l)
+            s0(iip1,jjp1,l)=s0(1,jjp1,l)
+            sy(iip1,1,l)=sy(1,1,l)
+            sy(iip1,jjp1,l)=sy(1,jjp1,l)
+            sx(1,1,l)=sx(iip1,1,l)
+            sx(1,jjp1,l)=sx(iip1,jjp1,l)
+          enddo
+      endif
+
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+      call limx(s0,sx,sm,pente_max)
+c     call minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+       call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
+c     call minmaxq(zq,1.e33,-1.e33,'avant advy     ')
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+       call   limy(s0,sy,sm,pente_max)
+       call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) 
+c     call minmaxq(zq,1.e33,-1.e33,'avant advz     ')
+       do j=1,jjp1
+          do i=1,iip1
+             sz(i,j,1)=0.
+             sz(i,j,llm)=0.
+          enddo
+       enddo
+       call limz(s0,sz,sm,pente_max)
+       call advz( limit,dtvr,w,sm,s0,sx,sy,sz )
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+        call limy(s0,sy,sm,pente_max)
+       call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) 
+       do l=1,llm
+          do j=1,jjp1
+             sm(iip1,j,l)=sm(1,j,l)
+             s0(iip1,j,l)=s0(1,j,l)
+             sx(iip1,j,l)=sx(1,j,l)
+             sy(iip1,j,l)=sy(1,j,l)
+             sz(iip1,j,l)=sz(1,j,l)
+          enddo
+       enddo
+
+
+c     call minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+       call limx(s0,sx,sm,pente_max)
+       call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) 
+c     call minmaxq(zq,1.e33,-1.e33,'apres advx     ')
+c      do l=1,llm
+c         do j=1,jjp1
+c          do i=1,iip1
+c             zq=s0(i,j,l)/sm(i,j,l)
+c            if(zq.lt.qmin)
+c    ,       print*,'apres advx2, s0(',i,',',j,',',l,')=',zq
+c          enddo
+c         enddo
+c      enddo
+c ***   On repasse les S dans la variable q directement 14/10/94
+c   On revient a des rapports de melange en divisant par la masse
+
+c En dehors des poles:
+
+       DO  l = 1,llm
+        DO  j = 1,jjp1
+         DO  i = 1,iim
+             q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l)
+         ENDDO
+        ENDDO
+      ENDDO
+
+c Traitements specifiques au pole
+
+      if(mode.ge.1) then
+      DO l=1,llm
+c   filtrages aux poles
+         masn=ssum(iim,sm(1,1,l),1)
+         mass=ssum(iim,sm(1,jjp1,l),1)
+         qpn=ssum(iim,s0(1,1,l),1)/masn
+         qps=ssum(iim,s0(1,jjp1,l),1)/mass
+         dqzpn=ssum(iim,sz(1,1,l),1)/masn
+         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+         do i=1,iip1
+            q( i,1,llm+1-l,3)=dqzpn
+            q( i,jjp1,llm+1-l,3)=dqzps
+            q( i,1,llm+1-l,0)=qpn
+            q( i,jjp1,llm+1-l,0)=qps
+         enddo
+         if(mode.eq.3) then
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            do i=1,iim
+               dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l)
+               dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l)
+               dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+               dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+            enddo
+            do i=1,iim
+               q(i,1,llm+1-l,2)=
+     s          (sinlon(i)*dyn1+coslon(i)*dyn2)
+               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+               q(i,jjp1,llm+1-l,2)=
+     s          (sinlon(i)*dys1+coslon(i)*dys2)
+               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     s         -q(i,jjp1,llm+1-l,2)
+            enddo
+         endif
+         if(mode.eq.1) then
+c   on filtre les valeurs au bord de la "grande maille pole"
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            do i=1,iim
+               zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+               dyn1=dyn1+sinlondlon(i)*zz
+               dyn2=dyn2+coslondlon(i)*zz
+               zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+               dys1=dys1+sinlondlon(i)*zz
+               dys2=dys2+coslondlon(i)*zz
+            enddo
+            do i=1,iim
+               q(i,1,llm+1-l,2)=
+     s          (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+               q(i,jjp1,llm+1-l,2)=
+     s          (sinlon(i)*dys1+coslon(i)*dys2)/2.
+               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     s         -q(i,jjp1,llm+1-l,2)
+            enddo
+            q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+            q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+
+            do i=1,iim
+               sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+               sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+            enddo
+            sxn(iip1)=sxn(1)
+            sxs(iip1)=sxs(1)
+            do i=1,iim
+               q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+               q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+            enddo
+            q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+            q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1)
+
+         endif
+
+       ENDDO
+       endif
+
+c bouclage en longitude
+      do iq=0,3
+         do l=1,llm
+            do j=1,jjp1
+               q(iip1,j,l,iq)=q(1,j,l,iq)
+            enddo
+         enddo
+      enddo
+
+c       PRINT*, ' SORTIE DE PENTES ---  ca peut glisser ....'
+
+        DO l = 1,llm
+    	 DO j = 1,jjp1
+    	  DO i = 1,iip1
+                IF (q(i,j,l,0).lt.0.)  THEN
+c                    PRINT*,'------------ BIP-----------' 
+c                    PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0)
+c                    PRINT*,'QX(',i,j,l,')=',q(i,j,l,1)
+c                    PRINT*,'QY(',i,j,l,')=',q(i,j,l,2)
+c                    PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3)
+c       		     PRINT*,' PBL EN SORTIE DE PENTES'
+                     q(i,j,l,0)=0.
+c                    STOP
+                 ENDIF
+          ENDDO
+         ENDDO
+        ENDDO
+
+c       PRINT*, '-------------------------------------------'
+        
+       do l=1,llm
+          do j=1,jjp1
+           do i=1,iip1
+             if(q(i,j,l,0).lt.qmin)
+     ,       print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)
+           enddo
+          enddo
+       enddo
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ppm3d.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ppm3d.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ppm3d.F	(revision 222)
@@ -0,0 +1,2001 @@
+!
+! $Id: ppm3d.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+
+cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998
+cDate: Wed, 15 Apr 1998 11:37:03 -0400
+cFrom: lin@explorer.gsfc.nasa.gov
+cTo: Frederic.Hourdin@lmd.jussieu.fr
+cSubject: 3D transport module of the GSFC CTM and GEOS GCM
+
+
+cThis code is sent to you by S-J Lin, DAO, NASA-GSFC
+
+cNote: this version is intended for machines like CRAY
+C-90. No multitasking directives implemented.
+
+      
+C ********************************************************************
+C
+C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard
+C Earth Observing System General Circulation Model (GEOS-GCM), and Data
+C Assimilation System (GEOS-DAS).
+C
+C ********************************************************************
+C
+C Purpose: given horizontal winds on  a hybrid sigma-p surfaces,
+C          one call to tpcore updates the 3-D mixing ratio
+C          fields one time step (NDT). [vertical mass flux is computed
+C          internally consistent with the discretized hydrostatic mass
+C          continuity equation of the C-Grid GEOS-GCM (for IGD=1)].
+C
+C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based
+C          on the van Leer or PPM.
+C          (see Lin and Rood 1996).
+C Version 4.5
+C Last modified: Dec. 5, 1996
+C Major changes from version 4.0: a more general vertical hybrid sigma-
+C pressure coordinate.
+C Subroutines modified: xtp, ytp, fzppm, qckxyz
+C Subroutines deleted: vanz
+C
+C Author: Shian-Jiann Lin
+C mail address:
+C                 Shian-Jiann Lin*
+C                 Code 910.3, NASA/GSFC, Greenbelt, MD 20771
+C                 Phone: 301-286-9540
+C                 E-mail: lin@dao.gsfc.nasa.gov
+C
+C *affiliation:
+C                 Joint Center for Earth Systems Technology
+C                 The University of Maryland Baltimore County
+C                 NASA - Goddard Space Flight Center
+C References:
+C
+C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi-
+C    Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070.
+C
+C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of
+C    the van Leer-type transport schemes and its applications to the moist-
+C    ure transport in a General Circulation Model. Mon. Wea. Rev., 122,
+C    1575-1593.
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR,
+     &                  JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax)
+
+c      implicit none
+
+c     rajout de déclarations
+c      integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd
+c      integer iu,iiu,j2,jmr,js0,jt
+c      real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp
+c      real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru
+C
+C ********************************************************************
+C
+C =============
+C INPUT:
+C =============
+C
+C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t)
+C NC: total # of constituents
+C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR
+C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1
+C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at
+C       the model top to NLAY near the surface (see fig. below).
+C       It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation)
+C
+C PS1(IMR,JNP): surface pressure at current time (t)
+C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2)
+C PS2 is replaced by the predicted PS (at t+NDT) on output.
+C Note: surface pressure can have any unit or can be multiplied by any
+C       const.
+C
+C The pressure at layer edges are defined as follows:
+C
+C        p(i,j,k) = AP(k)*PT  +  BP(k)*PS(i,j)          (1)
+C
+C Where PT is a constant having the same unit as PS.
+C AP and BP are unitless constants given at layer edges
+C defining the vertical coordinate. 
+C BP(1) = 0., BP(NLAY+1) = 1.
+C The pressure at the model top is PTOP = AP(1)*PT
+C
+C For pure sigma system set AP(k) = 1 for all k, PT = PTOP,
+C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP.
+C
+C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn
+C is a subset of the following even more general sigma-P-thelta coord.
+C currently under development.
+C  p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa))
+C
+C                  /////////////////////////////////
+C              / \ ------------- PTOP --------------  AP(1), BP(1)
+C               |
+C    delp(1)    |  ........... Q(i,j,1) ............  
+C               |
+C      W(1)    \ / ---------------------------------  AP(2), BP(2)
+C
+C
+C
+C     W(k-1)   / \ ---------------------------------  AP(k), BP(k)
+C               |
+C    delp(K)    |  ........... Q(i,j,k) ............ 
+C               |
+C      W(k)    \ / ---------------------------------  AP(k+1), BP(k+1)
+C
+C
+C
+C              / \ ---------------------------------  AP(NLAY), BP(NLAY)
+C               |
+C  delp(NLAY)   |  ........... Q(i,j,NLAY) .........  
+C               |
+C   W(NLAY)=0  \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1)
+C                 //////////////////////////////////
+C
+C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2)
+C U and V may need to be polar filtered in advance in some cases.
+C 
+C IGD:      grid type on which winds are defined.
+C IGD = 0:  A-Grid  [all variables defined at the same point from south
+C                   pole (j=1) to north pole (j=JNP) ]
+C
+C IGD = 1  GEOS-GCM C-Grid
+C                                      [North]
+C
+C                                       V(i,j)
+C                                          |
+C                                          |
+C                                          |
+C                             U(i-1,j)---Q(i,j)---U(i,j) [EAST]
+C                                          |
+C                                          |
+C                                          |
+C                                       V(i,j-1)
+C
+C         U(i,  1) is defined at South Pole.
+C         V(i,  1) is half grid north of the South Pole.
+C         V(i,JMR) is half grid south of the North Pole.
+C
+C         V must be defined at j=1 and j=JMR if IGD=1
+C         V at JNP need not be given.
+C
+C NDT: time step in seconds (need not be constant during the course of
+C      the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5
+C      (Lat-Lon) resolution. Smaller values are recommanded if the model
+C      has a well-resolved stratosphere.
+C
+C J1 defines the size of the polar cap:
+C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg.
+C North polar cap edge is located at  90 - (j1-1.5)*180/(JNP-1) deg.
+C There are currently only two choices (j1=2 or 3).
+C IMR must be an even integer if j1 = 2. Recommended value: J1=3.
+C
+C IORD, JORD, and KORD are integers controlling various options in E-W, N-S,
+C and vertical transport, respectively. Recommended values for positive
+C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non-
+C positive definite scalars or when linear correlation between constituents
+C is to be maintained.
+C
+C  _ORD= 
+C        1: 1st order upstream scheme (too diffusive, not a useful option; it
+C           can be used for debugging purposes; this is THE only known "linear"
+C           monotonic advection scheme.).
+C        2: 2nd order van Leer (full monotonicity constraint;
+C           see Lin et al 1994, MWR)
+C        3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984)
+C        4: semi-monotonic PPM (same as 3, but overshoots are allowed)
+C        5: positive-definite PPM (constraint on the subgrid distribution is
+C           only strong enough to prevent generation of negative values;
+C           both overshoots & undershoots are possible).
+C        6: un-constrained PPM (nearly diffusion free; slightly faster but
+C           positivity not quaranteed. Use this option only when the fields
+C           and winds are very smooth).
+C
+C *PPM: Piece-wise Parabolic Method
+C
+C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5.
+C for non-positive definite scalars (such as Ertel Potential Vorticity).
+C
+C The implicit numerical diffusion decreases as _ORD increases.
+C The last two options (ORDER=5, 6) should only be used when there is
+C significant explicit diffusion (such as a turbulence parameterization). You
+C might get dispersive results otherwise.
+C No filter of any kind is applied to the constituent fields here.
+C
+C AE: Radius of the sphere (meters).
+C     Recommended value for the planet earth: 6.371E6
+C
+C fill(logical):   flag to do filling for negatives (see note below).
+C
+C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s).
+C (220 m/s is a good value for troposphere model; 280 m/s otherwise)
+C
+C =============
+C Output
+C =============
+C
+C Q: mixing ratios at future time (t+NDT) (original values are over-written)
+C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic
+C          relationship. W will have the same unit as PS1 and PS2 (eg, mb).
+C          W must be divided by NDT to get the correct mass-flux unit.
+C          The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND
+C          is the pressure thickness in the "upwind" direction. For example,
+C          C(k) = W(k)/delp(k)   if W(k) > 0;
+C          C(k) = W(k)/delp(k+1) if W(k) < 0.
+C              ( W > 0 is downward, ie, toward surface)
+C PS2: predicted PS at t+NDT (original values are over-written)
+C
+C ********************************************************************
+C NOTES:
+C This forward-in-time upstream-biased transport scheme reduces to
+C the 2nd order center-in-time center-in-space mass continuity eqn.
+C if Q = 1 (constant fields will remain constant). This also ensures
+C that the computed vertical velocity to be identical to GEOS-1 GCM
+C for on-line transport.
+C
+C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when
+C winds are noisy near poles).
+C
+C Flux-Form Semi-Lagrangian transport in the East-West direction is used
+C when and where Courant # is greater than one.
+C
+C The user needs to change the parameter Jmax or Kmax if the resolution
+C is greater than 0.5 deg in N-S or 150 layers in the vertical direction.
+C (this TransPort Core is otherwise resolution independent and can be used
+C as a library routine).
+C
+C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd
+C order accurate for non-uniform grid (vertical sigma coord.).
+C
+C Time step is limitted only by transport in the meridional direction.
+C (the FFSL scheme is not implemented in the meridional direction).
+C
+C Since only 1-D limiters are applied, negative values could
+C potentially be generated when large time step is used and when the
+C initial fields contain discontinuities.
+C This does not necessarily imply the integration is unstable.
+C These negatives are typically very small. A filling algorithm is
+C activated if the user set "fill" to be true.
+C
+C The van Leer scheme used here is nearly as accurate as the original PPM
+C due to the use of a 4th order accurate reference slope. The PPM imple-
+C mented here is an improvement over the original and is also based on
+C the 4th order reference slope.
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C     User modifiable parameters
+C
+      parameter (Jmax = 361, kmax = 150)
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C Input-Output arrays
+C
+      
+      real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP),
+     &     U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1),
+     &     BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax
+      integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE
+      integer IMRD2
+      real    PT       
+      logical  cross, fill, dum
+C
+C Local dynamic arrays
+C
+      real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP),
+     &     fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY),
+     &     WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP),
+     &     delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP),
+     &     UA(IMR,JNP),qtmp(-IMR:2*IMR)
+C
+C Local static  arrays
+C
+      real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax),
+     &     cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax)
+      data NDT0, NSTEP /0, 0/
+      data cross /.true./
+      SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML,
+     &     DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
+C
+            
+      JMR = JNP -1
+      IMJM  = IMR*JNP
+      j2 = JNP - j1 + 1
+      NSTEP = NSTEP + 1
+C
+C *********** Initialization **********************
+      if(NSTEP.eq.1) then
+c
+      write(6,*) '------------------------------------ '
+      write(6,*) 'NASA/GSFC Transport Core Version 4.5'
+      write(6,*) '------------------------------------ '
+c
+      WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1
+      WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT
+C
+C controles sur les parametres
+      if(NLAY.LT.6) then
+        write(6,*) 'NLAY must be >= 6'
+        stop
+      endif
+      if (JNP.LT.NLAY) then
+         write(6,*) 'JNP must be >= NLAY'
+        stop
+      endif
+      IMRD2=mod(IMR,2)
+      if (j1.eq.2.and.IMRD2.NE.0) then
+         write(6,*) 'if j1=2 IMR must be an even integer'
+        stop
+      endif
+
+C
+      if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then
+        write(6,*) 'Jmax or Kmax is too small'
+        stop
+      endif
+C
+      DO k=1,NLAY
+      DAP(k) = (AP(k+1) - AP(k))*PT
+      DBK(k) =  BP(k+1) - BP(k)
+      ENDDO     
+C
+      PI = 4. * ATAN(1.)
+      DL = 2.*PI / REAL(IMR)
+      DP =    PI / REAL(JMR)
+C
+      if(IGD.eq.0) then
+C Compute analytic cosine at cell edges
+            call cosa(cosp,cose,JNP,PI,DP)
+      else
+C Define cosine consistent with GEOS-GCM (using dycore2.0 or later)
+            call cosc(cosp,cose,JNP,PI,DP)
+      endif
+C
+      do 15 J=2,JMR
+15    acosp(j) = 1. / cosp(j)
+C
+C Inverse of the Scaled polar cap area.
+C
+      RCAP  = DP / (IMR*(1.-COS((j1-1.5)*DP)))
+      acosp(1)   = RCAP
+      acosp(JNP) = RCAP
+      endif
+C
+      if(NDT0 .ne. NDT) then
+      DT   = NDT
+      NDT0 = NDT
+
+	if(Umax .lt. 180.) then
+         write(6,*) 'Umax may be too small!'
+	endif
+      CR1  = abs(Umax*DT)/(DL*AE)
+      MaxDT = DP*AE / abs(Umax) + 0.5
+      write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT
+      if(MaxDT .lt. abs(NDT)) then
+            write(6,*) 'Warning!!! NDT maybe too large!'
+      endif
+C
+      if(CR1.ge.0.95) then
+      JS0 = 0
+      JN0 = 0
+      IML = IMR-2
+      ZTC = 0.
+      else
+      ZTC  = acos(CR1) * (180./PI)
+C
+      JS0 = REAL(JMR)*(90.-ZTC)/180. + 2
+      JS0 = max(JS0, J1+1)
+      IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
+      JN0 = JNP-JS0+1
+      endif
+C     
+C
+      do J=2,JMR
+      DTDX(j)  = DT / ( DL*AE*COSP(J) )
+
+c     print*,'dtdx=',dtdx(j)
+      DTDX5(j) = 0.5*DTDX(j)
+      enddo
+C
+      
+      DTDY  = DT /(AE*DP)
+c      print*,'dtdy=',dtdy
+      DTDY5 = 0.5*DTDY
+C
+c      write(6,*) 'J1=',J1,' J2=', J2
+      endif
+C
+C *********** End Initialization **********************
+C
+C delp = pressure thickness: the psudo-density in a hydrostatic system.
+      do  k=1,NLAY
+         do  j=1,JNP
+            do  i=1,IMR
+               delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j)
+               delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j)       
+            enddo
+         enddo
+      enddo
+          
+C
+      if(j1.ne.2) then
+      DO 40 IC=1,NC
+      DO 40 L=1,NLAY
+      DO 40 I=1,IMR
+      Q(I,  2,L,IC) = Q(I,  1,L,IC)
+40    Q(I,JMR,L,IC) = Q(I,JNP,L,IC)
+      endif
+C
+C Compute "tracer density"
+      DO 550 IC=1,NC
+      DO 44 k=1,NLAY
+      DO 44 j=1,JNP
+      DO 44 i=1,IMR
+44    DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k)
+550	continue
+C
+      do 1500 k=1,NLAY
+C
+      if(IGD.eq.0) then
+C Convert winds on A-Grid to Courant # on C-Grid.
+      call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      else
+C Convert winds on C-grid to Courant #
+      do 45 j=j1,j2
+      do 45 i=2,IMR
+45    CRX(i,J) = dtdx(j)*U(i-1,j,k)
+   
+C
+      do 50 j=j1,j2
+50    CRX(1,J) = dtdx(j)*U(IMR,j,k)
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY*V(i,1,k)
+      endif
+C     
+C Determine JS and JN
+      JS = j1
+      JN = j2
+C
+      do j=JS0,j1+1,-1
+      do i=1,IMR
+      if(abs(CRX(i,j)).GT.1.) then
+            JS = j
+            go to 2222
+      endif
+      enddo
+      enddo
+C
+2222  continue
+      do j=JN0,j2-1
+      do i=1,IMR
+      if(abs(CRX(i,j)).GT.1.) then
+            JN = j
+            go to 2233
+      endif
+      enddo
+      enddo
+2233  continue
+C
+      if(j1.ne.2) then           ! Enlarged polar cap.
+      do i=1,IMR
+      DPI(i,  2,k) = 0.
+      DPI(i,JMR,k) = 0.
+      enddo
+      endif
+C
+C ******* Compute horizontal mass fluxes ************
+C
+C N-S component
+      do j=j1,j2+1
+      D5 = 0.5 * COSE(j)
+      do i=1,IMR
+      ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k))
+      enddo
+      enddo
+C
+      do 95 j=j1,j2
+      DO 95 i=1,IMR
+95    DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
+C
+C Poles
+      sum1 = ymass(IMR,j1  )
+      sum2 = ymass(IMR,J2+1)
+      do i=1,IMR-1
+      sum1 = sum1 + ymass(i,j1  )
+      sum2 = sum2 + ymass(i,J2+1)
+      enddo
+C
+      sum1 = - sum1 * RCAP
+      sum2 =   sum2 * RCAP
+      do i=1,IMR
+      DPI(i,  1,k) = sum1
+      DPI(i,JNP,k) = sum2
+      enddo
+C
+C E-W component
+C
+      do j=j1,j2
+      do i=2,IMR
+      PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k))
+      enddo
+      enddo
+C
+      do j=j1,j2
+      PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k))
+      enddo
+C
+      do 110 j=j1,j2
+      DO 110 i=1,IMR
+110   xmass(i,j) = PU(i,j)*CRX(i,j)
+C
+      DO 120 j=j1,j2
+      DO 120 i=1,IMR-1
+120   DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j)
+C
+      DO 130 j=j1,j2
+130   DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j)
+C
+      DO j=j1,j2
+      do i=1,IMR-1
+      UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j))
+      enddo
+      enddo
+C
+      DO j=j1,j2
+      UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j))
+      enddo
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Rajouts pour LMDZ.3.3
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      do i=1,IMR
+         do j=1,JNP
+             VA(i,j)=0.
+         enddo
+      enddo
+
+      do i=1,imr*(JMR-1)
+      VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3))
+      enddo
+C
+      if(j1.eq.2) then
+	IMH = IMR/2
+      do i=1,IMH
+      VA(i,      1) = 0.5*(CRY(i,2)-CRY(i+IMH,2))
+      VA(i+IMH,  1) = -VA(i,1)
+      VA(i,    JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR))
+      VA(i+IMH,JNP) = -VA(i,JNP)
+      enddo
+      VA(IMR,1)=VA(1,1)
+      VA(IMR,JNP)=VA(1,JNP)
+      endif
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+      do 1000 IC=1,NC
+C
+      do i=1,IMJM
+      wk1(i,1,1) = 0.
+      wk1(i,1,2) = 0.
+      enddo
+C
+C E-W advective cross term
+      do 250 j=J1,J2
+      if(J.GT.JS  .and. J.LT.JN) GO TO 250
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j,k,IC)
+      enddo
+C
+      do i=-IML,0
+      qtmp(i)       = q(IMR+i,j,k,IC)
+      qtmp(IMR+1-i) = q(1-i,j,k,IC)
+      enddo
+C
+      DO 230 i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.0.) then
+      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+      else
+      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+      endif
+      wk1(i,j,1) = wk1(i,j,1) - qtmp(i)
+230   continue
+250   continue
+C
+      if(JN.ne.0) then
+      do j=JS+1,JN-1
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j,k,IC)
+      enddo
+C
+      qtmp(0)     = q(IMR,J,k,IC)
+      qtmp(IMR+1) = q(  1,J,k,IC)
+C
+      do i=1,imr
+      iu = i - UA(i,j)
+      wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1))
+      enddo
+      enddo
+      endif
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Contribution from the N-S advection
+      do i=1,imr*(j2-j1+1)
+      JT = REAL(J1) - VA(i,j1)
+      wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
+      enddo
+C
+      do i=1,IMJM
+      wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1)
+      wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2)
+      enddo
+C
+	if(cross) then
+C Add cross terms in the vertical direction.
+	if(IORD .GE. 2) then
+		iad = 2
+	else
+		iad = 1
+	endif
+C
+	if(JORD .GE. 2) then
+		jad = 2
+	else
+		jad = 1
+	endif
+      call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad)
+      call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad)
+      do j=1,JNP
+      do i=1,IMR
+      q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j)
+      enddo
+      enddo
+      endif
+C
+      call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2)
+     &        ,CRX,fx1,xmass,IORD)
+
+      call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY,
+     &  DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD)
+C
+1000  continue
+1500  continue
+C
+C ******* Compute vertical mass flux (same unit as PS) ***********
+C
+C 1st step: compute total column mass CONVERGENCE.
+C
+      do 320 j=1,JNP
+      do 320 i=1,IMR
+320   CRY(i,j) = DPI(i,j,1)
+C
+      do 330 k=2,NLAY
+      do 330 j=1,JNP
+      do 330 i=1,IMR
+      CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
+330   continue
+C
+      do 360 j=1,JNP
+      do 360 i=1,IMR
+C
+C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption.
+C Changes (increases) to surface pressure = total column mass convergence
+C
+      PS2(i,j)  = PS1(i,j) + CRY(i,j)
+C
+C 3rd step: compute vertical mass flux from mass conservation principle.
+C
+      W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j)
+      W(i,j,NLAY) = 0.
+360   continue
+C
+      do 370 k=2,NLAY-1
+      do 370 j=1,JNP
+      do 370 i=1,IMR
+      W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
+370   continue
+C
+      DO 380 k=1,NLAY
+      DO 380 j=1,JNP
+      DO 380 i=1,IMR
+      delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j)
+380   continue
+C
+	KRD = max(3, KORD)
+      do 4000 IC=1,NC
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+   
+      call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI,
+     &           DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD)
+C
+    
+      if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2,
+     &                     cosp,acosp,.false.,IC,NSTEP)
+C
+C Recover tracer mixing ratio from "density" using predicted
+C "air density" (pressure thickness) at time-level n+1
+C
+      DO k=1,NLAY
+      DO j=1,JNP
+      DO i=1,IMR
+            Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k)
+c            print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC)
+      enddo
+      enddo
+      enddo
+C     
+      if(j1.ne.2) then
+      DO 400 k=1,NLAY
+      DO 400 I=1,IMR
+c     j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord
+      Q(I,  2,k,IC) = Q(I,  1,k,IC)
+      Q(I,JMR,k,IC) = Q(I,JNP,k,IC)
+400   CONTINUE
+      endif
+4000  continue
+C
+      if(j1.ne.2) then
+      DO 5000 k=1,NLAY
+      DO 5000 i=1,IMR
+      W(i,  2,k) = W(i,  1,k)
+      W(i,JMR,k) = W(i,JNP,k)
+5000  continue
+      endif
+C
+      RETURN
+      END
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+      subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6,
+     &                 flux,wk1,wk2,wz2,delp,KORD)
+      parameter ( kmax = 150 )
+      parameter ( R23 = 2./3., R3 = 1./3.)
+      real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY),
+     &     wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY),
+     &     DQDT(IMR,JNP,NLAY)
+C Assuming JNP >= NLAY
+      real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*),
+     &     wz2(IMR,*)
+C
+      JMR = JNP - 1
+      IMJM = IMR*JNP
+      NLAYM1 = NLAY - 1
+C
+      LMT = KORD - 3
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Compute DC for PPM
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      do 1000 k=1,NLAYM1
+      do 1000 i=1,IMJM
+      DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
+1000  continue
+C
+      DO 1220 k=2,NLAYM1
+      DO 1220 I=1,IMJM    
+       c0 =  delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1))
+       c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k))    
+       c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k))
+      tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1))
+      Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k)
+      Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1))
+      DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp)   
+1220  CONTINUE
+     
+C     
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Loop over latitudes  (to save memory)
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 2000 j=1,JNP
+      if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000
+C
+      DO k=1,NLAY
+      DO i=1,IMR
+      wz2(i,k) =   WZ(i,j,k)
+      wk1(i,k) =    P(i,j,k)
+      wk2(i,k) = delp(i,j,k)
+      flux(i,k) = DC(i,j,k)  !this flux is actually the monotone slope
+      enddo
+      enddo
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C Compute first guesses at cell interfaces
+C First guesses are required to be continuous.
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C three-cell parabolic subgrid distribution at model top
+C two-cell parabolic with zero gradient subgrid distribution 
+C at the surface.
+C
+C First guess top edge value
+      DO 10 i=1,IMR
+C three-cell PPM
+C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
+      a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/
+     &         (wk2(i,1)+wk2(i,2)) ) /
+     &       ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) )
+      b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - 
+     &    R23*a*(2.*wk2(i,1)+wk2(i,2))
+      AL(i,1) =  wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b)
+      AL(i,2) =  wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1)
+C
+C Check if change sign
+      if(wk1(i,1)*AL(i,1).le.0.) then
+		 AL(i,1) = 0.
+             flux(i,1) = 0.
+	else
+             flux(i,1) =  wk1(i,1) - AL(i,1)
+	endif
+10    continue
+C
+C Bottom
+      DO 15 i=1,IMR
+C 2-cell PPM with zero gradient right at the surface
+C
+      fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 /
+     & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1)))
+      AR(i,NLAY) = wk1(i,NLAY) + fct
+      AL(i,NLAY) = wk1(i,NLAY) - (fct+fct)
+      if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0.
+      flux(i,NLAY) = AR(i,NLAY) -  wk1(i,NLAY)
+15    continue
+     
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C 4th order interpolation in the interior.
+C****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 14 k=3,NLAYM1
+      DO 12 i=1,IMR
+      c1 =  DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k))
+      c2 =  2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1))
+      A1   =  (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k))
+      A2   =  (wk2(i,k  )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1))
+      AL(i,k) = wk1(i,k-1) + c1 + c2 *
+     &        ( wk2(i,k  )*(c1*(A1 - A2)+A2*flux(i,k-1)) -
+     &          wk2(i,k-1)*A1*flux(i,k)  )
+C      print *,'AL1',i,k, AL(i,k)
+12    CONTINUE
+14    continue
+C
+      do 20 i=1,IMR*NLAYM1
+      AR(i,1) = AL(i,2)
+C      print *,'AR1',i,AR(i,1)
+20    continue
+C
+      do 30 i=1,IMR*NLAY
+      A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1)))
+C      print *,'A61',i,A6(i,1)
+30    continue
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C Top & Bot always monotonic
+      call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0)
+      call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY),
+     &            wk1(1,NLAY),IMR,0)
+C
+C Interior depending on KORD
+      if(LMT.LE.2)
+     &  call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2),
+     &              IMR*(NLAY-2),LMT)
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 140 i=1,IMR*NLAYM1
+      IF(wz2(i,1).GT.0.) then
+        CM = wz2(i,1) / wk2(i,1)
+        flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM))
+      else
+C        print *,'test2-0',i,j,wz2(i,1),wk2(i,2)
+        CP= wz2(i,1) / wk2(i,2)        
+C        print *,'testCP',CP
+        flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP))
+C        print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23
+      endif
+140   continue
+C
+      DO 250 i=1,IMR*NLAYM1
+      flux(i,2) = wz2(i,1) * flux(i,2)
+250   continue
+C
+      do 350 i=1,IMR
+      DQ(i,j,   1) = DQ(i,j,   1) - flux(i,   2)
+      DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY)
+350   continue
+C
+      do 360 k=2,NLAYM1
+      do 360 i=1,IMR
+360   DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
+2000  continue
+      return
+      end
+C
+      subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC,
+     &               fx1,xmass,IORD)
+      dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP)
+     &    ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML)
+      dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR)
+C
+      IMP = IMR + 1
+C
+C van Leer at high latitudes
+      jvan = max(1,JNP/18)
+      j1vl = j1+jvan
+      j2vl = j2-jvan
+C
+      do 1310 j=j1,j2
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j)
+      enddo
+C
+      if(j.ge.JN .or. j.le.JS) goto 2222
+C ************* Eulerian **********
+C
+      qtmp(0)     = q(IMR,J)
+      qtmp(-1)    = q(IMR-1,J)
+      qtmp(IMP)   = q(1,J)
+      qtmp(IMP+1) = q(2,J)
+C
+      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1406 i=1,IMR
+      iu = REAL(i) - uc(i,j)
+1406  fx1(i) = qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+      DC(0) = DC(IMR)
+C
+      if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then
+      DO 1408 i=1,IMR
+      iu = REAL(i) - uc(i,j)
+1408  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
+      else
+      call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
+      endif
+C
+      ENDIF
+C
+      DO 1506 i=1,IMR
+1506  fx1(i) = fx1(i)*xmass(i,j)
+C
+      goto 1309
+C
+C ***** Conservative (flux-form) Semi-Lagrangian transport *****
+C
+2222  continue
+C
+      do i=-IML,0
+      qtmp(i)     = q(IMR+i,j)
+      qtmp(IMP-i) = q(1-i,j)
+      enddo
+C
+      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1306 i=1,IMR
+      itmp = INT(uc(i,j))
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1306  fx1(i) = (uc(i,j) - itmp)*qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+C
+      do i=-IML,0
+      DC(i)     = DC(IMR+i)
+      DC(IMP-i) = DC(1-i)
+      enddo
+C
+      DO 1307 i=1,IMR
+      itmp = INT(uc(i,j))
+      rut  = uc(i,j) - itmp
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1307  fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut))
+      ENDIF
+C
+      do 1308 i=1,IMR
+      IF(uc(i,j).GT.1.) then
+CDIR$ NOVECTOR
+        do ist = ISAVE(i),i-1
+        fx1(i) = fx1(i) + qtmp(ist)
+        enddo
+      elseIF(uc(i,j).LT.-1.) then
+        do ist = i,ISAVE(i)-1
+        fx1(i) = fx1(i) - qtmp(ist)
+        enddo
+CDIR$ VECTOR
+      endif
+1308  continue
+      do i=1,IMR
+      fx1(i) = PU(i,j)*fx1(i)
+      enddo
+C
+C ***************************************
+C
+1309  fx1(IMP) = fx1(1)
+      DO 1215 i=1,IMR
+1215  DQ(i,j) =  DQ(i,j) + fx1(i)-fx1(i+1)
+C
+C ***************************************
+C
+1310  continue
+      return
+      end
+C
+      subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
+      DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR)
+      integer LMT 
+c      logical first
+c      data first /.true./
+c      SAVE LMT
+c      if(first) then
+C
+C correction calcul de LMT a chaque passage pour pouvoir choisir
+c plusieurs schemas PPM pour differents traceurs
+c      IF (IORD.LE.0) then
+c            if(IMR.GE.144) then
+c                  LMT = 0
+c            elseif(IMR.GE.72) then
+c                  LMT = 1
+c            else
+c                  LMT = 2
+c            endif
+c      else
+c            LMT = IORD - 3
+c      endif
+C
+      LMT = IORD - 3
+c      write(6,*) 'PPM option in E-W direction = ', LMT
+c      first = .false.
+C      endif
+C
+      DO 10 i=1,IMR
+10    AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3
+C
+      do 20 i=1,IMR-1
+20    AR(i) = AL(i+1)
+      AR(IMR) = AL(1)
+C
+      do 30 i=1,IMR
+30    A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
+C
+      if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT)
+C
+      AL(0) = AL(IMR)
+      AR(0) = AR(IMR)
+      A6(0) = A6(IMR)
+C
+      DO i=1,IMR
+      IF(UT(i).GT.0.) then
+      flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) +
+     &                 A6(i-1)*(1.-R23*UT(i)) )
+      else
+      flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) +
+     &                        A6(i)*(1.+R23*UT(i)))
+      endif
+      enddo
+      return
+      end
+C
+      subroutine xmist(IMR,IML,P,DC)
+      parameter( R24 = 1./24.)
+      dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+C
+      do 10  i=1,IMR
+      tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2))
+      Pmax = max(P(i-1), p(i), p(i+1)) - p(i)
+      Pmin = p(i) - min(P(i-1), p(i), p(i+1))
+10    DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp)
+      return
+      end
+C
+      subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2
+     &              ,ymass,fx,A6,AR,AL,JORD)
+      dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP)
+     &       ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP)
+C Work array
+      DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+C
+      JMR = JNP - 1
+      len = IMR*(J2-J1+2)
+C
+      if(JORD.eq.1) then
+      DO 1000 i=1,len
+      JT = REAL(J1) - VC(i,J1)
+1000  fx(i,j1) = p(i,JT)
+      else
+   
+      call ymist(IMR,JNP,j1,P,DC2,4)
+C
+      if(JORD.LE.0 .or. JORD.GE.3) then
+   
+      call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+    
+      else
+      DO 1200 i=1,len
+      JT = REAL(J1) - VC(i,J1)
+1200  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
+      endif
+      endif
+C
+      DO 1300 i=1,len
+1300  fx(i,j1) = fx(i,j1)*ymass(i,j1)
+C
+      DO 1400 j=j1,j2
+      DO 1400 i=1,IMR
+1400  DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j)
+C
+C Poles
+      sum1 = fx(IMR,j1  )
+      sum2 = fx(IMR,J2+1)
+      do i=1,IMR-1
+      sum1 = sum1 + fx(i,j1  )
+      sum2 = sum2 + fx(i,J2+1)
+      enddo
+C
+      sum1 = DQ(1,  1) - sum1 * RCAP
+      sum2 = DQ(1,JNP) + sum2 * RCAP
+      do i=1,IMR
+      DQ(i,  1) = sum1
+      DQ(i,JNP) = sum2
+      enddo
+C
+      if(j1.ne.2) then
+      do i=1,IMR
+      DQ(i,  2) = sum1
+      DQ(i,JMR) = sum2
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine  ymist(IMR,JNP,j1,P,DC,ID)
+      parameter ( R24 = 1./24. )
+      dimension P(IMR,JNP),DC(IMR,JNP)
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      IJM3 = IMR*(JMR-3)
+C
+      IF(ID.EQ.2) THEN
+      do 10 i=1,IMR*(JMR-1)
+      tmp = 0.25*(p(i,3) - p(i,1))
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+10    CONTINUE
+      ELSE
+      do 12 i=1,IMH
+C J=2
+      tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+C J=JMR
+      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24
+      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+12    CONTINUE
+      do 14 i=IMH+1,IMR
+C J=2
+      tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+C J=JMR
+      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24
+      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+14    CONTINUE
+C
+      do 15 i=1,IJM3
+      tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24
+      Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3)
+      Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4))
+      DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+15    CONTINUE
+      ENDIF
+C
+      if(j1.ne.2) then
+      do i=1,IMR
+      DC(i,1) = 0.
+      DC(i,JNP) = 0.
+      enddo
+      else
+C Determine slopes in polar caps for scalars!
+C
+      do 13 i=1,IMH
+C South
+      tmp = 0.25*(p(i,2) - p(i+imh,2))
+      Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1)
+      Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2))
+      DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp)
+C North.
+      tmp = 0.25*(p(i+imh,JMR) - p(i,JMR))
+      Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP)
+      Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR))
+      DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp)
+13    continue
+C
+      do 25 i=imh+1,IMR
+      DC(i,  1) =  - DC(i-imh,  1)
+      DC(i,JNP) =  - DC(i-imh,JNP)
+25    continue
+      endif
+      return
+      end
+C
+      subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
+C Local work arrays.
+      real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+      integer LMT
+c      logical first
+C      data first /.true./
+C      SAVE LMT
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      j11 = j1-1
+      IMJM1 = IMR*(J2-J1+2)
+      len   = IMR*(J2-J1+3)
+C      if(first) then
+C      IF(JORD.LE.0) then
+C            if(JMR.GE.90) then
+C                  LMT = 0
+C            elseif(JMR.GE.45) then
+C                  LMT = 1
+C            else
+C                  LMT = 2
+C            endif
+C      else
+C            LMT = JORD - 3
+C      endif
+C
+C      first = .false.
+C      endif
+C     
+c modifs pour pouvoir choisir plusieurs schemas PPM
+      LMT = JORD - 3      
+C
+      DO 10 i=1,IMR*JMR        
+      AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3
+      AR(i,1) = AL(i,2)
+10    CONTINUE
+C
+CPoles:
+C
+      DO i=1,IMH
+      AL(i,1) = AL(i+IMH,2)
+      AL(i+IMH,1) = AL(i,2)
+C
+      AR(i,JNP) = AR(i+IMH,JMR)
+      AR(i+IMH,JNP) = AR(i,JMR)
+      ENDDO
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   Rajout pour LMDZ.3.3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      AR(IMR,1)=AL(1,1)
+      AR(IMR,JNP)=AL(1,JNP)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      
+           
+      do 30 i=1,len
+30    A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
+C
+      if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11)
+     &                       ,AL(1,j11),P(1,j11),len,LMT)
+C
+     
+      DO 140 i=1,IMJM1
+      IF(VC(i,j1).GT.0.) then
+      flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) +
+     &                         A6(i,j11)*(1.-R23*VC(i,j1)) )
+      else
+      flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) +
+     &                        A6(i,j1)*(1.+R23*VC(i,j1)))
+      endif
+140   continue
+      return
+      end
+C
+	subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
+	REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
+        REAL WK(IMR,-1:JNP+2)
+C
+	JMR = JNP-1
+	IMH = IMR/2
+	do j=1,JNP
+	do i=1,IMR
+	wk(i,j) = p(i,j)
+	enddo
+	enddo
+C Poles:
+	do i=1,IMH
+	wk(i,   -1) = p(i+IMH,3)
+	wk(i+IMH,-1) = p(i,3)
+	wk(i,    0) = p(i+IMH,2)
+	wk(i+IMH,0) = p(i,2)
+	wk(i,JNP+1) = p(i+IMH,JMR)
+	wk(i+IMH,JNP+1) = p(i,JMR)
+	wk(i,JNP+2) = p(i+IMH,JNP-2)
+	wk(i+IMH,JNP+2) = p(i,JNP-2)
+	enddo
+c        write(*,*) 'toto 1' 
+C --------------------------------
+      IF(IAD.eq.2) then
+      do j=j1-1,j2+1
+      do i=1,IMR
+c      write(*,*) 'avt NINT','i=',i,'j=',j
+      JP = NINT(VA(i,j))      
+      rv = JP - VA(i,j)
+c      write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv
+      JP = j - JP
+c      write(*,*) 'JP2=',JP
+      a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp)
+      b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1))
+c      write(*,*) 'a1=',a1,'b1=',b1
+      ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j)
+      enddo
+      enddo
+c      write(*,*) 'toto 2'
+C
+      ELSEIF(IAD.eq.1) then
+	do j=j1-1,j2+1
+      do i=1,imr
+      JP = REAL(j)-VA(i,j)
+      ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
+      enddo
+      enddo
+      ENDIF
+C
+	if(j1.ne.2) then
+	sum1 = 0.
+	sum2 = 0.
+      do i=1,imr
+      sum1 = sum1 + ady(i,2)
+      sum2 = sum2 + ady(i,JMR)
+      enddo
+	sum1 = sum1 / IMR
+	sum2 = sum2 / IMR
+C
+      do i=1,imr
+      ady(i,  2) =  sum1
+      ady(i,JMR) =  sum2
+      ady(i,  1) =  sum1
+      ady(i,JNP) =  sum2
+      enddo
+	else
+C Poles:
+	sum1 = 0.
+	sum2 = 0.
+      do i=1,imr
+      sum1 = sum1 + ady(i,1)
+      sum2 = sum2 + ady(i,JNP)
+      enddo
+	sum1 = sum1 / IMR
+	sum2 = sum2 / IMR
+C
+      do i=1,imr
+      ady(i,  1) =  sum1
+      ady(i,JNP) =  sum2
+      enddo
+	endif
+C
+	return
+	end
+C
+	subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD)
+	REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
+C
+	JMR = JNP-1
+      do 1309 j=j1,j2
+      if(J.GT.JS  .and. J.LT.JN) GO TO 1309
+C
+      do i=1,IMR
+      qtmp(i) = p(i,j)
+      enddo
+C
+      do i=-IML,0
+      qtmp(i)       = p(IMR+i,j)
+      qtmp(IMR+1-i) = p(1-i,j)
+      enddo
+C
+      IF(IAD.eq.2) THEN
+      DO i=1,IMR
+      IP = NINT(UA(i,j))
+      ru = IP - UA(i,j)
+      IP = i - IP
+      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+      adx(i,j) = qtmp(ip) + ru*(a1*ru + b1)
+      enddo
+      ELSEIF(IAD.eq.1) then
+      DO i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.0.) then
+      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+      else
+      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+      endif
+      enddo
+      ENDIF
+C
+      do i=1,IMR
+      adx(i,j) = adx(i,j) - p(i,j)
+      enddo
+1309  continue
+C
+C Eulerian upwind
+C
+      do j=JS+1,JN-1
+C
+      do i=1,IMR
+      qtmp(i) = p(i,j)
+      enddo
+C
+      qtmp(0)     = p(IMR,J)
+      qtmp(IMR+1) = p(1,J)
+C
+      IF(IAD.eq.2) THEN
+      qtmp(-1)     = p(IMR-1,J)
+      qtmp(IMR+2) = p(2,J)
+      do i=1,imr
+      IP = NINT(UA(i,j))
+      ru = IP - UA(i,j)
+      IP = i - IP
+      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+      adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1)
+      enddo
+      ELSEIF(IAD.eq.1) then
+C 1st order
+      DO i=1,IMR
+      IP = i - UA(i,j)
+      adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1))
+      enddo
+      ENDIF
+      enddo
+C
+	if(j1.ne.2) then
+      do i=1,IMR
+      adx(i,  2) = 0.
+      adx(i,JMR) = 0.
+      enddo
+	endif
+C set cross term due to x-adv at the poles to zero.
+      do i=1,IMR
+      adx(i,  1) = 0.
+      adx(i,JNP) = 0.
+      enddo
+	return
+	end
+C
+      subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT)
+C
+C A6 =  CURVATURE OF THE TEST PARABOLA
+C AR =  RIGHT EDGE VALUE OF THE TEST PARABOLA
+C AL =  LEFT  EDGE VALUE OF THE TEST PARABOLA
+C DC =  0.5 * MISMATCH
+C P  =  CELL-AVERAGED VALUE
+C IM =  VECTOR LENGTH
+C
+C OPTIONS:
+C
+C LMT = 0: FULL MONOTONICITY
+C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS)
+C LMT = 2: POSITIVE-DEFINITE CONSTRAINT
+C
+      parameter ( R12 = 1./12. )
+      dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+C
+      if(LMT.eq.0) then
+C Full constraint
+      do 100 i=1,IM
+      if(DC(i).eq.0.) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      else
+      da1  = AR(i) - AL(i)
+      da2  = da1**2
+      A6DA = A6(i)*da1
+      if(A6DA .lt. -da2) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      elseif(A6DA .gt. da2) then
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+      endif
+100   continue
+      elseif(LMT.eq.1) then
+C Semi-monotonic constraint
+      do 150 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. AL(i)) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      else
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+150   continue
+      elseif(LMT.eq.2) then
+      do 250 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250
+      fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
+      if(fmin.ge.0.) go to 250
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. AL(i)) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      else
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+250   continue
+      endif
+      return
+      end
+C
+      subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*)
+C
+      do 35 j=j1,j2
+      do 35 i=2,IMR
+35    CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
+C
+      do 45 j=j1,j2
+45    CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
+      return
+      end
+C
+      subroutine cosa(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+      JMR = JNP-1
+      do 55 j=2,JNP
+        ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
+55      cose(j) = cos(ph5)
+C
+      JEQ = (JNP+1) / 2
+      if(JMR .eq. 2*(JMR/2) ) then
+      do j=JNP, JEQ+1, -1
+       cose(j) =  cose(JNP+2-j)
+      enddo
+      else
+C cell edge at equator.
+       cose(JEQ+1) =  1.
+      do j=JNP, JEQ+2, -1
+       cose(j) =  cose(JNP+2-j)
+       enddo
+      endif
+C
+      do 66 j=2,JMR
+66    cosp(j) = 0.5*(cose(j)+cose(j+1))
+      cosp(1) = 0.
+      cosp(JNP) = 0.
+      return
+      end
+C
+      subroutine cosc(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+C
+      phi = -0.5*PI
+      do 55 j=2,JNP-1
+      phi  =  phi + DP
+55    cosp(j) = cos(phi)
+        cosp(  1) = 0.
+        cosp(JNP) = 0.
+C
+      do 66 j=2,JNP
+        cose(j) = 0.5*(cosp(j)+cosp(j-1))
+66    CONTINUE
+C
+      do 77 j=2,JNP-1
+       cosp(j) = 0.5*(cose(j)+cose(j+1))
+77    CONTINUE
+      return
+      end
+C
+      SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp,
+     &                   cross,IC,NSTEP)
+C
+      parameter( tiny = 1.E-60 )
+      DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
+      logical cross
+C
+      NLAYM1 = NLAY-1
+      len = IMR*(j2-j1+1)
+      ip = 0
+C
+C Top layer
+      L = 1
+	icr = 1
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 50
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 50
+C
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 50
+C
+C Vertical filling...
+      do i=1,len
+      IF( Q(i,j1,1).LT.0.) THEN
+      ip = ip + 1
+          Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1)
+          Q(i,j1,1) = 0.
+      endif
+      enddo
+C
+50    continue
+      DO 225 L = 2,NLAYM1
+      icr = 1
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 225
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) go to 225
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 225
+C
+      do i=1,len
+      IF( Q(I,j1,L).LT.0.) THEN
+C
+      ip = ip + 1
+C From above
+          qup =  Q(I,j1,L-1)
+          qly = -Q(I,j1,L)
+          dup  = min(qly,qup)
+          Q(I,j1,L-1) = qup - dup
+          Q(I,j1,L  ) = dup-qly
+C Below
+          Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L)
+          Q(I,j1,L)   = 0.
+      ENDIF
+      ENDDO
+225   CONTINUE
+C
+C BOTTOM LAYER
+      sum = 0.
+      L = NLAY
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 911
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 911
+C
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      if(icr.eq.0) goto 911
+C
+      DO  I=1,len
+      IF( Q(I,j1,L).LT.0.) THEN
+      ip = ip + 1
+c
+C From above
+C
+          qup = Q(I,j1,NLAYM1)
+          qly = -Q(I,j1,L)
+          dup = min(qly,qup)
+          Q(I,j1,NLAYM1) = qup - dup
+C From "below" the surface.
+          sum = sum + qly-dup
+          Q(I,j1,L) = 0.
+       ENDIF
+      ENDDO
+C
+911   continue
+C
+      if(ip.gt.IMR) then
+      write(6,*) 'IC=',IC,' STEP=',NSTEP,
+     &           ' Vertical filling pts=',ip
+      endif
+C
+      if(sum.gt.1.e-25) then
+      write(6,*) IC,NSTEP,' Mass source from the ground=',sum
+      endif
+      RETURN
+      END
+C
+      subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+      icr = 0
+      do 65 j=j1+1,j2-1
+      DO 50 i=1,IMR-1
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-E
+      dn = q(i+1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i+1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-E
+      ds = q(i+1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i+1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+50    continue
+      if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65
+      DO 55 i=2,IMR
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-W
+      dn = q(i-1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i-1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-W
+      ds = q(i-1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i-1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+55    continue
+C *****************************************
+C i=1
+      i=1
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-W
+      dn = q(IMR,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(IMR,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-W
+      ds = q(IMR,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(IMR,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+C *****************************************
+C i=IMR
+      i=IMR
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-E
+      dn = q(1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-E
+      ds = q(1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+C *****************************************
+65    continue
+C
+      do i=1,IMR
+      if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then
+      icr = 1
+      goto 80
+      endif
+      enddo
+C
+80    continue
+C
+      if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then
+      icr = 1
+      endif
+C
+      return
+      end
+C
+      subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+c      logical first
+c      data first /.true./
+c      save cap1
+C
+c      if(first) then
+      DP = 4.*ATAN(1.)/REAL(JNP-1)
+      CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
+c      first = .false.
+c      endif
+C
+      ipy = 0
+      do 55 j=j1+1,j2-1
+      DO 55 i=1,IMR
+      IF(q(i,j).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j)*cosp(j)
+C North
+      dn = q(i,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C South
+      ds = q(i,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+55    continue
+C
+      do i=1,imr
+      IF(q(i,j1).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j1)*cosp(j1)
+C North
+      dn = q(i,j1+1)*cosp(j1+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i,j1+1) = (dn - d1)*acosp(j1+1)
+      q(i,j1) = (d1 - dq)*acosp(j1) + tiny
+      endif
+      enddo
+C
+      j = j2
+      do i=1,imr
+      IF(q(i,j).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j)*cosp(j)
+C South
+      ds = q(i,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+      enddo
+C
+C Check Poles.
+      if(q(1,1).lt.0.) then
+      dq = q(1,1)*cap1/REAL(IMR)*acosp(j1)
+      do i=1,imr
+      q(i,1) = 0.
+      q(i,j1) = q(i,j1) + dq
+      if(q(i,j1).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      if(q(1,JNP).lt.0.) then
+      dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2)
+      do i=1,imr
+      q(i,JNP) = 0.
+      q(i,j2) = q(i,j2) + dq
+      if(q(i,j2).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      dimension q(IMR,*),qtmp(JNP,IMR)
+C
+      ipx = 0
+C Copy & swap direction for vectorization.
+      do 25 i=1,imr
+      do 25 j=j1,j2
+25    qtmp(j,i) = q(i,j)
+C
+      do 55 i=2,imr-1
+      do 55 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,i-1))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,i-1) = qtmp(j,i-1) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,i+1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,i+1) = qtmp(j,i+1) - d2
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+55    continue
+c
+      i=1
+      do 65 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,imr))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,imr) = qtmp(j,imr) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,i+1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,i+1) = qtmp(j,i+1) - d2
+c
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+65    continue
+      i=IMR
+      do 75 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,i-1))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,i-1) = qtmp(j,i-1) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,1) = qtmp(j,1) - d2
+c
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+75    continue
+C
+      if(ipx.ne.0) then
+      do 85 j=j1,j2
+      do 85 i=1,imr
+85    q(i,j) = qtmp(j,i)
+      else
+C
+C Poles.
+      if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1
+      endif
+      return
+      end
+C
+      subroutine zflip(q,im,km,nc)
+C This routine flip the array q (in the vertical).
+      real q(im,km,nc)
+C local dynamic array
+      real qtmp(im,km)
+C
+      do 4000 IC = 1, nc
+C
+      do 1000 k=1,km
+      do 1000 i=1,im
+      qtmp(i,k) = q(i,km+1-k,IC)
+1000  continue
+C
+      do 2000 i=1,im*km
+2000  q(i,1,IC) = qtmp(i,1)
+4000  continue
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/prather.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/prather.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/prather.F	(revision 222)
@@ -0,0 +1,361 @@
+!
+! $Header$
+!
+      SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
+      IMPLICIT NONE
+
+c=======================================================================
+c   Adaptation LMDZ:  A.Armengaud (LGGE)
+c   ----------------
+c
+c   ************************************************
+c   Transport des traceurs par la methode de prather
+c   Ref : 
+c
+c   ************************************************
+c   q,w,pext,pbaru et pbarv : arguments d'entree  pour le s-pg
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iq,nt
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL masse(iip1,jjp1,llm)
+      REAL q( iip1,jjp1,llm,0:9)
+      REAL w( ip1jmp1,llm )
+      integer ordre,ilim
+
+c   Local:
+c   ------
+      LOGICAL limit
+      real zq(iip1,jjp1,llm)
+      REAL sm ( iip1,jjp1, llm )
+      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+      REAL sxx( iip1,jjp1,llm)
+      REAL sxy( iip1,jjp1,llm)
+      REAL sxz( iip1,jjp1,llm)
+      REAL syy( iip1,jjp1,llm )
+      REAL syz( iip1,jjp1,llm )
+      REAL szz( iip1,jjp1,llm ),zz
+      INTEGER i,j,l,indice
+      real sxn(iip1),sxs(iip1)
+
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      real qmin,qmax
+      save qmin,qmax
+      save sinlon,coslon,sinlondlon,coslondlon
+      real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps
+      real masn,mass
+c
+      REAL      SSUM
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      logical first
+      save first
+      EXTERNAL advxp,advyp,advzp 
+
+
+      data first/.true./
+      data qmin,qmax/-1.e33,1.e33/
+
+
+c==========================================================================
+c==========================================================================
+c     MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt
+c==========================================================================
+c==========================================================================
+      REAL dt
+c==========================================================================
+      limit = .TRUE.
+ 
+      if(first) then
+         print*,'SCHEMA PRATHER'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+
+        DO l = 1,llm
+        DO j = 1,jjp1
+        DO i = 1,iip1
+        q( i,j,l,1 )=0.
+        q( i,j,l,2)=0.
+        q( i,j,l,3)=0.
+        q( i,j,l,4)=0.
+        q( i,j,l,5)=0.
+        q( i,j,l,6)=0.
+        q( i,j,l,7)=0.
+        q( i,j,l,8)=0.
+        q( i,j,l,9)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      endif
+c   Fin modif Fred
+
+c *** On calcule la masse d'air en kg
+
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+         sm( i,j,llm+1-l ) =masse(i,j,l)
+         ENDDO
+        ENDDO
+       ENDDO
+
+c *** q contient les qqtes de traceur avant l'advection 
+
+c *** Affectation des tableaux S a partir de Q
+ 
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+       s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l)
+       sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l)
+       sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l)
+       sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l)
+       sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l)
+       sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l)
+       sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l)
+       syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l)
+       syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l)
+       szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l)
+         ENDDO
+        ENDDO
+       ENDDO
+c *** Appel des subroutines d'advection en X, en Y et en Z
+c *** Advection avec "time-splitting"
+      
+c-----------------------------------------------------------
+       do indice =1,nt
+       call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        end do
+        do l=1,llm
+        do i=1,iip1
+        sy(i,1,l)=0.
+        sy(i,jjp1,l)=0.
+        enddo
+        enddo
+c---------------------------------------------------------
+       call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+c---------------------------------------------------------
+
+c---------------------------------------------------------
+       do j=1,jjp1
+          do i=1,iip1
+             sz(i,j,1)=0.
+             sz(i,j,llm)=0.
+             sxz(i,j,1)=0.
+             sxz(i,j,llm)=0.
+             syz(i,j,1)=0.
+             syz(i,j,llm)=0.
+             szz(i,j,1)=0.
+             szz(i,j,llm)=0.
+          enddo
+       enddo
+       call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz 
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        do l=1,llm
+        do i=1,iip1
+        sy(i,1,l)=0.
+        sy(i,jjp1,l)=0.
+        enddo
+        enddo
+
+c---------------------------------------------------------
+
+c---------------------------------------------------------
+       call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+c---------------------------------------------------------
+       DO l = 1,llm
+        DO j = 1,jjp1
+             s0( iip1,j,l)=s0( 1,j,l )
+             sx( iip1,j,l)=sx( 1,j,l )
+             sy( iip1,j,l)=sy( 1,j,l )
+             sz( iip1,j,l)=sz( 1,j,l )
+             sxx( iip1,j,l)=sxx( 1,j,l )
+             sxy( iip1,j,l)=sxy( 1,j,l) 
+             sxz( iip1,j,l)=sxz( 1,j,l )
+             syy( iip1,j,l)=syy( 1,j,l )
+             syz( iip1,j,l)=syz( 1,j,l)
+             szz( iip1,j,l)=szz( 1,j,l )
+        ENDDO
+       ENDDO
+       do indice=1,nt
+       call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        end do
+c---------------------------------------------------------
+c---------------------------------------------------------
+c ***   On repasse les S dans la variable qpr
+c ***   On repasse les S dans la variable q directement 14/10/94
+
+       DO  l = 1,llm
+        DO  j = 1,jjp1
+         DO  i = 1,iip1
+      q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l)
+      ENDDO
+      ENDDO
+      ENDDO
+
+c---------------------------------------------------------
+c      go to  777
+c   filtrages aux poles
+
+c Traitements specifiques au pole
+
+c   filtrages aux poles
+         DO l=1,llm
+c   filtrages aux poles
+         masn=ssum(iim,sm(1,1,l),1)
+         mass=ssum(iim,sm(1,jjp1,l),1)
+         qpn=ssum(iim,s0(1,1,l),1)/masn
+         qps=ssum(iim,s0(1,jjp1,l),1)/mass
+         dqzpn=ssum(iim,sz(1,1,l),1)/masn
+         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+         do i=1,iip1
+          q( i,1,llm+1-l,3)=dqzpn
+          q( i,jjp1,llm+1-l,3)=dqzps
+          q( i,1,llm+1-l,0)=qpn
+          q( i,jjp1,llm+1-l,0)=qps
+         enddo
+c       enddo
+c         print*,'qpn',qpn,'qps',qps
+c          print*,'dqzpn',dqzpn,'dqzps',dqzps
+c       enddo
+           dyn1=0.
+           dys1=0.
+           dyn2=0.
+           dys2=0.
+        do i=1,iim
+        zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+        dyn1=dyn1+sinlondlon(i)*zz
+        dyn2=dyn2+coslondlon(i)*zz
+        zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+        dys1=dys1+sinlondlon(i)*zz
+        dys2=dys2+coslondlon(i)*zz
+        enddo
+         do i=1,iim
+         q(i,1,llm+1-l,2)=
+     $   (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+         q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)
+     $          +q(i,1,llm+1-l,2)
+         q(i,jjp1,llm+1-l,2)=
+     $   (sinlon(i)*dys1+coslon(i)*dys2)/2.
+         q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     $      -q(i,jjp1,llm+1-l,2)
+         enddo
+      q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+      q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+      do i=1,iim
+      sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+      sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+      enddo
+      sxn(iip1)=sxn(1)
+      sxs(iip1)=sxs(1)
+      do i=1,iim
+      q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+      q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+      END DO
+      q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+      q(1,jjp1,llm+1-l,1)=
+     $   q(iip1,jjp1,llm+1-l,1)
+        enddo
+         do l=1,llm
+           do i=1,iim
+            q( i,1,llm+1-l,4)=0.
+            q( i,jjp1,llm+1-l,4)=0.
+            q( i,1,llm+1-l,5)=0.
+            q( i,jjp1,llm+1-l,5)=0.
+            q( i,1,llm+1-l,6)=0.
+            q( i,jjp1,llm+1-l,6)=0.
+            q( i,1,llm+1-l,7)=0.
+            q( i,jjp1,llm+1-l,7)=0.
+            q( i,1,llm+1-l,8)=0.
+            q( i,jjp1,llm+1-l,8)=0.
+            q( i,1,llm+1-l,9)=0.
+            q( i,jjp1,llm+1-l,9)=0.
+          enddo
+         ENDDO
+
+777      continue
+c
+c   bouclage en longitude
+      do l=1,llm
+      do j=1,jjp1
+      q(iip1,j,l,0)=q(1,j,l,0)
+      q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0)
+      q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1)
+      q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2)
+      q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3)
+      q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4)
+      q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5)
+      q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6)
+      q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7)
+      q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8)
+      q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9)
+      enddo
+      enddo
+        DO l = 1,llm
+    	 DO j = 2,jjm
+           DO i = 1,iip1
+         IF (q(i,j,l,0).lt.0.)  THEN
+         PRINT*,'------------ BIP-----------' 
+         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0),
+     $          q(i,j-1,l,0)
+         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2),
+     $   q(i,j-1,l,2)   
+         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+c    		     PRINT*,' PBL EN SORTIE D'' ADVZP'
+                     q(i,j,l,0)=0.
+c                  STOP
+               ENDIF
+           ENDDO
+         ENDDO
+         do j=1,jjp1,jjm
+         do i=1,iip1
+               IF (q(i,j,l,0).lt.0.)  THEN
+               PRINT*,'------------ BIP 2-----------'
+         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0)
+         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2)
+         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+
+                     q(i,j,l,0)=0.
+c                  STOP
+               ENDIF
+         enddo
+         enddo
+        ENDDO
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pression.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pression.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/pression.F	(revision 222)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+      SUBROUTINE pression( ngrid, ap, bp, ps, p )
+c
+
+c      Auteurs : P. Le Van , Fr.Hourdin  .
+
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+      INTEGER ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      DO    l    = 1, llmp1
+        DO  ij   = 1, ngrid
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+   
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/psextbar.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/psextbar.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/psextbar.F	(revision 222)
@@ -0,0 +1,107 @@
+!
+! $Header$
+!
+      SUBROUTINE psextbar ( ps, psexbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c **********************************************************************
+c
+c         ps          est un  argum. d'entree  pour le s-pg ..
+c         psexbarxy   est un  argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )
+
+      INTEGER  l, ij
+c
+
+      DO ij = 1, ip1jmp1
+       pext(ij) = ps(ij) * aire(ij)
+      ENDDO
+
+
+      DO     5     ij = 1, ip1jm - 1
+      psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     psexbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      psexbarxy( ij ) = psexbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/q_sat.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/q_sat.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/q_sat.F	(revision 222)
@@ -0,0 +1,73 @@
+!
+! $Header$
+!
+!
+!
+
+      subroutine q_sat(np,temp,pres,qsat)
+!
+      IMPLICIT none
+!======================================================================
+! Autheur(s): Z.X. Li (LMD/CNRS)
+!  reecriture vectorisee par F. Hourdin.
+! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+!======================================================================
+! Arguments:
+! kelvin---input-R: temperature en Kelvin
+! millibar--input-R: pression en mb
+!
+! q_sat----output-R: vapeur d'eau saturante en kg/kg
+!======================================================================
+!
+      integer np
+      REAL temp(np),pres(np),qsat(np)
+!
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+!
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+!
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+!
+      REAL rtt
+      PARAMETER (rtt=273.16)
+!
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+
+      real zqsat
+      integer ip
+!
+!     ------------------------------------------------------------------
+!
+!
+
+      do ip=1,np
+
+!      write(*,*)'kelvin,millibar=',kelvin,millibar
+!       write(*,*)'temp,pres=',temp(ip),pres(ip)
+!
+         IF (temp(ip) .LE. rtt) THEN
+            r3es = r3ies
+            r4es = r4ies
+         ELSE
+            r3es = r3les
+            r4es = r4les
+         ENDIF
+!
+         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+         zqsat=MIN(0.5,ZQSAT)
+         zqsat=zqsat/(1.-retv *zqsat)
+!
+         qsat(ip)= zqsat
+!      write(*,*)'qsat=',qsat(ip)
+
+      enddo
+!
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ran1.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ran1.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ran1.F	(revision 222)
@@ -0,0 +1,34 @@
+!
+! $Id: ran1.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      FUNCTION RAN1(IDUM)
+      DIMENSION R(97)
+      save r
+      save iff,ix1,ix2,ix3
+      PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6)
+      PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6)
+      PARAMETER (M3=243000,IA3=4561,IC3=51349)
+      DATA IFF /0/
+      IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
+        IFF=1
+        IX1=MOD(IC1-IDUM,M1)
+        IX1=MOD(IA1*IX1+IC1,M1)
+        IX2=MOD(IX1,M2)
+        IX1=MOD(IA1*IX1+IC1,M1)
+        IX3=MOD(IX1,M3)
+        DO 11 J=1,97
+          IX1=MOD(IA1*IX1+IC1,M1)
+          IX2=MOD(IA2*IX2+IC2,M2)
+          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+11      CONTINUE
+        IDUM=1
+      ENDIF
+      IX1=MOD(IA1*IX1+IC1,M1)
+      IX2=MOD(IA2*IX2+IC2,M2)
+      IX3=MOD(IA3*IX3+IC3,M3)
+      J=1+(97*IX3)/M3
+      IF(J.GT.97.OR.J.LT.1) stop 1
+      RAN1=R(J)
+      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/relaxetat0.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/relaxetat0.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/relaxetat0.F	(revision 222)
@@ -0,0 +1,68 @@
+      SUBROUTINE relaxetat0(fichnom)
+
+      use netcdf, only: nf90_get_var
+      use comuforc_h
+      use ioipsl_getincom
+
+      IMPLICIT NONE
+
+!=======================================================================
+! Author: A. Spiga
+! Purpose: Read a simple relaxation field
+!=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "netcdf.inc"
+#include "iniprint.h"
+
+! INPUTS
+      CHARACTER*(*) fichnom
+
+! VARIABLES
+      REAL ucov(iip1, jjp1,llm)
+      INTEGER ierr, nid, nvarid
+      INTEGER i,j,l,ij
+
+      !! OPEN NETCDF FILE
+      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(lunout,*)'relaxetat0: Pb d''ouverture du fichier'
+        write(lunout,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+      !! ALLOCATE RELAXATION FIELD
+      IF (.NOT.ALLOCATED(uforc)) ALLOCATE(uforc(ip1jmp1,llm))
+
+      !! READ RELAXATION FIELD
+      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         write(lunout,*)"dynetat0: Le champ <ucov> est absent"
+         CALL abort
+      ENDIF
+      ierr = nf90_get_var(nid, nvarid, ucov) 
+      IF (ierr .NE. NF_NOERR) THEN
+         write(lunout,*)"dynetat0: Lecture echouee pour <ucov>"
+         CALL abort
+      ENDIF
+
+      !! TRANSFER TO SHARED VARIABLE IN comuforc_h MODULE
+      !! TBD --> check the relaxation field's dimensions are OK!
+      do l=1,llm
+        do j=1,jjp1
+           do i=1,iip1
+              ij=(j-1)*iip1+i
+              uforc(ij,l)=ucov(i,j,l)
+           enddo
+        enddo
+      enddo
+
+      !! READ THE RELAXATION RATE IN SETTINGS
+      facwind = 1000.
+      CALL getin('facwind',facwind)
+
+      !! END
+      ierr = NF_CLOSE(nid)
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotat.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotat.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotat.F	(revision 222)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE rotat (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotat_nfil.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotat_nfil.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotat_nfil.F	(revision 222)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      SUBROUTINE rotat_nfil (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van 
+c**************************************************************
+c.          Calcule le rotationnel  non filtre   ,
+c      a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotatf.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotatf.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotatf.F	(revision 222)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE rotatf (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotatst.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotatst.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/rotatst.F	(revision 222)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE rotatst (klevel,x, y, rot )
+c
+c  P. Le Van
+c
+c    *****************************************************************
+c     .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y ..
+c         x  et  y etant des composantes  covariantes  .....
+c    *****************************************************************
+c        x  et y     sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+      INTEGER klevel
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+      INTEGER  l, ij
+c
+c
+      DO 5 l = 1,klevel
+c
+      DO 1 ij = 1, ip1jm - 1
+      rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   +
+     *                 x(ij +iip1, l )  -  x( ij,l )  )
+   1  CONTINUE
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim,l )
+   2  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/serre.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/serre.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/serre.h	(revision 222)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!c
+!c
+!c..include serre.h
+!c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
+     &  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo ,     &
+     &  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sort.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sort.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sort.F	(revision 222)
@@ -0,0 +1,37 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE sort(n,d)
+c
+c     P.Le Van
+c      
+c...  cette routine met le tableau d  dans l'ordre croissant  ....
+cc   ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc
+c      tion  situee + bas  IF(d(j).LE.p)  THEN     par
+c                           IF(d(j).GE.p)  THEN
+c
+
+      INTEGER n
+      REAL d(n) , p
+      INTEGER i,j,k
+
+      DO i=1,n-1
+        k=i
+        p=d(i)
+        DO j=i+1,n
+         IF(d(j).LE.p) THEN
+           k=j
+           p=d(j)
+         ENDIF
+        ENDDO
+
+       IF(k.ne.i) THEN
+         d(k)=d(i)
+         d(i)=p
+       ENDIF
+      ENDDO
+
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sortvarc.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sortvarc.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sortvarc.F	(revision 222)
@@ -0,0 +1,199 @@
+!
+! $Id: sortvarc.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE sortvarc
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov )
+
+      use control_mod,only:resetvarc 
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+
+      logical  firstcal
+      data     firstcal/.true./
+      save     firstcal
+
+c-----------------------------------------------------------------------
+! Ehouarn: when no initialization fields from file, resetvarc should be
+!          set to false
+       if (firstcal) then
+         if (.not.read_start) then
+           resetvarc=.true.
+         endif
+       endif
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = REAL( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       ge(:)=dp(:)*dp(:)
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = rad *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot  = SSUM(     llm, etotl, 1 )
+      ztot  = SSUM(     llm, ztotl, 1 )
+      stot  = SSUM(     llm, stotl, 1 )
+      rmsv  = SSUM(     llm, rmsvl, 1 )
+      ang   = SSUM(     llm,  angl, 1 )
+
+      IF (firstcal.and.resetvarc) then
+         PRINT 3500, itau, rjour, heure,time
+         PRINT*,'WARNING!!! On recalcule les valeurs initiales de :'
+         PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
+         PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+         etot0 = etot
+         ptot0 = ptot
+         ztot0 = ztot
+         stot0 = stot
+         ang0  = ang
+      END IF
+
+      ! compute relative changes in etot,... (except if 'reference' values
+      ! are zero, which can happen when using iniacademic)
+      if (etot0.ne.0) then
+        etot= etot/etot0
+      else
+        etot=1.
+      endif
+      rmsv= SQRT(rmsv/ptot)
+      if (ptot0.ne.0) then
+        ptot= ptot/ptot0
+      else
+        ptot=1.
+      endif
+      if (ztot0.ne.0) then
+        ztot= ztot/ztot0
+      else
+        ztot=1.
+      endif
+      if (stot0.ne.0) then
+        stot= stot/stot0
+      else
+        stot=1.
+      endif
+      if (ang0.ne.0) then
+        ang = ang /ang0
+      else
+        ang=1.
+      endif
+
+      firstcal = .false.
+
+      PRINT 3500, itau, rjour, heure, time
+      PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+
+      RETURN
+
+3500   FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x 
+     *   ,'date',f14.4,4x,10("*"))
+4000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie'
+     * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB  '
+     .  ,f10.6,e13.6,5f10.3/
+     * )
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sortvarc0.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sortvarc0.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/sortvarc0.F	(revision 222)
@@ -0,0 +1,141 @@
+!
+! $Id: sortvarc0.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+      integer  ismin,ismax
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = REAL( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       ge=dp*dp
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = rad *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot0  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot0  = SSUM(     llm, etotl, 1 )
+      ztot0  = SSUM(     llm, ztotl, 1 )
+      stot0  = SSUM(     llm, stotl, 1 )
+      rmsv   = SSUM(     llm, rmsvl, 1 )
+      ang0   = SSUM(     llm,  angl, 1 )
+
+      rday = REAL(INT (time ))
+c
+      PRINT 3500, itau, rday, heure, time
+      PRINT *, ptot0,etot0,ztot0,stot0,ang0
+
+3500   FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x 
+     *   ,'date',f10.5,4x,10("*"))
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/temps.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/temps.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/temps.h	(revision 222)
@@ -0,0 +1,34 @@
+!
+! $Id: temps.h 1577 2011-10-20 15:06:47Z fairhead $
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! jD_ref = jour julien de la date de reference (lancement de l'experience)
+! hD_ref = "heure" julienne de la date de reference
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps_r/dt,jD_ref,jH_ref,start_time,hour_ini
+      COMMON/temps_i/day_ini,day_end,annee_ref,day_ref,                 &
+     &             itau_dyn,itau_phy,itaufin
+      COMMON/temps_c/calend
+
+
+      INTEGER   itaufin ! total number of dynamical steps for the run
+      INTEGER   itau_dyn, itau_phy
+      INTEGER   day_ini ! initial day # of simulation sequence
+      INTEGER   day_end ! final day # ; i.e. day # when this simulation ends
+      INTEGER   annee_ref
+      INTEGER   day_ref
+      REAL      dt ! (dynamics) time step (changes if doing Matsuno or LF step)
+      REAL      jD_ref, jH_ref, start_time
+      CHARACTER (len=10) :: calend
+
+      ! Additionnal Mars stuff:
+      real hour_ini ! initial fraction of day of simulation sequence (0=<hour_ini<1)
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/test_period.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/test_period.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/test_period.F	(revision 222)
@@ -0,0 +1,115 @@
+!
+! $Header$
+!
+      SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
+c
+c     Auteur : P. Le Van  
+c    ---------
+c  ....  Cette routine teste la periodicite en longitude des champs   ucov,
+c                           teta, q , p et phis                 .......... 
+c
+      USE infotrac
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+c    ......  Arguments   ......
+c
+      REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) ,
+     ,      q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1)
+c
+c   .....  Variables  locales  .....
+c
+      INTEGER ij,l,nq
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( ucov(ij,l).NE.ucov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  UCOV  ---  n est pas',  
+     ,  ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( teta(ij,l).NE.teta(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,   ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+     ,      , teta(ij,l),   teta(ij+iim,l)
+          STOP
+          ENDIF
+         ENDDO
+
+         do ij=1,iim
+          if (teta(ij,l).ne.teta(1,l)
+     s     .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,  ' constant aux poles ! '
+          print*,'teta(',1 ,',',l,')=',teta(1 ,l)
+          print*,'teta(',ij,',',l,')=',teta(ij,l)
+          print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l)
+          print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l)
+          stop
+          endif
+         enddo
+      ENDDO
+
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jm, iip1
+          IF( vcov(ij,l).NE.vcov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  VCOV  ---  n est pas',  
+     ,   ' periodique en longitude !'
+          PRINT *,' l,  ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l)
+          vcov(ij+iim,l)=vcov(ij,l)
+c         STOP
+          ENDIF
+         ENDDO
+      ENDDO
+      
+c
+      DO nq =1, nqtot
+        DO l =1, llm
+          DO ij = 1, ip1jmp1, iip1
+          IF( q(ij,l,nq).NE.q(ij+iim,l,nq) )  THEN
+          PRINT *,'STOP dans test_period car ---  Q  ---  n est pas ',  
+     ,   'periodique en longitude !'
+          PRINT *,' nq , l,  ij = ', nq, l, ij, ij+iim
+          STOP
+          ENDIF
+          ENDDO
+        ENDDO
+      ENDDO
+c
+       DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( p(ij,l).NE.p(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  P  ---  n est pas',  
+     ,    ' periodique en longitude !'
+          PRINT *,' l ij = ',l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( phis(ij).NE.phis(ij+iim) )  THEN
+          PRINT *,'STOP dans test_period car ---  PHIS  ---  n est pas',  
+     ,   ' periodique en longitude !  l, IJ = ', l, ij,ij+iim
+          PRINT *,' ij = ', ij, ij+iim
+          STOP
+          ENDIF
+         ENDDO
+         do ij=1,iim
+          if (p(ij,l).ne.p(1,l)
+     s     .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then
+          PRINT *,'STOP dans test_period car ---  P     ---  n est pas',  
+     ,  ' constant aux poles ! '
+          print*,'p(',1 ,',',l,')=',p(1 ,l)
+          print*,'p(',ij,',',l,')=',p(ij,l)
+          print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l)
+          print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l)
+          stop
+          endif
+         enddo
+       ENDDO
+c
+c
+         RETURN
+         END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tidal_forces.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tidal_forces.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tidal_forces.F	(revision 222)
@@ -0,0 +1,109 @@
+      SUBROUTINE tidal_forces (t, du, dv)
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Auteur:  B. Charnay  (10/2010)
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *****************************************************************
+c   ..... calcul du gradient horizontal du potentiel gravitationnel du aux forces de marees causees par Saturne
+c   ..... Formule tiree de Tokano 2002
+c   *****************************************************************
+c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+c
+c
+c    du et dv          sont des arguments de sortie pour le s-pg  ....
+c
+c=======================================================================
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+!#include "comorbit.h"
+      REAL t        ! jour de l'annee
+      REAL du( ip1jmp1,llm ),  dv( ip1jm,llm )
+
+c     variables locales
+      REAL Vo
+      PARAMETER (Vo=-4.691e-6)
+      INTEGER  l,ij,i,k
+      REAL n                ! 2pi/periode de rotation siderale (en jours)
+      REAL a0               ! angle Ã  l'instant initial entre Titan et le perihelie
+      PARAMETER (a0=0.)      
+
+c     cos et sin de la latitude et longitude, calcules au premiers appel
+      REAL coslonv(ip1jm),sinlonv(ip1jm)
+      REAL sinlatv(ip1jm),coslatv(ip1jm)
+      REAL coslonu(ip1jmp1),sinlonu(ip1jmp1)
+      REAL sinlatu(ip1jmp1),coslatu(ip1jmp1)      
+
+      LOGICAl first      
+
+      SAVE coslonv,coslonu,sinlonu,sinlonv
+      SAVE coslatv,coslatu,sinlatu,sinlatv
+      SAVE first, n
+
+      DATA first /.true./
+
+! Calcul des sin et cos aux points consideres
+
+      IF(first) THEN
+         first=.false.
+         n=2*3.145!*(1+1/673.)
+         do i=1,iip1
+          do k=1,jjm
+            coslonv(i+(k-1)*iip1)=cos(rlonv(i))
+            sinlonv(i+(k-1)*iip1)=sin(rlonv(i))
+            coslatv(i+(k-1)*iip1)=cos(rlatv(k))
+            sinlatv(i+(k-1)*iip1)=sin(rlatv(k))
+          ENDDO
+         ENDDO
+
+
+
+         do i=1,iip1
+          do k=1,jjp1
+            coslonu(i+(k-1)*iip1)=cos(rlonu(i))
+            sinlonu(i+(k-1)*iip1)=sin(rlonu(i))
+            coslatu(i+(k-1)*iip1)=cos(rlatu(k))
+            sinlatu(i+(k-1)*iip1)=sin(rlatu(k))
+          ENDDO
+         ENDDO
+
+
+
+      ENDIF
+
+
+! Tendance du aux forces de maree
+
+      DO l = 1,llm
+
+      DO ij  = 1, ip1jmp1 
+
+       du(ij,l) = cu(ij)*Vo
+     $    *(3*sinlonu(ij)*coslonu(ij)*coslatu(ij)*cos(n*t+a0) 
+     $    -2*coslatu(ij)*(2*coslonu(ij)**2-1)*sin(n*t+a0))        
+      ENDDO
+
+      DO ij  = 1, ip1jm 
+       dv(ij,l) = cv(ij)*Vo
+     $    *(3*sinlatv(ij)*coslatv(ij)*coslonv(ij)**2*cos(n*t+a0) 
+     $    + 4*coslatv(ij)*sinlatv(ij)*sinlonv(ij)*coslonv(ij)
+     $    *sin(n*t+a0))      
+      ENDDO
+
+      ENDDO
+
+
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tourpot.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tourpot.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tourpot.F	(revision 222)
@@ -0,0 +1,81 @@
+!
+! $Header$
+!
+      SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ip1jm,llm )
+      REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm )
+      REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm )
+
+      INTEGER l, ij
+
+
+
+
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,llm
+
+      DO 2 ij = 1, ip1jm - 1
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, llm
+
+      DO 6 ij = 1, ip1jm - 1
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/traceurpole.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/traceurpole.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/traceurpole.F	(revision 222)
@@ -0,0 +1,70 @@
+!
+! $Id: traceurpole.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+          subroutine traceurpole(q,masse)
+
+      USE control_mod
+
+          implicit none
+      
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+
+
+c   Arguments
+       integer iq
+       real masse(iip1,jjp1,llm)
+       real q(iip1,jjp1,llm)
+       
+
+c   Locals
+      integer i,j,l
+      real sommemassen(llm)
+      real sommemqn(llm)
+      real sommemasses(llm)
+      real sommemqs(llm)
+      real qpolen(llm),qpoles(llm)
+
+    
+c On impose une seule valeur au pôle Sud j=jjm+1=jjp1       
+      sommemasses=0
+      sommemqs=0
+          do l=1,llm
+             do i=1,iip1          
+                 sommemasses(l)=sommemasses(l)+masse(i,jjp1,l)
+                 sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l)
+             enddo         
+          qpoles(l)=sommemqs(l)/sommemasses(l)
+          enddo
+
+c On impose une seule valeur du traceur au pôle Nord j=1
+      sommemassen=0
+      sommemqn=0  
+         do l=1,llm
+           do i=1,iip1              
+               sommemassen(l)=sommemassen(l)+masse(i,1,l)
+               sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l)
+           enddo
+           qpolen(l)=sommemqn(l)/sommemassen(l) 
+         enddo
+    
+c On force le traceur à prendre cette valeur aux pôles
+        do l=1,llm
+            do i=1,iip1
+               q(i,1,l)=qpolen(l)
+               q(i,jjp1,l)=qpoles(l)
+             enddo
+        enddo
+
+      
+      return
+      end           
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tracstoke.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tracstoke.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/tracstoke.h	(revision 222)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ugeostr.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ugeostr.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/ugeostr.F90	(revision 222)
@@ -0,0 +1,68 @@
+!
+! $Id: ugeostr.F90 1474 2011-01-14 11:04:45Z lguez $
+!
+subroutine ugeostr(phi,ucov)
+
+  ! Calcul du vent covariant geostrophique a partir du champ de
+  ! geopotentiel.
+  ! We actually compute: (1 - cos^8 \phi) u_g
+  ! to have a wind going smoothly to 0 at the equator.
+  ! We assume that the surface pressure is uniform so that model
+  ! levels are pressure levels.
+
+  implicit none
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comconst.h"
+  include "comgeom2.h"
+
+  real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+  real um(jjm,llm),fact,u(iip1,jjm,llm)
+  integer i,j,l
+
+  real zlat
+
+  um(:,:)=0 ! initialize um()
+
+  DO j=1,jjm
+
+     if (abs(sin(rlatv(j))).lt.1.e-4) then
+        zlat=1.e-4
+     else
+        zlat=rlatv(j)
+     endif
+     fact=cos(zlat)
+     fact=fact*fact
+     fact=fact*fact
+     fact=fact*fact
+     fact=(1.-fact)/ &
+          (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j)))
+     fact=-fact/rad
+     DO l=1,llm
+        DO i=1,iim
+           u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
+           um(j,l)=um(j,l)+u(i,j,l)/REAL(iim)
+        ENDDO
+     ENDDO
+  ENDDO
+  call dump2d(jjm,llm,um,'Vent-u geostrophique')
+
+  !   calcul des champ de vent:
+
+  DO l=1,llm
+     DO i=1,iip1
+        ucov(i,1,l)=0.
+        ucov(i,jjp1,l)=0.
+     end DO
+     DO  j=2,jjm
+        DO  i=1,iim
+           ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j)
+        end DO
+        ucov(iip1,j,l)=ucov(1,j,l)
+     end DO
+  end DO
+
+  print *, 301
+
+end subroutine ugeostr
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/vitvert.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/vitvert.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/vitvert.F	(revision 222)
@@ -0,0 +1,52 @@
+!
+! $Header$
+!
+      SUBROUTINE vitvert ( convm , w )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ip1jmp1,llm),convm(ip1jmp1,llm)
+      INTEGER   l, ij
+
+
+
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = 1,ip1jmp1
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+
+      DO 5 ij  = 1,ip1jmp1
+      w(ij,1)  = 0.
+5     CONTINUE
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/write_grads_dyn.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/write_grads_dyn.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3d_common/write_grads_dyn.h	(revision 222)
@@ -0,0 +1,31 @@
+!
+! $Header$
+!
+      if (callinigrads) then
+
+         string10='dyn'
+         call inigrads(1,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtvr*iperiod,string10,'dyn_zon ')
+
+        callinigrads=.false.
+
+
+      endif
+
+      string10='ps'
+      CALL wrgrads(1,1,ps,string10,string10)
+
+      string10='u'
+      CALL wrgrads(1,llm,unat,string10,string10)
+      string10='v'
+      CALL wrgrads(1,llm,vnat,string10,string10)
+      string10='teta'
+      CALL wrgrads(1,llm,teta,string10,string10)
+      do iq=1,nqtot
+         string10='q'
+         write(string10(2:2),'(i1)') iq
+         CALL wrgrads(1,llm,q(:,:,iq),string10,string10)
+      enddo
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/abort_gcm.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/abort_gcm.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/abort_gcm.F	(revision 222)
@@ -0,0 +1,65 @@
+!
+! $Id: abort_gcm.F 1907 2013-11-26 13:10:46Z 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=*) modname
+      integer ierr, ierror_mpi
+      character(len=*) message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+c$OMP MASTER
+      call histclo
+      call restclo
+      if (MPI_rank .eq. 0) then
+         call getin_dump
+      endif
+c$OMP END MASTER
+#endif
+
+
+
+c     call histclo(2)
+c     call histclo(3)
+c     call histclo(4)
+c     call histclo(5)
+      write(lunout,*) 'Stopping in ', modname
+      write(lunout,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+#ifdef CPP_MPI
+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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/addfi_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/addfi_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/addfi_p.F	(revision 222)
@@ -0,0 +1,275 @@
+!
+! $Id: addfi_p.F 1446 2010-10-22 09:27:25Z emillour $
+!
+      SUBROUTINE addfi_p(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  (unit/s)
+c      pdtsfi(ip1jmp1)        |
+c
+c      Output :
+c      --------
+c      pucov
+c      pvcov
+c      ph
+c      pts
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      REAL,INTENT(IN) :: pdt ! time step for the integration (s)
+c
+      REAL,INTENT(INOUT) :: pvcov(ip1jm,llm) ! covariant meridional wind
+      REAL,INTENT(INOUT) :: pucov(ip1jmp1,llm) ! covariant zonal wind
+      REAL,INTENT(INOUT) :: pteta(ip1jmp1,llm) ! potential temperature
+      REAL,INTENT(INOUT) :: pq(ip1jmp1,llm,nqtot) ! tracers
+      REAL,INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
+c respective tendencies (.../s) to add
+      REAL,INTENT(IN) :: pdvfi(ip1jm,llm)
+      REAL,INTENT(IN) :: pdufi(ip1jmp1,llm)
+      REAL,INTENT(IN) :: pdqfi(ip1jmp1,llm,nqtot)
+      REAL,INTENT(IN) :: pdhfi(ip1jmp1,llm)
+      REAL,INTENT(IN) :: pdpfi(ip1jmp1)
+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
+!***********************
+! Correction on teta due to surface pressure changes
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO k = 1,llm
+        DO j = ijb,ije
+           pteta(j,k)= pteta(j,k)*(1+pdpfi(j)*pdt/pps(j))**kappa
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+!***********************
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advect_new_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advect_new_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advect_new_p.F	(revision 222)
@@ -0,0 +1,284 @@
+!
+! $Header$
+!
+      SUBROUTINE advect_new_p(ucov,vcov,teta,w,massebx,masseby,
+     &                        du,dv,dteta)
+      USE parallel_lmdz
+      USE write_field_p
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+      REAL,SAVE :: dv1(ip1jm,llm),du1(ip1jmp1,llm),dteta1(ip1jmp1,llm)
+      REAL,SAVE :: dv2(ip1jm,llm),du2(ip1jmp1,llm),dteta2(ip1jmp1,llm)
+c   Local:
+c   ------
+
+      REAL,SAVE :: uav(ip1jmp1,llm),vav(ip1jm,llm)
+      REAL wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l,ijb,ije
+
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+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.
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+        dv2(ij,1)=0.
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+
+      DO ij=ijb,ije
+        dteta2(ij,1)=0.
+      ENDDO
+c$OMP END MASTER
+
+ 
+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
+      
+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
+      
+      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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advect_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advect_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advect_p.F	(revision 222)
@@ -0,0 +1,219 @@
+!
+! $Header$
+!
+      SUBROUTINE advect_p(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
+      USE parallel_lmdz
+      USE write_field_p
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l,ijb,ije
+
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+      DO  l=1,llm
+         
+         ijb=ij_begin
+         ije=ij_end
+         if (pole_nord) ijb=ijb+iip1
+         if (pole_sud)  ije=ije-iip1
+         
+c         DO    ij     = iip2, ip1jmp1
+c            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+c         ENDDO
+
+c         DO    ij     = iip2, ip1jm
+c            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+c         ENDDO
+         
+         DO    ij     = ijb, ije
+                  
+           uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
+     .	             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+         ENDDO
+         
+         if (pole_nord) then
+           DO      ij         = 1, iip1
+              uav(ij      ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO      ij         = 1, iip1
+              uav(ip1jm+ij,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+      
+c      call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+      
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO  l=1,llm
+         
+         DO    ij   = ijb+1, ije
+           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         
+         DO    ij   = ijb,ije,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         
+         
+         DO    ij   = ijb, ije-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         
+         DO    ij       = ijb, ije, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+         
+      ENDDO
+c       call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+c-----------------------------------------------------------------------
+
+
+      
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if (pole_sud)  ije=ij_end
+      
+      DO 5   ij   = ijb, ije
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+         
+      DO 6 ij = ijb ,ije-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .....  correction pour  du(iip1,j,l)  ........
+c     .....     du(iip1,j,l)= du(1,j,l)   .....
+
+CDIR$ IVDEP
+      DO   7  ij   = ijb+iip1-1, ije, iip1
+      du( ij, l  ) = du( ij -iim, l  )
+      du( ij,l+1 ) = du( ij -iim,l+1 )
+   7  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 8 ij = ijb, ije
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+        ijb=ij_begin
+        ije=ij_end
+        
+        DO 15 ij = ijb, ije
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta(ij, l ) = dteta(ij, l )  -  ww
+         dteta(ij,l+1) = dteta(ij,l+1)  +  ww
+  15    CONTINUE
+
+c ym ---> conser a voir plus tard
+
+c      IF( conser)  THEN
+c        
+c        DO 17 ij = 1,ip1jmp1
+c        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+c  17    CONTINUE
+c        gt       = SSUM( ip1jmp1,ge,1 )
+c        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+c      END IF
+
+  20  CONTINUE
+ 
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advtrac_p.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advtrac_p.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/advtrac_p.F90	(revision 222)
@@ -0,0 +1,507 @@
+! $Id: advtrac_p.F90 1549 2011-07-05 08:41:12Z lguez $
+
+SUBROUTINE advtrac_p(pbaru,pbarv , p,  masse,q,iapptrac,teta, flxw, pk)
+
+  !     Auteur :  F. Hourdin
+  !
+  !     Modif. P. Le Van     (20/12/97)
+  !            F. Codron     (10/99)
+  !            D. Le Croller (07/2001)
+  !            M.A Filiberti (04/2002)
+  !
+  USE parallel_lmdz
+  USE Write_Field_p
+  USE Bands
+  USE mod_hallo
+  USE Vampir
+  USE times
+  USE infotrac, ONLY: nqtot, iadv
+  USE control_mod, ONLY: iapp_tracvl, day_step, planet_type
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comconst.h"
+  include "comvert.h"
+  include "comdissip.h"
+  include "comgeom2.h"
+  include "logic.h"
+  include "temps.h"
+  include "ener.h"
+  include "description.h"
+
+  !-------------------------------------------------------------------
+  !     Arguments
+  !-------------------------------------------------------------------
+  INTEGER,INTENT(OUT) :: iapptrac
+  REAL,INTENT(IN) :: pbaru(ip1jmp1,llm)
+  REAL,INTENT(IN) :: pbarv(ip1jm,llm)
+  REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot)
+  REAL,INTENT(IN) :: masse(ip1jmp1,llm)
+  REAL,INTENT(IN) :: p( ip1jmp1,llmp1 )
+  REAL,INTENT(IN) :: teta(ip1jmp1,llm)
+  REAL,INTENT(IN) :: pk(ip1jmp1,llm)
+  REAL,INTENT(OUT) :: flxw(ip1jmp1,llm)
+  !-------------------------------------------------------------------
+  !     Ajout PPM
+  !--------------------------------------------------------
+  REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm)
+  !-------------------------------------------------------------
+  !     Variables locales
+  !-------------------------------------------------------------
+
+  REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+  REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+  REAL,SAVE::pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) 
+  REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu
+  INTEGER iadvtr
+  INTEGER ij,l,iq,iiq
+  REAL zdpmin, zdpmax
+  SAVE iadvtr, massem, pbaruc, pbarvc
+  DATA iadvtr/0/
+  !$OMP THREADPRIVATE(iadvtr)
+  !----------------------------------------------------------
+  !     Rajouts pour PPM
+  !----------------------------------------------------------
+  INTEGER indice,n
+  REAL dtbon ! Pas de temps adaptatif pour que CFL<1
+  REAL CFLmaxz,aaa,bbb ! CFL maximum
+  REAL psppm(iim,jjp1) ! pression  au sol
+  REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm)
+  REAL qppm(iim*jjp1,llm,nqtot)
+  REAL fluxwppm(iim,jjp1,llm)
+  REAL apppm(llmp1), bpppm(llmp1)
+  LOGICAL dum,fill
+  DATA fill/.true./
+  DATA dum/.true./
+  REAL,SAVE :: finmasse(ip1jmp1,llm)
+  integer ijb,ije,ijb_u,ijb_v,ije_u,ije_v,j
+  type(Request) :: Request_vanleer
+  REAL,SAVE :: p_tmp( ip1jmp1,llmp1 )
+  REAL,SAVE :: teta_tmp(ip1jmp1,llm)
+  REAL,SAVE :: pk_tmp(ip1jmp1,llm)
+
+  ijb_u=ij_begin
+  ije_u=ij_end
+
+  ijb_v=ij_begin-iip1
+  ije_v=ij_end
+  if (pole_nord) ijb_v=ij_begin
+  if (pole_sud)  ije_v=ij_end-iip1
+
+  IF(iadvtr.EQ.0) THEN
+     !         CALL initial0(ijp1llm,pbaruc)
+     !         CALL initial0(ijmllm,pbarvc)
+     !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+     DO l=1,llm   
+        pbaruc(ijb_u:ije_u,l)=0.
+        pbarvc(ijb_v:ije_v,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 = ijb_u,ije_u
+        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+     ENDDO
+     DO ij = ijb_v,ije_v
+        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+  !$OMP END DO NOWAIT
+
+  !   selection de la masse instantanee des mailles avant le transport.
+  IF(iadvtr.EQ.0) THEN
+
+     !         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+     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
+
+     !cc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+     !
+  ENDIF ! of IF(iadvtr.EQ.0)
+
+  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
+     !$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_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+     !$OMP BARRIER
+
+     !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llmp1
+        p_tmp(ijb:ije,l)=p(ijb:ije,l)
+     ENDDO
+     !$OMP END DO NOWAIT
+
+     !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llm
+        pk_tmp(ijb:ije,l)=pk(ijb:ije,l)
+        teta_tmp(ijb:ije,l)=teta(ijb:ije,l)
+     ENDDO
+     !$OMP END DO NOWAIT
+
+     !$OMP MASTER
+     call VTb(VTHallo)
+     !$OMP END MASTER
+
+     call Register_SwapFieldHallo(pbarug,pbarug,ip1jmp1,llm, &
+          jj_Nb_vanleer,0,0,Request_vanleer)
+     call Register_SwapFieldHallo(pbarvg,pbarvg,ip1jm,llm, &
+          jj_Nb_vanleer,1,0,Request_vanleer)
+     call Register_SwapFieldHallo(massem,massem,ip1jmp1,llm, &
+          jj_Nb_vanleer,0,0,Request_vanleer)
+     call Register_SwapFieldHallo(wg,wg,ip1jmp1,llm, &
+          jj_Nb_vanleer,0,0,Request_vanleer)
+     call Register_SwapFieldHallo(teta_tmp,teta_tmp,ip1jmp1,llm, &
+          jj_Nb_vanleer,1,1,Request_vanleer)
+     call Register_SwapFieldHallo(p_tmp,p_tmp,ip1jmp1,llmp1, &
+          jj_Nb_vanleer,1,1,Request_vanleer)
+     call Register_SwapFieldHallo(pk_tmp,pk_tmp,ip1jmp1,llm, &
+          jj_Nb_vanleer,1,1,Request_vanleer)
+     do j=1,nqtot
+        call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, &
+             jj_nb_vanleer,0,0,Request_vanleer)
+     enddo
+
+     call SendRequest(Request_vanleer)
+     !$OMP BARRIER
+     call WaitRequest(Request_vanleer)
+
+
+     !$OMP BARRIER
+     !$OMP MASTER      
+     call SetDistrib(jj_nb_vanleer)
+     call VTe(VTHallo)
+     call VTb(VTadvection)
+     call start_timer(timer_vanleer)
+     !$OMP END MASTER
+     !$OMP BARRIER
+
+     ! ... Flux de masse diagnostiques traceurs
+     ijb=ij_begin
+     ije=ij_end
+     flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/REAL(iapp_tracvl)
+
+     !  test sur l'eventuelle creation de valeurs negatives de la masse
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_nord) ijb=ij_begin+iip1
+     if (pole_sud) ije=ij_end-iip1
+
+     !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+     DO l=1,llm-1
+        DO ij = ijb+1,ije
+           zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l) &
+                - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
+                +       wg(ij,l+1)  - wg(ij,l)
+        ENDDO
+
+        !            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+        ! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
+
+        do ij=ijb,ije-iip1+1,iip1
+           zdp(ij)=zdp(ij+iip1-1)
+        enddo
+
+        DO ij = ijb,ije
+           zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+        ENDDO
+
+
+        !            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+        !  ym ---> eventuellement a revoir
+        CALL minmax ( ije-ijb+1, zdp(ijb), zdpmin,zdpmax )
+
+        IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+           PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin, &
+                '   MAX:', zdpmax
+        ENDIF
+
+     ENDDO
+     !$OMP END DO NOWAIT
+
+     !-------------------------------------------------------------------
+     !   Advection proprement dite (Modification Le Croller (07/2001)
+     !-------------------------------------------------------------------
+
+     !----------------------------------------------------
+     !        Calcul des moyennes basées sur la masse
+     !----------------------------------------------------
+
+     !ym      ----> Normalement, inutile pour les schémas classiques
+     !ym      ----> Revérifier lors de la parallélisation des autres schemas
+
+     !ym          call massbar_p(massem,massebx,masseby)  
+
+     call vlspltgen_p( q,iadv, 2., massem, wg , &
+          pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp )
+
+
+!!! ATTENTION !!!! TOUT CE QUI EST ENTRE ICI ET 1234 EST OBSOLETE !!!!!!!
+     GOTO 1234
+!!! ATTENTION !!!!
+
+     !-----------------------------------------------------------
+     !     Appel des sous programmes d'advection
+     !-----------------------------------------------------------
+     do iq=1,nqtot
+        !        call clock(t_initial)
+        if(iadv(iq) == 0) cycle 
+        !   ----------------------------------------------------------------
+        !   Schema de Van Leer I MUSCL
+        !   ----------------------------------------------------------------
+        if(iadv(iq).eq.10) THEN
+
+           call vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
+
+           !   ----------------------------------------------------------------
+           !   Schema "pseudo amont" + test sur humidite specifique
+           !    pour la vapeur d'eau. F. Codron
+           !   ----------------------------------------------------------------
+        else if(iadv(iq).eq.14) then
+           !
+           !ym        stop 'advtrac : appel à vlspltqs :schema non parallelise'
+           CALL vlspltqs_p( q(1,1,1), 2., massem, wg , &
+                pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp )
+           !   ----------------------------------------------------------------
+           !   Schema de Frederic Hourdin
+           !   ----------------------------------------------------------------
+        else if(iadv(iq).eq.12) then
+           stop 'advtrac : schema non parallelise'
+           !            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           do indice=1,n
+              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+           end do
+        else if(iadv(iq).eq.13) then
+           stop 'advtrac : schema non parallelise'
+           !            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           do indice=1,n
+              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+           end do
+           !   ----------------------------------------------------------------
+           !   Schema de pente SLOPES
+           !   ----------------------------------------------------------------
+        else if (iadv(iq).eq.20) then
+           stop 'advtrac : schema non parallelise'
+
+           call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+           !   ----------------------------------------------------------------
+           !   Schema de Prather
+           !   ----------------------------------------------------------------
+        else if (iadv(iq).eq.30) then
+           stop 'advtrac : schema non parallelise'
+           !            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg, &
+                n,dtbon)
+           !   ----------------------------------------------------------------
+           !   Schemas PPM Lin et Rood
+           !   ----------------------------------------------------------------
+        else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. &
+             iadv(iq).LE.18)) then
+
+           stop 'advtrac : schema non parallelise'
+
+           !        Test sur le flux horizontal
+           !        Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
+                   dtvr,'n=',n
+           endif
+           !        Test sur le flux vertical
+           CFLmaxz=0.
+           do l=2,llm
+              do ij=iip2,ip1jm
+                 aaa=wg(ij,l)*dtvr/massem(ij,l)
+                 CFLmaxz=max(CFLmaxz,aaa)
+                 bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+                 CFLmaxz=max(CFLmaxz,bbb)
+              enddo
+           enddo
+           if (CFLmaxz.GE.1) then
+              write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+           endif
+
+           !-----------------------------------------------------------
+           !        Ss-prg interface LMDZ.4->PPM3d
+           !-----------------------------------------------------------
+
+           call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
+                apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
+                unatppm,vnatppm,psppm)
+
+           do indice=1,n
+              !----------------------------------------------------------------
+              !                         VL (version PPM) horiz. et PPM vert.
+              !----------------------------------------------------------------
+              if (iadv(iq).eq.11) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+
+                 !-------------------------------------------------------------
+                 !                           Monotonic PPM
+                 !-------------------------------------------------------------
+              else if (iadv(iq).eq.16) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+                 !-------------------------------------------------------------
+
+                 !-------------------------------------------------------------
+                 !                           Semi Monotonic PPM
+                 !-------------------------------------------------------------
+              else if (iadv(iq).eq.17) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+                 !-------------------------------------------------------------
+
+                 !-------------------------------------------------------------
+                 !                         Positive Definite PPM
+                 !-------------------------------------------------------------
+              else if (iadv(iq).eq.18) then
+                 !                  Ss-prg PPM3d de Lin
+                 call ppm3d(1,qppm(1,1,iq), &
+                      psppm,psppm, &
+                      unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, &
+                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
+                      fill,dum,220.)
+                 !-------------------------------------------------------------
+              endif
+           enddo
+           !-----------------------------------------------------------------
+           !               Ss-prg interface PPM3d-LMDZ.4
+           !-----------------------------------------------------------------
+           call interpost(q(1,1,iq),qppm(1,1,iq))
+        endif
+        !----------------------------------------------------------------------
+
+        !-----------------------------------------------------------------
+        ! On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
+        ! et Nord j=1
+        !-----------------------------------------------------------------
+
+        !                  call traceurpole(q(1,1,iq),massem)
+
+        ! calcul du temps cpu pour un schema donne
+
+        !                  call clock(t_final)
+        !ym                  tps_cpu=t_final-t_initial
+        !ym                  cpuadv(iq)=cpuadv(iq)+tps_cpu
+
+     end DO
+
+!!! ATTENTION !!!!
+1234 CONTINUE
+!!! ATTENTION !!!! LE CODE REPREND ICI !!!!!!!!
+
+     !$OMP BARRIER
+
+     if (planet_type=="earth") then
+
+        ijb=ij_begin
+        ije=ij_end
+
+        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l = 1, llm
+           DO ij = ijb, ije
+              finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+           ENDDO
+        ENDDO
+        !$OMP END DO
+
+        CALL qminimum_p( q, 2, finmasse )
+
+     endif ! of if (planet_type=="earth")
+
+        !------------------------------------------------------------------
+        !   on reinitialise a zero les flux de masse cumules
+        !---------------------------------------------------
+        !          iadvtr=0
+
+        !$OMP MASTER
+	call VTe(VTadvection)
+        call stop_timer(timer_vanleer)
+        call VTb(VThallo)
+        !$OMP END MASTER
+
+
+	do j=1,nqtot
+           call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, &
+                jj_nb_caldyn,0,0,Request_vanleer)
+        enddo
+
+        call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm, &
+             jj_nb_caldyn,0,0,Request_vanleer)
+
+        call SendRequest(Request_vanleer)
+        !$OMP BARRIER
+        call WaitRequest(Request_vanleer)      
+
+        !$OMP BARRIER
+        !$OMP MASTER
+        call SetDistrib(jj_nb_caldyn)
+	call VTe(VThallo)
+	call resume_timer(timer_caldyn)
+ !$OMP END MASTER
+ !$OMP BARRIER	
+        iadvtr=0
+  ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+END SUBROUTINE advtrac_p
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bands.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bands.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bands.F90	(revision 222)
@@ -0,0 +1,437 @@
+!
+! $Id: bands.F90 1615 2012-02-10 15:42:26Z emillour $
+!
+  module Bands
+  
+    integer, parameter :: bands_caldyn=1
+    integer, parameter :: bands_vanleer=2
+    integer, parameter :: bands_dissip=3
+    
+    INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2
+    INTEGER,dimension(:),allocatable :: jj_Nb_dissip
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis
+    INTEGER,dimension(:),allocatable :: distrib_phys
+  
+  contains
+  
+  subroutine AllocateBands
+    use parallel_lmdz
+    implicit none
+    
+    allocate(jj_Nb_Caldyn(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer2(0:MPI_Size-1))
+    allocate(jj_Nb_dissip(0:MPI_Size-1))
+    allocate(jj_Nb_physic(0:MPI_Size-1))
+    allocate(jj_Nb_physic_bis(0:MPI_Size-1))
+    allocate(distrib_phys(0:MPI_Size-1))
+  
+  end subroutine AllocateBands
+  
+  subroutine Read_distrib
+    use parallel_lmdz
+    implicit none
+
+    include "dimensions.h"
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+    
+      call AllocateBands
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+       
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+      
+         do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_caldyn(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_vanleer(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_dissip(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,distrib_phys(i)
+        enddo
+	
+	CLOSE(unit_number)  
+  
+      else
+        do i=0,mpi_size-1
+          jj_nb_caldyn(i)=(jjm+1)/mpi_size
+	  if (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
+        enddo
+      
+        jj_nb_vanleer(:)=jj_nb_caldyn(:)
+        jj_nb_dissip(:)=jj_nb_caldyn(:)
+        
+	do i=0,mpi_size-1
+	  distrib_phys(i)=(iim*(jjm-1)+2)/mpi_size
+	  IF (i<MOD(iim*(jjm-1)+2,mpi_size)) distrib_phys(i)=distrib_phys(i)+1
+	enddo
+      endif
+  
+   end subroutine Read_distrib
+   
+   
+   SUBROUTINE  Set_Bands 
+     USE parallel_lmdz
+#ifdef CPP_PHYS
+! Ehouarn: what follows is only related to // physics
+     USE mod_phys_lmdz_para, ONLY : jj_para_begin,jj_para_end
+#endif
+     IMPLICIT NONE
+     INCLUDE 'dimensions.h'    
+     INTEGER :: i
+        
+      do i=0,mpi_size-1
+         jj_nb_vanleer2(i)=(jjm+1)/mpi_size
+	 if (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
+      enddo
+          
+#ifdef CPP_PHYS
+      do i=0,MPI_Size-1
+        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic(i-1)=jj_Nb_physic(i-1)-1
+          endif
+        endif
+      enddo
+      
+      do i=0,MPI_Size-1
+        jj_Nb_physic_bis(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+          else
+	    jj_Nb_physic_bis(i-1)=jj_Nb_physic_bis(i-1)+1
+	    jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+	  endif
+        endif
+      enddo
+#endif      
+      
+    end subroutine Set_Bands
+
+
+    subroutine AdjustBands_caldyn
+      use times
+      use parallel_lmdz
+      implicit none
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+        if (jj_nb_caldyn(max_proc)>3) then
+          if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then
+             jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+             jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
+	        -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then
+               jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+               jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+         
+    end subroutine AdjustBands_caldyn
+    
+    subroutine AdjustBands_vanleer
+      use times
+      use parallel_lmdz
+      implicit none
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_vanleer(max_proc)>3) then
+          if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. &
+             timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then
+             jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+             jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then
+               jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+               jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+         
+    end subroutine AdjustBands_vanleer
+
+    subroutine AdjustBands_dissip
+      use times
+      use parallel_lmdz
+      implicit none
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_dissip(max_proc)>3) then
+          if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then
+             jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+             jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
+	        - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then
+               jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+               jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+         
+    end subroutine AdjustBands_dissip
+
+    subroutine AdjustBands_physic
+      use times
+#ifdef CPP_PHYS
+! Ehouarn: what follows is only related to // physics
+      USE mod_phys_lmdz_para, only : klon_mpi_para_nb
+#endif
+      USE parallel_lmdz
+      implicit none
+
+      integer :: i,Index
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: Inc
+      real :: medium
+      integer :: NbTot,sgn
+      
+      allocate(value(0:mpi_size-1))
+      allocate(Inc(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+      
+      medium=0
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_physic(i),timer_physic,i)
+	medium=medium+value(i)
+      enddo    
+      
+      medium=medium/mpi_size      
+      NbTot=0
+#ifdef CPP_PHYS
+      do i=0,mpi_size-1
+        Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i))
+        NbTot=NbTot+Inc(i)  
+      enddo
+      
+      if (NbTot>=0) then
+        Sgn=1
+      else
+        Sgn=-1
+	NbTot=-NbTot
+      endif
+      
+      Index=0
+      do i=1,NbTot
+        Inc(Index)=Inc(Index)-Sgn
+	Index=Index+1
+	if (Index>mpi_size-1) Index=0
+      enddo
+      
+      do i=0,mpi_size-1
+        distrib_phys(i)=klon_mpi_para_nb(i)+inc(i)
+      enddo
+#endif     
+    end subroutine AdjustBands_physic
+
+    subroutine WriteBands
+    USE parallel_lmdz
+    implicit none
+    include "dimensions.h"
+
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+  
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+      
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+        
+!	write (unit_number,*) '*** Bandes caldyn ***'
+	do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_caldyn(i)
+        enddo
+        
+!	write (unit_number,*) '*** Bandes vanleer ***' 
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_vanleer(i)
+        enddo
+       
+!        write (unit_number,*) '*** Bandes dissip ***'
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_dissip(i)
+        enddo
+        
+	do i=0,mpi_size-1
+          write (unit_number,*) i,distrib_phys(i)
+        enddo
+	
+        CLOSE(unit_number)   
+      else 
+        print *,'probleme lors de l ecriture des bandes'
+      endif
+       
+    end subroutine WriteBands
+  
+  end module Bands
+  
+  
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bernoui_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bernoui_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bernoui_p.F	(revision 222)
@@ -0,0 +1,74 @@
+      SUBROUTINE bernoui_p (ngrid,nlay,pphi,pecin,pbern)
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c     calcul de la fonction de Bernouilli aux niveaux s  .....
+c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
+c                              energ.cinet.)
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Decalrations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+c
+c   Arguments:
+c   ----------
+c
+      INTEGER nlay,ngrid
+      REAL pphi(ngrid,nlay),pecin(ngrid,nlay),pbern(ngrid,nlay)
+c
+c   Local:
+c   ------
+c
+      INTEGER   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,jje, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      
+      
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bilan_dyn_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bilan_dyn_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/bilan_dyn_p.F	(revision 222)
@@ -0,0 +1,811 @@
+!
+! $Id: bilan_dyn_p.F 1907 2013-11-26 13:10:46Z lguez $
+!
+      SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum,
+     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+c   AFAIRE
+c   Prevoir en champ nq+1 le diagnostique de l'energie
+c   en faisant Qzon=Cv T + L * ...
+c             vQ..A=Cp T + L * ...
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE parallel_lmdz
+      USE mod_hallo
+      use misc_mod
+      use write_field_p
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.h"
+#include "iniprint.h"
+
+c====================================================================
+c
+c   Sous-programme consacre à des diagnostics dynamiques de base
+c
+c 
+c   De facon generale, les moyennes des scalaires Q sont ponderees par
+c   la masse.
+c
+c   Les flux de masse sont eux simplement moyennes.
+c
+c====================================================================
+
+c   Arguments :
+c   ===========
+
+      integer ntrac
+      real dt_app,dt_cum
+      real ps(iip1,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+      real flux_u(iip1,jjp1,llm)
+      real flux_v(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+      real phi(iip1,jjp1,llm)
+      real ucov(iip1,jjp1,llm)
+      real vcov(iip1,jjm,llm)
+      real trac(iip1,jjp1,llm,ntrac)
+
+c   Local :
+c   =======
+
+      integer,save :: icum,ncum
+!$OMP THREADPRIVATE(icum,ncum)
+      logical,SAVE :: first=.true.
+!$OMP THREADPRIVATE(first) 
+
+      real zz,zqy
+      real,save :: zfactv(jjm,llm)
+
+      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 :: vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+      REAL,save :: ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+      REAL,save :: massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL,save :: vorpot(iip1,jjm,llm)
+      REAL,save :: w(iip1,jjp1,llm),ecin(iip1,jjp1,llm)
+      REAL,save ::convm(iip1,jjp1,llm)
+      REAL,save :: bern(iip1,jjp1,llm)
+
+c   champ contenant les scalaires advectés.
+      real,save :: Q(iip1,jjp1,llm,nQ)
+    
+c   champs cumulés
+      real,save :: ps_cum(iip1,jjp1)
+      real,save :: masse_cum(iip1,jjp1,llm)
+      real,save :: flux_u_cum(iip1,jjp1,llm)
+      real,save :: flux_v_cum(iip1,jjm,llm)
+      real,save :: Q_cum(iip1,jjp1,llm,nQ)
+      real,save :: flux_uQ_cum(iip1,jjp1,llm,nQ)
+      real,save :: flux_vQ_cum(iip1,jjm,llm,nQ)
+      real,save :: flux_wQ_cum(iip1,jjp1,llm,nQ)
+      real,save :: dQ(iip1,jjp1,llm,nQ)
+
+
+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 :: zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+      real,save :: zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+      real,save :: zmasse(jjm,llm),zamasse(jjm)
+
+      real,save :: zv(jjm,llm),psi(jjm,llm+1)
+
+      integer i,j,l,iQ
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      character*10 infile
+
+      integer fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      integer,save :: ndex3d(jjm*llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer ii,jj
+      integer zan, dayref
+C
+      real,save :: rlong(jjm),rlatg(jjm)
+      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
+
+        ndex3d=0
+
+        icum=0
+c       initialisation des fichiers
+        first=.false.
+c   ncum est la frequence de stokage en pas de temps
+        ncum=dt_cum/dt_app
+        if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+           WRITE(lunout,*)
+     .            'Pb : le pas de cumule doit etre multiple du pas'
+           WRITE(lunout,*)'dt_app=',dt_app
+           WRITE(lunout,*)'dt_cum=',dt_cum
+           stop
+        else
+          write(lunout,*) "bilan_dyn_p: ncum=",ncum
+        endif
+
+!        if (i_sortie.eq.1) then
+!	 file='dynzon'
+!         if (mpi_rank==0) then
+!	 call inigrads(ifile,1
+!     s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
+!     s  ,llm,presnivs,1.
+!     s  ,dt_cum,file,'dyn_zon ')
+!         endif
+!        endif
+
+!$OMP MASTER
+        nom(itemp)='T'
+        nom(igeop)='gz'
+        nom(iecin)='K'
+        nom(iang)='ang'
+        nom(iu)='u'
+        nom(iovap)='ovap'
+        nom(iun)='un'
+
+        unites(itemp)='K'
+        unites(igeop)='m2/s2'
+        unites(iecin)='m2/s2'
+        unites(iang)='ang'
+        unites(iu)='m/s'
+        unites(iovap)='kg/kg'
+        unites(iun)='un'
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      infile='dynzon'
+
+      zan = annee_ref
+      dayref = day_ref
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      rlong=0.
+      rlatg=rlatv*180./pi
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      IF (pole_sud) THEN
+        jjn=jj_nb-1
+        jje=jj_end-1
+      ENDIF
+
+      ddid=(/ 2 /)
+      dsg=(/ jjm /)
+      dsl=(/ jjn /)
+      dpf=(/ jjb /)
+      dpl=(/ jje /)
+      dhs=(/ 0 /)
+      dhe=(/ 0 /)
+
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
+     .                 'box',bilan_dyn_domain_id)
+       
+      call histbeg(trim(infile),
+     .             1, rlong(jjb:jje), jjn, rlatg(jjb:jje),
+     .             1, 1, 1, jjn,
+     .             tau0, zjulian, dt_cum, thoriid, fileid,
+     .             bilan_dyn_domain_id)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
+     .              llm, presnivs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+      do iQ=1,nQ
+         do itr=1,ntr
+            if(itr.eq.1) then
+               znom(itr,iQ)=nom(iQ)
+               znoml(itr,iQ)=nom(iQ)
+               zunites(itr,iQ)=unites(iQ)
+            else
+               znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+               znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+               zunites(itr,iQ)='m/s * '//unites(iQ)
+            endif
+         enddo
+      enddo
+
+c   Declarations des champs avec dimension verticale
+c      print*,'1HISTDEF'
+      do iQ=1,nQ
+         do itr=1,ntr
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'var ',itr,iQ
+     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+            call histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+c   Declarations pour les fonctions de courant
+c      print*,'2HISTDEF'
+          call histdef(fileid,'psi'//nom(iQ)
+     .      ,'stream fn. '//znoml(itot,iQ),
+     .      zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+      enddo
+
+
+c   Declarations pour les champs de transport d'air
+c      print*,'3HISTDEF'
+      call histdef(fileid, 'masse', 'masse',
+     .             'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'v', 'v',
+     .             'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+c   Declarations pour les fonctions de courant
+c      print*,'4HISTDEF'
+          call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
+     .      1,jjn,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+
+
+c   Declaration des champs 1D de transport en latitude
+c      print*,'5HISTDEF'
+      do iQ=1,nQ
+         do itr=2,ntr
+            call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+      enddo
+
+
+c      print*,'8HISTDEF'
+               CALL histend(fileid)
+
+!$OMP END MASTER
+!$OMP BARRIER
+      endif
+
+
+c=====================================================================
+c   Calcul des champs dynamiques
+c   ----------------------------
+
+      jjb=jj_begin
+      jje=jj_end
+    
+c   énergie cinétique
+!      ucont(:,jjb:jje,:)=0
+
+      call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Req)
+      call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Req)
+      call SendRequest(Req)
+c$OMP BARRIER
+      call WaitRequest(Req)
+c$OMP BARRIER
+
+      CALL covcont_p(llm,ucov,vcov,ucont,vcont)
+      CALL enercin_p(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
+
+!$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 BARRIER
+
+!$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 BARRIER
+
+!$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(Q(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req)
+      enddo
+      call SendRequest(Req)
+!$OMP BARRIER      
+      call WaitRequest(Req)
+!$OMP BARRIER
+
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         do l=1,llm
+            do j=jjb,jje
+               do i=1,iip1
+                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
+     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+               enddo
+            enddo
+         enddo
+!$OMP END DO NOWAIT
+      enddo
+
+
+c    tendances
+c    ---------
+
+c   convergence horizontale
+      call Register_Hallo(flux_uQ_cum,ip1jmp1,llm,2,2,2,2,Req)
+      call Register_Hallo(flux_vQ_cum,ip1jm,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+!$OMP BARRIER      
+      call WaitRequest(Req)
+c$OMP BARRIER
+
+      call  convflu_p(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+c   calcul de la vitesse verticale
+      call Register_Hallo(flux_u_cum,ip1jmp1,llm,2,2,2,2,Req)
+      call Register_Hallo(flux_v_cum,ip1jm,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+!$OMP BARRIER      
+      call WaitRequest(Req)
+c$OMP BARRIER
+
+      call convmas_p(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert_p(convm,w)
+!$OMP BARRIER      
+
+      jjb=jj_begin
+      jje=jj_end
+
+      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
+
+      jjb=jj_begin
+      jje=jj_end
+
+
+c   A retravailler eventuellement
+c   division de dQ par la masse pour revenir aux bonnes grandeurs
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
+        ENDDO
+!$OMP ENDDO NOWAIT 
+      enddo
+ 
+c=====================================================================
+c   Transport méridien
+c=====================================================================
+
+c   cumul zonal des masses des mailles
+c   ----------------------------------
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          zv(jjb:jje,l)=0.
+          zmasse(jjb:jje,l)=0.
+        ENDDO
+!$OMP ENDDO NOWAIT 
+
+      call Register_Hallo(masse_cum,ip1jmp1,llm,1,1,1,1,Req)
+      do iQ=1,nQ
+        call Register_Hallo(Q_cum(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req)
+      enddo
+
+      call SendRequest(Req)
+!$OMP BARRIER
+      call WaitRequest(Req)
+c$OMP BARRIER
+
+      call massbar_p(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 
+
+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 ! of do iQ=1,nQ
+
+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
+!$OMP BARRIER
+c     on doit pouvoir tracer systematiquement la fonction de courant.
+
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+      return
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/caldyn_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/caldyn_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/caldyn_p.F	(revision 222)
@@ -0,0 +1,215 @@
+!
+! $Id: $
+!
+#undef DEBUG_IO
+c#define DEBUG_IO
+
+      SUBROUTINE caldyn_p
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,tsurpk,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+      USE parallel_lmdz
+      USE Write_Field_p
+      
+      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 "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+!   Arguments:
+!   ----------
+
+      LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics
+      INTEGER,INTENT(IN) :: itau ! time step index
+      REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
+      REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
+      REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
+      REAL,INTENT(IN) :: ps(ip1jmp1) ! surface pressure
+      REAL,INTENT(IN) :: phis(ip1jmp1) ! geopotential at the surface
+      REAL,INTENT(IN) :: pk(ip1jmp1,llm) ! Exner at mid-layer
+      REAL,INTENT(IN) :: pkf(ip1jmp1,llm) ! filtered Exner
+      REAL,INTENT(IN) :: tsurpk(ip1jmp1,llm) ! cpp * temperature / pk
+      REAL,INTENT(IN) :: phi(ip1jmp1,llm) ! geopotential
+      REAL,INTENT(OUT) :: masse(ip1jmp1,llm) ! air mass
+      REAL,INTENT(OUT) :: dv(ip1jm,llm) ! tendency on vcov
+      REAL,INTENT(OUT) :: du(ip1jmp1,llm) ! tendency on ucov
+      REAL,INTENT(OUT) :: dteta(ip1jmp1,llm) ! tenddency on teta
+      REAL,INTENT(OUT) :: dp(ip1jmp1) ! tendency on ps
+      REAL,INTENT(OUT) :: w(ip1jmp1,llm) ! vertical velocity
+      REAL,INTENT(OUT) :: pbaru(ip1jmp1,llm) ! mass flux in the zonal direction
+      REAL,INTENT(OUT) :: pbarv(ip1jm,llm) ! mass flux in the meridional direction
+      REAL,INTENT(IN) :: time ! current time
+
+!   Local:
+!   ------
+
+      REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL,SAVE :: ang(ip1jmp1,llm)
+      REAL,SAVE :: p(ip1jmp1,llmp1)
+      REAL,SAVE :: massebx(ip1jmp1,llm),masseby(ip1jm,llm)
+      REAL,SAVE :: psexbarxy(ip1jm)
+      REAL,SAVE :: vorpot(ip1jm,llm)
+      REAL,SAVE :: ecin(ip1jmp1,llm)
+      REAL,SAVE :: bern(ip1jmp1,llm)
+      REAL,SAVE :: massebxy(ip1jm,llm)
+      REAL,SAVE :: convm(ip1jmp1,llm)
+!      REAL,SAVE :: temp(ip1jmp1,llm)
+      INTEGER   ij,l,ijb,ije,ierr
+
+!-----------------------------------------------------------------------
+!   Compute dynamical tendencies:
+!--------------------------------
+
+      ! compute contravariant winds ucont() and vcont
+      CALL covcont_p  ( llm    , ucov    , vcov , ucont, vcont        )
+      ! compute pressure p()
+      CALL pression_p ( ip1jmp1, ap      , bp   ,  ps  , p            )
+cym      CALL psextbar (   ps   , psexbarxy                          )
+c$OMP BARRIER
+      ! compute mass in each atmospheric mesh: masse()
+      CALL massdair_p (    p   , masse                                )
+      ! compute X and Y-averages of mass, massebx() and masseby()
+      CALL massbar_p  (   masse, massebx , masseby                    )
+      ! compute XY-average of mass, massebxy()
+      call massbarxy_p(   masse, massebxy                             )
+      ! compute mass fluxes pbaru() and pbarv()
+      CALL flumass_p  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      ! compute dteta() , horizontal converging flux of theta
+      CALL dteta1_p   (   teta , pbaru   , pbarv, dteta               )
+      ! compute convm(), horizontal converging flux of mass
+      CALL convmas1_p  (   pbaru, pbarv   , convm                      )
+c$OMP BARRIER      
+      CALL convmas2_p  (   convm                      )
+c$OMP BARRIER
+#ifdef DEBUG_IO
+c$OMP BARRIER
+c$OMP MASTER
+      call WriteField_p('ucont',reshape(ucont,(/iip1,jmp1,llm/)))
+      call WriteField_p('vcont',reshape(vcont,(/iip1,jjm,llm/)))
+      call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/)))
+      call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
+      call WriteField_p('massebx',reshape(massebx,(/iip1,jmp1,llm/)))
+      call WriteField_p('masseby',reshape(masseby,(/iip1,jjm,llm/)))
+      call WriteField_p('massebxy',reshape(massebxy,(/iip1,jjm,llm/)))
+      call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
+      call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
+      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
+      call WriteField_p('convm',reshape(convm,(/iip1,jmp1,llm/)))
+c$OMP END MASTER
+c$OMP BARRIER
+#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
+c$OMP FLUSH
+
+      ! compute vertical velocity w()
+      CALL vitvert_p ( convm  , w                                  )
+      ! compute potential vorticity vorpot()
+      CALL tourpot_p ( vcov   , ucov  , massebxy  , vorpot         )
+      ! compute rotation induced du() and dv()
+      CALL dudv1_p   ( vorpot , pbaru , pbarv     , du     , dv    )
+
+#ifdef DEBUG_IO      
+c$OMP BARRIER
+c$OMP MASTER
+      call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/)))
+      call WriteField_p('vorpot',reshape(vorpot,(/iip1,jjm,llm/)))
+      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
+      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
+c$OMP END MASTER
+c$OMP BARRIER
+#endif      
+      
+      ! compute kinetic energy ecin()
+      CALL enercin_p ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      ! compute Bernouilli function bern()
+      CALL bernoui_p ( ip1jmp1, llm   , phi       , ecin   , bern  )
+      ! compute and add du() and dv() contributions from Bernouilli and pressure
+      CALL dudv2_p   ( tsurpk , pkf   , bern      , du     , dv    )
+
+#ifdef DEBUG_IO
+c$OMP BARRIER
+c$OMP MASTER
+      call WriteField_p('ecin',reshape(ecin,(/iip1,jmp1,llm/)))
+      call WriteField_p('bern',reshape(bern,(/iip1,jmp1,llm/)))
+      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
+      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
+      call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
+c$OMP END MASTER
+c$OMP BARRIER
+#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_p(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      
+c-----------------------------------------------------------------------
+c   Sorties eventuelles des variables de controle:
+c   ----------------------------------------------
+
+      IF( conser )  THEN
+c ym ---> exige communication collective ( aussi dans advect)
+        CALL sortvarc
+     $ (itau,ucov,tsurpk,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov)
+
+      ENDIF
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/calfis_icosa.f90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/calfis_icosa.f90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/calfis_icosa.f90	(revision 222)
@@ -0,0 +1,98 @@
+SUBROUTINE calfis_icosa(dtphy, lafin, day, time, presnivs,      &
+                        plev, play, phi, phis, ulon, ulat, T, q, wflux, &
+                        du, dv, dT, dq, dps) 
+  USE infotrac
+  USE dimphy
+  USE control_mod
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  INCLUDE "comconst.h"
+  
+  REAL, INTENT(IN)    :: dtphy
+  LOGICAL, INTENT(IN) :: lafin
+  REAL, INTENT(IN)    :: day
+  REAL, INTENT(IN)    :: time
+  REAL,INTENT(IN) :: presnivs(klev)
+  REAL,INTENT(IN) :: plev(klon_mpi,klev+1)
+  REAL,INTENT(IN) :: play(klon_mpi,klev)
+  REAL,INTENT(IN) :: phi(klon_mpi,klev)
+  REAL,INTENT(IN) :: phis(klon_mpi)
+  REAL,INTENT(IN) :: ulon(klon_mpi,klev) 
+  REAL,INTENT(IN) :: ulat(klon_mpi,klev)
+  REAL,INTENT(IN) :: T(klon_mpi,klev)
+  REAL,INTENT(IN) :: q(klon_mpi,klev,nqtot)
+  REAL,INTENT(IN) :: wflux(klon_mpi,klev)
+  REAL,INTENT(OUT) :: du(klon_mpi,klev)
+  REAL,INTENT(OUT) :: dv(klon_mpi,klev)
+  REAL,INTENT(OUT) :: dT(klon_mpi,klev)
+  REAL,INTENT(OUT) :: dq(klon_mpi,klev,nqtot)
+  REAL,INTENT(OUT) :: dps(klon_mpi)
+
+  REAL :: ducov(klon_mpi,klev)
+  REAL :: plev_omp(klon_omp,klev+1)
+  REAL :: play_omp(klon_omp,klev)
+  REAL :: phi_omp(klon_omp,klev)
+  REAL :: ulon_omp(klon_omp,klev)
+  REAL :: ulat_omp(klon_omp,klev)
+  REAL :: T_omp(klon_omp,klev)
+  REAL :: q_omp(klon_omp,klev,nqtot)
+  CHARACTER(len=255) :: t_name(nqtot)
+  REAL :: wflux_omp(klon_omp,klev)
+  REAL :: du_omp(klon_omp,klev)
+  REAL :: dv_omp(klon_omp,klev)
+  REAL :: dt_omp(klon_omp,klev)
+  REAL :: dq_omp(klon_omp,klev,nqtot)
+  REAL :: dps_omp(klon_omp)
+  LOGICAL :: tracerdyn
+   
+  LOGICAL,SAVE :: debut=.TRUE.
+  INTEGER :: k,offset
+ 
+    
+    offset=klon_omp_begin-1
+    klon=klon_omp
+    DO k=1,klon_omp
+      plev_omp(k,:) = plev(k+offset,:)
+      play_omp(k,:) = play(k+offset,:)
+      phi_omp(k,:)  = phi(k+offset,:)
+      ulon_omp(k,:) = ulon(k+offset,:)
+      ulat_omp(k,:) = ulat(k+offset,:)
+      T_omp(k,:)    = T(k+offset,:)
+      q_omp(k,:,:)  = q(k+offset,:,:)
+      wflux_omp(k,:)= wflux(k+offset,:)
+    ENDDO   
+  
+    CALL physiq  (klon,      &
+                  klev,      &
+                  nqtot,     &
+                  t_name,    &
+                  debut,     &
+                  lafin,     &
+                  day,       &
+                  time,      &
+                  dtphy,     &
+                  plev_omp,  &
+                  play_omp,  &
+                  phi_omp,   &
+                  ulon_omp,  &
+                  ulat_omp,  &
+                  T_omp,     &
+                  q_omp,     &
+                  wflux_omp, &
+                  du_omp,    &
+                  dv_omp,    &
+                  dt_omp,    &
+                  dq_omp,    &
+                  dps_omp,   &
+                  tracerdyn)
+ 
+    DO k=1,klon_omp
+      du(k+offset,:) = du_omp(k,:)
+      dv(k+offset,:) = dv_omp(k,:)
+      dq(k+offset,:,:) = dq_omp(k,:,:)
+      dT(k+offset,:) = dT_omp(k,:)
+      dps(k+offset) = dps_omp(k)
+   ENDDO
+  debut=.FALSE.
+  
+END SUBROUTINE calfis_icosa
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/calfis_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/calfis_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/calfis_p.F	(revision 222)
@@ -0,0 +1,1443 @@
+!
+! $Id: calfis_p.F 1407 2010-07-07 10:31:52Z fairhead $
+!
+C
+C
+      SUBROUTINE calfis_p(lafin,
+     $                  jD_cur, jH_cur,
+     $                  pucov,
+     $                  pvcov,
+     $                  pteta,
+     $                  pq,
+     $                  pmasse,
+     $                  pps,
+     $                  pp,
+     $                  ppk,
+     $                  pphis,
+     $                  pphi,
+     $                  pducov,
+     $                  pdvcov,
+     $                  pdteta,
+     $                  pdq,
+     $                  flxw,
+     $                  pdufi,
+     $                  pdvfi,
+     $                  pdhfi,
+     $                  pdqfi,
+     $                  pdpsfi)
+#ifdef CPP_PHYS
+! Ehouarn: if using (parallelized) physics
+      USE dimphy
+      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
+      USE mod_interface_dyn_phys
+!      USE IOPHY
+#endif
+      USE parallel_lmdz, ONLY : omp_chunk, using_mpi, AllGather_Field
+      USE Write_Field
+      Use Write_field_p
+      USE Times
+      USE infotrac, ONLY: nqtot, niadv, tname
+      USE control_mod, ONLY: planet_type, nsplit_phys
+      USE cpdet_mod, only: tpot2t_p, t2tpot_p
+
+! used only for zonal averages
+      USE moyzon_mod
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   1. rearrangement des tableaux et transformation
+c      variables dynamiques  >  variables physiques
+c   2. calcul des termes physiques
+c   3. retransformation des tendances physiques en tendances dynamiques
+c
+c   remarques:
+c   ----------
+c
+c    - les vents sont donnes dans la physique par leurs composantes 
+c      naturelles.
+c    - la variable thermodynamique de la physique est une variable
+c      intensive :   T 
+c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+c    - les deux seules variables dependant de la geometrie necessaires
+c      pour la physique sont la latitude pour le rayonnement et 
+c      l'aire de la maille quand on veut integrer une grandeur 
+c      horizontalement.
+c    - les points de la physique sont les points scalaires de la 
+c      la dynamique; numerotation:
+c          1 pour le pole nord
+c          (jjm-1)*iim pour l'interieur du domaine
+c          ngridmx pour le pole sud
+c      ---> ngridmx=2+(jjm-1)*iim
+c
+c     Input :
+c     -------
+c       ecritphy        frequence d'ecriture (en jours)de histphy
+c       pucov           covariant zonal velocity
+c       pvcov           covariant meridional velocity 
+c       pteta           potential temperature
+c       pps             surface pressure
+c       pmasse          masse d'air dans chaque maille
+c       pts             surface temperature  (K)
+c       callrad         clef d'appel au rayonnement
+c
+c    Output :
+c    --------
+c        pdufi          tendency for the natural zonal velocity (ms-1)
+c        pdvfi          tendency for the natural meridional velocity 
+c        pdhfi          tendency for the potential temperature (K/s)
+c        pdtsfi         tendency for the surface temperature
+c
+c        pdtrad         radiative tendencies  \  both input
+c        pfluxrad       radiative fluxes      /  and output
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "logic.h"
+
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+c    Arguments :
+c    -----------
+      LOGICAL,INTENT(IN) ::  lafin ! .true. for the very last call to physics
+      REAL,INTENT(IN) :: jD_cur, jH_cur
+      REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
+      REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
+      REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
+      REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
+      REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
+      REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
+      REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
+
+      REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
+      REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
+      REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
+! commentaire SL: pdq ne sert que pour le calcul de pcvgq,
+! qui lui meme ne sert a rien dans la routine telle qu'elle est
+! ecrite, et que j'ai donc commente....
+      REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
+      ! NB: pdq is only used to compute pcvgq which is in fact not used...
+
+      REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
+      REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
+      REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
+      REAL,INTENT(IN) :: flxw(iip1,jjp1,llm)  ! Vertical mass flux on dynamics grid
+
+      ! tendencies (in */s) from the physics
+      REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
+      REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
+      REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
+      REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
+      REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
+
+#ifdef CPP_PHYS
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq,iiq
+      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
+      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
+
+      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
+! ADAPTATION GCM POUR CP(T)
+      REAL,ALLOCATABLE,SAVE :: zteta(:,:)
+      REAL,ALLOCATABLE,SAVE ::  zpk(:,:)
+
+! Ces calculs ne servent pas. 
+! Si necessaire, decommenter ces variables et les calculs...
+!      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
+!      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
+
+      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zpk_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
+      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
+      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) 
+      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
+      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Introduction du splitting (FH)
+! Question pour Yann :
+! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent
+! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il
+! soit allocatable (plutot par exemple que de passer une dimension
+! dépendant du process en argument des routines) et que, du coup,
+! le SAVE évite d'avoir à refaire l'allocation à chaque appel.
+! Tu confirmes ?
+! J'ai suivi le même principe pour les zdufic_omp
+! Mais c'est surement bien que tu controles.
+! 
+
+      REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:)
+      REAL jH_cur_split,zdt_split
+      LOGICAL debut_split,lafin_split
+      INTEGER isplit
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zpk_omp,zphi_omp,zphis_omp,
+c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
+c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
+c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp,
+c$OMP+                 zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp)       
+
+      LOGICAL,SAVE :: first_omp=.true.
+c$OMP THREADPRIVATE(first_omp)
+      
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+      save unskap
+
+      REAL SSUM
+
+      LOGICAL,SAVE :: firstcal=.true., debut=.true.
+c$OMP THREADPRIVATE(firstcal,debut)
+      
+      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
+      INTEGER :: ierr
+#ifdef CPP_MPI
+      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
+#else
+      INTEGER,dimension(1,4) :: Status
+#endif
+      INTEGER, dimension(4) :: Req
+      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
+      integer :: k,kstart,kend
+      INTEGER :: offset  
+
+      LOGICAL tracerdyn ! for generic/mars physics call ; possibly to get rid of
+
+! For Titan only right now: 
+! to allow for 2D computation of microphys and chemistry
+      LOGICAL,save :: flag_moyzon
+      REAL,allocatable,save :: tmpvar(:,:)
+      REAL,allocatable,save :: tmpvarp1(:,:)
+      REAL,allocatable,save :: tmpvarbar(:)
+      REAL,allocatable,save :: tmpvarbarp1(:)
+      real :: zz1,zz2
+
+c-----------------------------------------------------------------------
+
+c    1. Initialisations :
+c    --------------------
+
+
+      klon=klon_mpi
+      
+      IF ( firstcal )  THEN
+        debut = .TRUE.
+        IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         write(lunout,*) 'STOP dans calfis'
+         write(lunout,*) 
+     &   'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         write(lunout,*) '  ngridmx  jjm   iim   '
+         write(lunout,*) ngridmx,jjm,iim
+         STOP
+        ENDIF
+
+        unskap   = 1./ kappa
+
+c$OMP MASTER
+        flag_moyzon = .false.
+        if(moyzon_ch.or.moyzon_mu) then
+         flag_moyzon = .true.
+         allocate(tmpvar(iip1,llm))
+         allocate(tmpvarp1(iip1,llmp1))
+         allocate(tmpvarbar(llm))
+         allocate(tmpvarbarp1(llmp1))
+        endif
+
+      ALLOCATE(zpsrf(klon))
+      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
+      ALLOCATE(zphi(klon,llm),zphis(klon))
+      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
+      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
+!      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
+!      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
+      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
+      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
+      ALLOCATE(zdpsrf(klon))
+      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
+      ALLOCATE(flxwfi(klon,llm))
+! ADAPTATION GCM POUR CP(T)
+      ALLOCATE(zteta(klon,llm))
+      ALLOCATE(zpk(klon,llm))
+
+      ! zonal means. horizontal dimension should be iip1
+      if (flag_moyzon) call moyzon_init(klon,llm,nqtot)
+
+c------------------------------------------------------------------
+c moyennes globales pour les profils de pression et de temperature
+      if(planet_type.eq."titan".or.planet_type.eq."venus") then
+        call AllGather_Field(pp,iip1*jjp1,llmp1)
+        call AllGather_Field(pteta,iip1*jjp1,llm)
+        call AllGather_Field(ppk,iip1*jjp1,llm)
+        call AllGather_Field(pphi,iip1*jjp1,llm)
+        call AllGather_Field(pphis,iip1*jjp1,1)
+        ALLOCATE(plevmoy(llm+1))
+        ALLOCATE(playmoy(llm))
+        ALLOCATE(tmoy(llm))
+        ALLOCATE(tetamoy(llm))
+        ALLOCATE(pkmoy(llm))
+        ALLOCATE(phimoy(0:llm))
+        ALLOCATE(zlevmoy(llm+1))
+        ALLOCATE(zlaymoy(llm))
+        plevmoy=0.
+        do l=1,llmp1
+         do i=1,iip1
+          do j=1,jjp1
+            plevmoy(l)=plevmoy(l)+pp(i,j,l)/(iip1*jjp1)
+          enddo
+         enddo
+        enddo
+        tetamoy=0.
+        pkmoy=0.
+        phimoy=0.
+        do i=1,iip1
+         do j=1,jjp1
+            phimoy(0)=phimoy(0)+pphis(i,j)/(iip1*jjp1)
+         enddo
+        enddo
+        do l=1,llm
+         do i=1,iip1
+          do j=1,jjp1
+            tetamoy(l)=tetamoy(l)+pteta(i,j,l)/(iip1*jjp1)
+            pkmoy(l)=pkmoy(l)+ppk(i,j,l)/(iip1*jjp1)
+            phimoy(l)=phimoy(l)+pphi(i,j,l)/(iip1*jjp1)
+          enddo
+         enddo
+        enddo
+        playmoy(:) = preff * (pkmoy(:)/cpp) ** unskap
+        call tpot2t_p(1,llm,tetamoy,tmoy,pkmoy)
+c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE:
+        zlaymoy(:) = g*rad*rad/(g*rad-phimoy(:))-rad
+        zlevmoy(1) = phimoy(0)/g
+        DO l=2,llm
+            zz1=(playmoy(l-1)+plevmoy(l))/(playmoy(l-1)-plevmoy(l))
+            zz2=(plevmoy(l)  +playmoy(l))/(plevmoy(l)  -playmoy(l))
+            zlevmoy(l)=(zz1*zlaymoy(l-1)+zz2*zlaymoy(l))/(zz1+zz2)
+        ENDDO
+        zlevmoy(llmp1)=zlaymoy(llm)+(zlaymoy(llm)-zlevmoy(llm))
+c-------------------
+c + lat index
+        allocate(klat(klon))
+        do ig0=1,klon
+          j=index_j(ig0)
+          klat(ig0)=j
+        enddo
+      endif   ! planet_type=titan
+c------------------------------------------------------------------
+
+c$OMP END MASTER
+c$OMP BARRIER	  
+      ELSE
+          debut = .FALSE.
+      ENDIF
+
+
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+
+c$OMP MASTER
+      call start_timer(timer_physic)
+c$OMP END MASTER
+
+c$OMP MASTER             
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+      do ig0=1,klon
+        i=index_i(ig0)
+        j=index_j(ig0)
+        zpsrf(ig0)=pps(i,j)
+      enddo
+c$OMP END MASTER
+
+
+c   42. pression intercouches et fonction d'Exner:
+
+c   -----------------------------------------------------------------
+c     .... zplev  definis aux (llm +1) interfaces des couches  ....
+c     .... zplay  definis aux (  llm )    milieux des couches  .... 
+c   -----------------------------------------------------------------
+
+c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+
+c      print *,omp_rank,'klon--->',klon
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llmp1
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zplev( ig0,l ) = pp(i,j,l)
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+      if (flag_moyzon) then
+        call AllGather_Field(pp,iip1*jjp1,llmp1)
+        j=index_j(1)
+        tmpvarp1(:,:) = pp(:,j,:)
+        call moyzon(llmp1,tmpvarp1,tmpvarbarp1)
+        zplevbar_mpi(1,:) = tmpvarbarp1
+        do ig0=2,klon
+          j=index_j(ig0)
+          if (j.ne.index_j(ig0-1)) then
+            tmpvarp1(:,:) = pp(:,j,:)
+            call moyzon(llmp1,tmpvarp1,tmpvarbarp1)
+            zplevbar_mpi(ig0,:) = tmpvarbarp1
+          else
+            zplevbar_mpi(ig0,:) = zplevbar_mpi(ig0-1,:)
+          endif
+        enddo
+      endif
+
+! ADAPTATION GCM POUR CP(T)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zpk(ig0,l)=ppk(i,j,l)
+          zteta(ig0,l)=pteta(i,j,l)
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+      if (flag_moyzon) then
+        call AllGather_Field(pteta,iip1*jjp1,llm)
+        call AllGather_Field(ppk,iip1*jjp1,llm)
+        j=index_j(1)
+        tmpvar(:,:) = pteta(:,j,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        ztetabar_mpi(1,:) = tmpvarbar
+        tmpvar(:,:) = ppk(:,j,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zpkbar_mpi(1,:) = tmpvarbar
+        call tpot2t_p(1,llm,ztetabar_mpi(1,:),ztfibar_mpi(1,:),
+     &                      zpkbar_mpi(1,:))
+        do ig0=2,klon
+          j=index_j(ig0)
+          if (j.ne.index_j(ig0-1)) then
+            tmpvar(:,:) = pteta(:,j,:)
+            call moyzon(llm,tmpvar,tmpvarbar)
+            ztetabar_mpi(ig0,:) = tmpvarbar
+            tmpvar(:,:) = ppk(:,j,:)
+            call moyzon(llm,tmpvar,tmpvarbar)
+            zpkbar_mpi(ig0,:) = tmpvarbar
+            call tpot2t_p(1,llm,ztetabar_mpi(ig0,:),ztfibar_mpi(ig0,:),
+     &                          zpkbar_mpi(ig0,:))
+          else
+            zpkbar_mpi(ig0,:)   = zpkbar_mpi(ig0-1,:)
+            ztetabar_mpi(ig0,:) = ztetabar_mpi(ig0-1,:)
+            ztfibar_mpi(ig0,:)  = ztfibar_mpi(ig0-1,:)
+          endif
+        enddo
+      endif
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+
+! ADAPTATION GCM POUR CP(T)
+         call tpot2t_p(klon,llm,zteta,ztfi,zpk)
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        do ig0=1,klon
+          i=index_i(ig0)
+          j=index_j(ig0)
+          pksurcp        = ppk(i,j,l) / cpp
+          zplay(ig0,l)   = preff * pksurcp ** unskap
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+      if (flag_moyzon) then
+        zplaybar_mpi(:,:) = preff * (zpkbar_mpi(:,:)/cpp)**unskap
+      endif
+
+c   43.bis traceurs (tous intensifs)
+c   ---------------
+
+      DO iq=1,nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+             zqfi(ig0,l,iq)  = pq(i,j,l,iq)
+           enddo
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO ! of DO iq=1,nqtot
+      if (flag_moyzon) then
+       DO iq=1,nqtot
+         call AllGather_Field(pq(:,:,:,iq),iip1*jjp1,llm)
+         j=index_j(1)
+         tmpvar(:,:) = pq(:,j,:,iq)
+         call moyzon(llm,tmpvar,tmpvarbar)
+         zqfibar_mpi(1,:,iq) = tmpvarbar
+         do ig0=2,klon
+          j=index_j(ig0)
+          if (j.ne.index_j(ig0-1)) then
+            tmpvar(:,:) = pq(:,j,:,iq)
+            call moyzon(llm,tmpvar,tmpvarbar)
+            zqfibar_mpi(ig0,:,iq) = tmpvarbar
+          else
+            zqfibar_mpi(ig0,:,iq) = zqfibar_mpi(ig0-1,:,iq)
+          endif
+        enddo
+       ENDDO ! of DO iq=1,nqtot
+      endif
+
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
+
+      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
+
+c$OMP BARRIER
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+	 DO ig=1,klon
+	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
+	 ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      if (flag_moyzon) then
+        call AllGather_Field(pphis,iip1*jjp1,1)
+        call AllGather_Field(pphi,iip1*jjp1,llm)
+        j=index_j(1)
+        tmpvar(:,1) = pphis(:,j)
+        call moyzon(1,tmpvar(:,1),tmpvarbar(1))
+        zphisbar_mpi(1) = tmpvarbar(1)
+        tmpvar(:,:) = pphi(:,j,:)
+        call moyzon(llm,tmpvar,tmpvarbar)
+        zphibar_mpi(1,:) = tmpvarbar-zphisbar_mpi(1)
+        do ig0=2,klon
+          j=index_j(ig0)
+          if (j.ne.index_j(ig0-1)) then
+            tmpvar(:,1) = pphis(:,j)
+            call moyzon(1,tmpvar(:,1),tmpvarbar(1))
+            zphisbar_mpi(ig0) = tmpvarbar(1)
+            tmpvar(:,:) = pphi(:,j,:)
+            call moyzon(llm,tmpvar,tmpvarbar)
+            zphibar_mpi(ig0,:) = tmpvarbar-zphisbar_mpi(ig0)
+          else
+            zphisbar_mpi(ig0)  = zphisbar_mpi(ig0-1)
+            zphibar_mpi(ig0,:) = zphibar_mpi(ig0-1,:)
+          endif
+        enddo
+      endif
+
+c
+c   45. champ u:
+c   ------------
+
+      kstart=1
+      kend=klon
+      
+      if (is_north_pole) kstart=2
+      if (is_south_pole) kend=klon-1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!CDIR SPARSE
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          if (i==1) then
+            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
+     $                         + pucov(1,j,l)/cu(1,j) )
+          else
+            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j) 
+     $                       + pucov(i,j,l)/cu(i,j) )
+          endif
+        enddo
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   46.champ v:
+c   -----------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+        DO ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1) 
+     $                       + pvcov(i,j,l)/cv(i,j) )
+    
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   47. champs de vents aux pole nord   
+c   ------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      if (is_north_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+
+           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+           DO i=2,iim
+              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+           ENDDO
+  
+           DO i=1,iim
+              zcos(i)   = COS(rlonv(i))*z1(i)
+              zsin(i)   = SIN(rlonv(i))*z1(i)
+           ENDDO
+  
+           zufi(1,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+  
+        ENDDO
+c$OMP END DO NOWAIT      
+      endif
+
+
+c   48. champs de vents aux pole sud:
+c   ---------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      if (is_south_pole) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+  
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+           DO i=2,iim
+             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+	   ENDDO
+  
+           DO i=1,iim
+              zcos(i)    = COS(rlonv(i))*z1(i)
+              zsin(i)    = SIN(rlonv(i))*z1(i)
+	   ENDDO
+  
+           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
+           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
+        ENDDO
+c$OMP END DO NOWAIT       
+      endif
+
+c On change de grille, dynamique vers physiq, pour le flux de masse verticale
+      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+! Appel de la physique: pose probleme quand on tourne 
+! SANS physique, car physiq.F est dans le repertoire phy[]... 
+! Il faut une cle CPP_PHYS
+
+! Le fait que les arguments de physiq soient differents selon les planetes 
+! ne pose pas de probleme a priori.
+
+
+c$OMP BARRIER
+      if (first_omp) then
+        klon=klon_omp
+
+        allocate(zplev_omp(klon,llm+1))
+        allocate(zplay_omp(klon,llm))
+        allocate(zpk_omp(klon,llm))
+        allocate(zphi_omp(klon,llm))
+        allocate(zphis_omp(klon))
+        allocate(presnivs_omp(llm))
+        allocate(zufi_omp(klon,llm))
+        allocate(zvfi_omp(klon,llm))
+        allocate(ztfi_omp(klon,llm))
+        allocate(zqfi_omp(klon,llm,nqtot))
+        allocate(zdufi_omp(klon,llm))
+        allocate(zdvfi_omp(klon,llm))
+        allocate(zdtfi_omp(klon,llm))
+        allocate(zdqfi_omp(klon,llm,nqtot))
+        allocate(zdufic_omp(klon,llm))
+        allocate(zdvfic_omp(klon,llm))
+        allocate(zdtfic_omp(klon,llm))
+        allocate(zdqfic_omp(klon,llm,nqtot))
+        allocate(zdpsrf_omp(klon))
+        allocate(flxwfi_omp(klon,llm))
+
+        if (flag_moyzon) call moyzon_init_omp(klon,llm,nqtot)
+
+	first_omp=.false.
+      endif
+       
+	   
+      klon=klon_omp
+      offset=klon_omp_begin-1
+      
+      do l=1,llm+1
+        do i=1,klon
+          zplev_omp(i,l)=zplev(offset+i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay_omp(i,l)=zplay(offset+i,l)
+	enddo 
+      enddo
+	
+       do l=1,llm
+        do i=1,klon  
+	  zpk_omp(i,l)=zpk(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi_omp(i,l)=zphi(offset+i,l)
+	enddo 
+      enddo
+	
+      do i=1,klon
+	zphis_omp(i)=zphis(offset+i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs_omp(l)=presnivs(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi_omp(i,l)=zufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi_omp(i,l)=zvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi_omp(i,l)=ztfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi_omp(i,l)=zdufi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi_omp(i,l)=zdvfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi_omp(i,l)=zdtfi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf_omp(i)=zdpsrf(offset+i)
+      enddo 
+
+      do l=1,llm
+        do i=1,klon
+          flxwfi_omp(i,l)=flxwfi(offset+i,l)
+	enddo 
+      enddo
+
+      if (flag_moyzon) then
+       do l=1,llm+1
+        do i=1,klon
+          zplevbar(i,l)=zplevbar_mpi(offset+i,l)
+	enddo 
+       enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplaybar(i,l)=zplaybar_mpi(offset+i,l)
+	enddo 
+       enddo
+	
+       do l=1,llm
+        do i=1,klon
+	  zphibar(i,l)=zphibar_mpi(offset+i,l)
+	enddo 
+       enddo
+		
+      do i=1,klon
+	zphisbar(i)=zphisbar_mpi(offset+i)
+      enddo 
+     
+      do l=1,llm
+        do i=1,klon
+	  ztfibar(i,l)=ztfibar_mpi(offset+i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfibar(i,l,iq)=zqfibar_mpi(offset+i,l,iq)
+	  enddo
+	enddo 
+       enddo
+      endif
+
+      
+c$OMP BARRIER
+
+!$OMP MASTER
+!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
+!$OMP END MASTER
+      zdt_split=dtphys/nsplit_phys
+      zdufic_omp(:,:)=0.
+      zdvfic_omp(:,:)=0.
+      zdtfic_omp(:,:)=0.
+      zdqfic_omp(:,:,:)=0.
+
+#ifdef CPP_PHYS
+      do isplit=1,nsplit_phys
+
+         jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
+         debut_split=debut.and.isplit==1
+         lafin_split=lafin.and.isplit==nsplit_phys
+
+
+      if (planet_type=="earth") then
+        CALL physiq (klon,
+     .             llm,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_split,
+     .             zdt_split,
+     .             zplev_omp,
+     .             zplay_omp,
+     .             zphi_omp,
+     .             zphis_omp,
+     .             presnivs_omp,
+     .             zufi_omp,
+     .             zvfi_omp,
+     .             ztfi_omp,
+     .             zqfi_omp,
+c#ifdef INCA
+     .             flxwfi_omp,
+c#endif
+     .             zdufi_omp,
+     .             zdvfi_omp,
+     .             zdtfi_omp,
+     .             zdqfi_omp,
+     .             zdpsrf_omp,
+     .             pducov)
+
+      else if ( planet_type=="generic" ) then
+
+      CALL physiq (klon,     !! ngrid
+     .             llm,            !! nlayer
+     .             nqtot,          !! nq
+     .             tname,          !! tracer names from dynamical core (given in infotrac)
+     .             debut_split,    !! firstcall 
+     .             lafin_split,    !! lastcall
+     .             jD_cur,         !! pday. see leapfrog_p 
+     .             jH_cur_split,   !! ptime "fraction of day"
+     .             zdt_split,      !! ptimestep
+     .             zplev_omp,  !! pplev
+     .             zplay_omp,  !! pplay
+     .             zphi_omp,   !! pphi
+     .             zufi_omp,   !! pu
+     .             zvfi_omp,   !! pv
+     .             ztfi_omp,   !! pt
+     .             zqfi_omp,   !! pq
+     .             flxwfi_omp, !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
+     .             zdufi_omp,  !! pdu
+     .             zdvfi_omp,  !! pdv
+     .             zdtfi_omp,  !! pdt
+     .             zdqfi_omp,  !! pdq
+     .             zdpsrf_omp, !! pdpsrf
+     .             tracerdyn)      !! tracerdyn <-- utilite ???
+
+      else if ( planet_type=="mars" ) then
+
+        CALL physiq (klon,       ! ngrid
+     .             llm,          ! nlayer
+     .             nqtot,        ! nq
+     .             debut_split,  ! firstcall
+     .             lafin_split,  ! lastcall
+     .             jD_cur,       ! pday
+     .             jH_cur_split, ! ptime
+     .             zdt_split,    ! ptimestep
+     .             zplev_omp,    ! pplev
+     .             zplay_omp,    ! pplay
+     .             zphi_omp,     ! pphi
+     .             zufi_omp,     ! pu
+     .             zvfi_omp,     ! pv
+     .             ztfi_omp,     ! pt
+     .             zqfi_omp,     ! pq
+     .             flxwfi_omp,   ! pw
+     .             zdufi_omp,    ! pdu
+     .             zdvfi_omp,    ! pdv
+     .             zdtfi_omp,    ! pdt
+     .             zdqfi_omp,    ! pdq
+     .             zdpsrf_omp,   ! pdpsrf
+     .             tracerdyn)    ! tracerdyn (somewhat obsolete)
+
+      else if ((planet_type=="titan").or.(planet_type=="venus")) then
+
+        CALL physiq (klon,
+     .             llm,
+     .             nqtot,
+     .             debut_split,
+     .             lafin_split,
+     .             jD_cur,
+     .             jH_cur_split,
+     .             zdt_split,
+     .             zplev_omp,
+     .             zplay_omp,
+     .             zpk_omp,
+     .             zphi_omp,
+     .             zphis_omp,
+     .             presnivs_omp,
+     .             zufi_omp,
+     .             zvfi_omp,
+     .             ztfi_omp,
+     .             zqfi_omp,
+     .             flxwfi_omp,
+     .             zdufi_omp,
+     .             zdvfi_omp,
+     .             zdtfi_omp,
+     .             zdqfi_omp,
+     .             zdpsrf_omp)
+
+      else ! unknown "planet_type"
+
+        write(lunout,*) "calfis_p: error, unknown planet_type: ",
+     &                  trim(planet_type)
+        stop
+
+      endif ! planet_type
+         zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split
+         zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split
+         ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split
+         zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split
+
+         zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:)
+         zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:)
+         zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:)
+         zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:)
+
+      enddo
+
+#endif
+! of #ifdef CPP_PHYS
+
+      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
+      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys
+      zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys
+      zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys
+
+c$OMP BARRIER
+
+      do l=1,llm+1
+        do i=1,klon
+          zplev(offset+i,l)=zplev_omp(i,l)
+	enddo 
+      enddo
+	  
+       do l=1,llm
+        do i=1,klon  
+	  zplay(offset+i,l)=zplay_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zphi(offset+i,l)=zphi_omp(i,l)
+	enddo 
+      enddo
+	
+
+      do i=1,klon
+	zphis(offset+i)=zphis_omp(i)
+      enddo 
+     
+	
+      do l=1,llm
+        presnivs(l)=presnivs_omp(l)
+      enddo 
+	
+      do l=1,llm
+        do i=1,klon
+	  zufi(offset+i,l)=zufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zvfi(offset+i,l)=zvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  ztfi(offset+i,l)=ztfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdufi(offset+i,l)=zdufi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+	  zdvfi(offset+i,l)=zdvfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do l=1,llm
+        do i=1,klon
+          zdtfi(offset+i,l)=zdtfi_omp(i,l)
+	enddo 
+      enddo
+	
+      do iq=1,nqtot
+        do l=1,llm
+          do i=1,klon
+	    zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
+	  enddo 
+        enddo
+      enddo
+      	
+      do i=1,klon
+	zdpsrf(offset+i)=zdpsrf_omp(i)
+      enddo 
+      
+
+      klon=klon_mpi
+500   CONTINUE
+c$OMP BARRIER
+
+c$OMP MASTER
+      call stop_timer(timer_physic)
+c$OMP END MASTER
+
+      IF (using_mpi) THEN
+            
+      if (MPI_rank>0) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+       DO l=1,llm      
+        du_send(1:iim,l)=zdufi(1:iim,l)
+        dv_send(1:iim,l)=zdvfi(1:iim,l)
+       ENDDO
+c$OMP END DO NOWAIT       
+
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER
+!$OMP CRITICAL (MPI)
+        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
+     &                   COMM_LMDZ,Req(1),ierr)
+        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
+     &                  COMM_LMDZ,Req(2),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+c$OMP BARRIER
+     
+      endif
+   
+      if (MPI_rank<MPI_Size-1) then
+c$OMP BARRIER
+#ifdef CPP_MPI 
+c$OMP MASTER      
+!$OMP CRITICAL (MPI)
+        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
+     &                 COMM_LMDZ,Req(3),ierr)
+        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
+     &                 COMM_LMDZ,Req(4),ierr)
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+      endif
+
+c$OMP BARRIER
+
+
+#ifdef CPP_MPI 
+c$OMP MASTER    
+!$OMP CRITICAL (MPI)
+      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
+        call MPI_WAITALL(4,Req(1),Status,ierr)
+      else if (MPI_rank>0) then
+        call MPI_WAITALL(2,Req(1),Status,ierr)
+      else if (MPI_rank <MPI_Size-1) then
+        call MPI_WAITALL(2,Req(3),Status,ierr)
+      endif
+!$OMP END CRITICAL (MPI)
+c$OMP END MASTER
+#endif
+
+c$OMP BARRIER     
+
+      ENDIF ! using_mpi
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+            
+        zdufi2(1:klon,l)=zdufi(1:klon,l)
+        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
+            
+        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
+        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l) 
+  
+         pdhfi(:,jj_begin,l)=0
+         pdqfi(:,jj_begin,l,:)=0
+         pdufi(:,jj_begin,l)=0
+         pdvfi(:,jj_begin,l)=0
+         
+         if (.not. is_south_pole) then
+           pdhfi(:,jj_end,l)=0
+           pdqfi(:,jj_end,l,:)=0
+           pdufi(:,jj_end,l)=0
+           pdvfi(:,jj_end,l)=0
+         endif
+      
+       ENDDO 
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+       pdpsfi(:,jj_begin)=0    
+       if (.not. is_south_pole) then
+	 pdpsfi(:,jj_end)=0
+       endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
+c
+c   62. enthalpie potentielle
+c   ---------------------
+
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1
+      
+! ADAPTATION GCM POUR CP(T)
+      call t2tpot_p(klon,llm,ztfi,zteta,zpk)
+
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+          i=index_i(ig0)
+          j=index_j(ig0)
+!          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
+          pdhfi(i,j,l) = (zteta(ig0,l) - pteta(i,j,l))/dtphys
+!          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
+          if (i==1) then
+            pdhfi(iip1,j,l) = (zteta(ig0,l) - pteta(i,j,l))/dtphys
+          endif
+         enddo          
+
+        if (is_north_pole) then
+            DO i=1,iip1
+!              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+              pdhfi(i,1,l)    = (zteta(1,l) - pteta(i,1,l))/dtphys
+            enddo
+        endif
+        
+        if (is_south_pole) then
+            DO i=1,iip1
+!              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
+              pdhfi(i,jjp1,l) = (zteta(klon,l) - pteta(i,jjp1,l))/dtphys
+            ENDDO
+        endif
+      ENDDO
+c$OMP END DO NOWAIT
+      
+c   62. humidite specifique
+c   ---------------------
+! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+!      DO iq=1,nqtot
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!         DO l=1,llm
+!!!cdir NODEP 
+!           do ig0=kstart,kend
+!             i=index_i(ig0)
+!             j=index_j(ig0)
+!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq) 
+!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq) 
+!           enddo
+!           
+!           if (is_north_pole) then
+!             do i=1,iip1
+!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
+!             enddo
+!           endif
+!           
+!           if (is_south_pole) then
+!             do i=1,iip1
+!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq) 
+!             enddo
+!           endif
+!         ENDDO
+!c$OMP END DO NOWAIT
+!      ENDDO
+
+c   63. traceurs (tous en intensifs)
+c   ------------
+C     initialisation des tendances
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        pdqfi(:,:,l,:)=0.
+      ENDDO
+c$OMP END DO NOWAIT	 
+
+C
+!cdir NODEP
+      DO iq=1,nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP           
+	     DO ig0=kstart,kend
+              i=index_i(ig0)
+              j=index_j(ig0)
+              pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq)
+              if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq)
+            ENDDO
+	    
+	    IF (is_north_pole) then
+	      DO i=1,iip1
+                pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+	    IF (is_south_pole) then
+	      DO i=1,iip1
+                pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq)
+	      ENDDO
+	    ENDIF
+	    
+         ENDDO
+c$OMP END DO NOWAIT	 
+      ENDDO
+      
+c   65. champ u:
+c   ------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+         do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           
+           if (i/=iim) then
+             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+           
+           if (i==1) then
+              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
+     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
+             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
+           endif
+         
+         enddo
+         
+         if (is_north_pole) then
+           DO i=1,iip1
+            pdufi(i,1,l)    = 0.
+           ENDDO
+         endif
+         
+         if (is_south_pole) then
+           DO i=1,iip1
+            pdufi(i,jjp1,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   67. champ v:
+c   ------------
+
+      kstart=1
+      kend=klon
+
+      if (is_north_pole) kstart=2
+      if (is_south_pole)  kend=klon-1-iim
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+!CDIR ON_ADB(index_i)
+!CDIR ON_ADB(index_j) 
+!cdir NODEP
+        do ig0=kstart,kend
+           i=index_i(ig0)
+           j=index_j(ig0)
+           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
+           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
+     $	                                    zdvfi2(ig0+iim,l))
+     $				          *cv(i,j)
+        enddo
+         
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      v = U * cos(long) + V * SIN(long)
+
+      if (is_north_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l=1,llm
+
+          DO i=1,iim
+            pdvfi(i,1,l)=
+     $      zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
+       
+            pdvfi(i,1,l)=
+     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+          ENDDO
+
+          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+
+      endif    
+      
+      if (is_south_pole) then
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+         DO l=1,llm
+  
+           DO i=1,iim
+              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
+     $        +zdvfi(klon,l)*SIN(rlonv(i))
+
+              pdvfi(i,jjm,l)=
+     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
+           ENDDO
+
+           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+        ENDDO
+c$OMP END DO NOWAIT
+     
+      endif
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+ 
+      firstcal = .FALSE.
+
+#else
+      write(lunout,*)
+     & "calfis_p: for now can only work with parallel physics"
+      stop
+#endif
+! of #ifdef CPP_PHYS
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/ce0l.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/ce0l.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/ce0l.F90	(revision 222)
@@ -0,0 +1,137 @@
+!
+! $Id: ce0l.F90 1984 2014-02-18 09:59:29Z emillour $
+!
+!-------------------------------------------------------------------------------
+!
+PROGRAM ce0l
+!-------------------------------------------------------------------------------
+! Purpose: Calls etat0, creates initial states and limit_netcdf
+!
+!     interbar=.T. for barycentric interpolation inter_barxy
+!     extrap  =.T. for data extrapolation, like for the SSTs when file does not
+!                  contain ocean points only.
+!     oldice  =.T. for old-style ice, obtained using grille_m (grid_atob).
+!     masque is created in etat0, passed to limit to ensure consistancy.
+!-------------------------------------------------------------------------------
+  USE control_mod
+#ifdef CPP_EARTH
+! This prog. is designed to work for Earth
+  USE dimphy
+  USE comgeomphy
+  USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root
+  USE mod_const_mpi
+  USE infotrac
+  USE parallel_lmdz, ONLY: finalize_parallel
+  USE indice_sol_mod
+
+#ifdef CPP_IOIPSL
+  USE ioipsl, ONLY: ioconf_calendar
+#endif
+
+#endif
+  IMPLICIT NONE
+#ifndef CPP_EARTH
+#include "iniprint.h"
+  WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
+#else
+!-------------------------------------------------------------------------------
+! Local variables:
+  LOGICAL, PARAMETER :: interbar=.TRUE., extrap=.FALSE., oldice=.FALSE.
+#include "dimensions.h"
+#include "paramet.h"
+!#include "indicesol.h"
+#include "iniprint.h"
+#include "temps.h"
+#include "logic.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+
+  INTEGER, PARAMETER            :: longcles=20
+  INTEGER                       :: ierr
+  REAL,    DIMENSION(longcles)  :: clesphy0
+  REAL,    DIMENSION(iip1,jjp1) :: masque
+  CHARACTER(LEN=15)             :: calnd
+  REAL,    DIMENSION(iip1,jjp1) :: phis ! geopotentiel au sol
+!-------------------------------------------------------------------------------
+  CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+#ifdef CPP_MPI
+  CALL init_mpi
+#endif
+
+  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+  WRITE(lunout,*)'---> klon=',klon
+  IF (mpi_size>1 .OR. omp_size>1) THEN
+       CALL abort_gcm('ce0l','In parallel mode,                         &
+ &                 ce0l must be called only                             &
+ &                 for 1 process and 1 task',1)
+  ENDIF
+
+  CALL InitComgeomphy
+
+#ifdef CPP_IOIPSL
+  SELECT CASE(calend)
+    CASE('earth_360d');CALL ioconf_calendar('360d');      calnd='a 360 jours/an'
+    CASE('earth_365d');CALL ioconf_calendar('noleap');    calnd='a 365 jours/an'
+    CASE('earth_366d');CALL ioconf_calendar('366d');      calnd='bissextile'
+    CASE('gregorian'); CALL ioconf_calendar('gregorian'); calnd='gregorien'
+    CASE('standard');  CALL ioconf_calendar('gregorian'); calnd='gregorien'
+    CASE('julian');    CALL ioconf_calendar('julian');    calnd='julien'
+    CASE('proleptic_gregorian'); CALL ioconf_calendar('gregorian')
+  !--- DC Bof...  => IOIPSL a mettre a jour: proleptic_gregorian /= gregorian
+    CASE DEFAULT
+      CALL abort_gcm('ce0l','Mauvais choix de calendrier',1)
+  END SELECT
+  WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre '//TRIM(calnd)
+#endif
+
+  IF (type_trac == 'inca') THEN
+#ifdef INCA
+      CALL init_const_lmdz( &
+         nbtr,anneeref,dayref,&
+         iphysiq,day_step,nday,& 
+         nbsrf, is_oce,is_sic,&
+         is_ter,is_lic)
+      
+#endif
+  END IF
+
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,*) '  ***  etat0_netcdf ***  '
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) ' interbar = ',interbar
+  CALL etat0_netcdf(interbar,masque,phis,ok_etat0)
+
+  IF(ok_limit) THEN
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,*) '  ***  Limit_netcdf ***  '
+  WRITE(lunout,*) '  *********************  '
+  WRITE(lunout,'(//)')
+  CALL limit_netcdf(interbar,extrap,oldice,masque)
+  END IF
+
+  WRITE(lunout,'(//)')
+  WRITE(lunout,*) '  ***************************  '
+  WRITE(lunout,*) '  ***  grilles_gcm_netcdf ***  '
+  WRITE(lunout,*) '  ***************************  '
+  WRITE(lunout,'(//)')
+  CALL grilles_gcm_netcdf_sub(masque,phis)
+  
+#ifdef CPP_MPI
+!$OMP MASTER
+  CALL MPI_FINALIZE(ierr)
+  IF (ierr /= 0) CALL abort_gcm('ce0l','Error in MPI_FINALIZE',1)
+!$OMP END MASTER
+#endif
+
+#endif
+! of #ifndef CPP_EARTH #else
+
+END PROGRAM ce0l
+!
+!-------------------------------------------------------------------------------
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/conf_gcm.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/conf_gcm.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/conf_gcm.F	(revision 222)
@@ -0,0 +1,1011 @@
+!
+! $Id: conf_gcm.F 1438 2010-10-08 10:19:34Z jghattas $
+!
+!
+!
+      SUBROUTINE conf_gcm( tapedef, etatinit )
+!
+#ifdef CPP_IOIPSL
+      use IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      use ioipsl_getincom
+#endif
+      use misc_mod
+      use mod_filtre_fft, ONLY : use_filtre_fft
+      use mod_hallo, ONLY : use_mpi_alloc
+      USE control_mod
+      USE infotrac, ONLY : type_trac
+      use assert_m, only: assert
+      use sponge_mod_p, only: callsponge,mode_sponge,nsponge,tetasponge
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!     Auteurs :   L. Fairhead , P. Le Van  .
+!
+!     Arguments :
+!
+!     tapedef   :
+!     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+!     -metres  du zoom  avec  celles lues sur le fichier start .
+!
+       LOGICAL etatinit
+       INTEGER tapedef
+
+!   Declarations :
+!   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "iniprint.h"
+#include "temps.h"
+#include "comconst.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! #include "clesphys.h"
+!
+!
+!   local:
+!   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy, tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      character(len=*),parameter :: modname="conf_gcm"
+      character (len=80) :: abort_message
+#ifdef CPP_OMP
+      integer,external :: OMP_GET_NUM_THREADS
+#endif      
+!
+!  -------------------------------------------------------------------
+!
+!       .........     Version  du 29/04/97       ..........
+!
+!   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+!      tetatemp   ajoutes  pour la dissipation   .
+!
+!   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+!
+!  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+!    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+!
+!   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+!         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+!                de limit.dat ( dic)                        ...........
+!           Sinon  etatinit = . FALSE .
+!
+!   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+!    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+!   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+!    lectba .  
+!   Ces parmetres definissant entre autres la grille et doivent etre
+!   pareils et coherents , sinon il y aura  divergence du gcm .
+!
+!-----------------------------------------------------------------------
+!   initialisations:
+!   ----------------
+
+!Config  Key  = lunout
+!Config  Desc = unite de fichier pour les impressions
+!Config  Def  = 6
+!Config  Help = unite de fichier pour les impressions 
+!Config         (defaut sortie standard = 6)
+      lunout=6
+      CALL getin('lunout', lunout)
+      IF (lunout /= 5 .and. lunout /= 6) THEN
+        OPEN(UNIT=lunout,FILE='lmdz.out_0000',ACTION='write', 
+     &          STATUS='unknown',FORM='formatted')
+
+      ENDIF
+
+      adjust=.false.
+      call getin('adjust',adjust)
+      
+#ifdef CPP_OMP
+      ! adjust=y not implemented in case of OpenMP threads...
+!$OMP PARALLEL
+      if ((OMP_GET_NUM_THREADS()>1).and.adjust) then
+        write(lunout,*)'conf_gcm: Error, adjust should be set to n'
+     &,' when running with OpenMP threads'
+        abort_message = 'Wrong value for adjust'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!$OMP END PARALLEL         
+#endif
+
+      itaumax=0
+      call getin('itaumax',itaumax);
+      if (itaumax<=0) itaumax=HUGE(itaumax)
+      
+!Config  Key  = prt_level
+!Config  Desc = niveau d'impressions de débogage
+!Config  Def  = 0
+!Config  Help = Niveau d'impression pour le débogage
+!Config         (0 = minimum d'impression)
+      prt_level = 0
+      CALL getin('prt_level',prt_level)
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+!Config  Key  = planet_type
+!Config  Desc = planet type ("earth", "mars", "venus", ...)
+!Config  Def  = earth
+!Config  Help = this flag sets the type of atymosphere that is considered
+      planet_type="earth"
+      CALL getin('planet_type',planet_type)
+
+!Config  Key  = calend
+!Config  Desc = type de calendrier utilise
+!Config  Def  = earth_360d
+!Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
+!Config         
+      calend = 'earth_360d'
+      CALL getin('calend', calend)
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = raz_date
+!Config  Desc = Remise a zero de la date initiale
+!Config  Def  = 0 (pas de remise a zero)
+!Config  Help = Remise a zero de la date initiale 
+!Config         0 pas de remise a zero, on garde la date du fichier restart
+!Config         1 prise en compte de la date de gcm.def avec remise a zero
+!Config         des compteurs de pas de temps
+      raz_date = 0
+      CALL getin('raz_date', raz_date)
+
+!Config  Key  = resetvarc
+!Config  Desc = Reinit des variables de controle
+!Config  Def  = n
+!Config  Help = Reinit des variables de controle
+      resetvarc = .false.
+      CALL getin('resetvarc',resetvarc)
+
+!Config  Key  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+      ! alternative to specifying nday (see also 'less1day' and 'fractday'
+      ! options below: sopecify numbre of dynamic steps to run:
+      ndynstep = -9999 ! default value ; if ndynstep <0 then option not used.
+      call getin('ndynstep',ndynstep)
+      
+!Config  Key  = starttime
+!Config  Desc = Heure de depart de la simulation
+!Config  Def  = 0
+!Config  Help = Heure de depart de la simulation
+!Config         en jour
+      starttime = 0
+      CALL getin('starttime',starttime)
+
+      ! Mars: time of start for run in "start.nc" (when there are multiple time
+      !       steps stored in the file)
+      timestart=-9999 ! default value; if <0, use last stored time
+      call getin("timestart",timestart)
+      
+!Config  Key  = less1day
+!Config  Desc = Possibilite d'integrer moins d'un jour
+!Config  Def  = n
+!Config  Help = Possibilite d'integrer moins d'un jour
+      less1day = .false.
+      CALL getin('less1day',less1day)
+
+!Config  Key  = fractday
+!Config  Desc = integration sur une fraction de jour
+!Config  Def  = 0.01
+!Config  Help = integration sur une fraction de jour
+      fractday = 0.01
+      CALL getin('fractday',fractday)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = nsplit_phys
+!Config  Desc = nombre de subdivisions par pas physique
+!Config  Def  = 1
+!Config  Help = nombre de subdivisions par pas physique
+       nsplit_phys = 1 
+       CALL getin('nsplit_phys',nsplit_phys)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps)
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+!Config  Key  = iapp_tracvl
+!Config  Desc = frequence du groupement des flux 
+!Config  Def  = iperiod
+!Config  Help = frequence du groupement des flux (en pas de temps) 
+       iapp_tracvl = iperiod
+       CALL getin('iapp_tracvl',iapp_tracvl)
+
+!Config  Key  = iconser
+!Config  Desc = periode de sortie des variables de controle
+!Config  Def  = 240  
+!Config  Help = periode de sortie des variables de controle
+!Config         (En pas de temps)
+       iconser = 240  
+       CALL getin('iconser', iconser)
+
+!Config  Key  = iecri
+!Config  Desc = periode d'ecriture du fichier histoire
+!Config  Def  = 1
+!Config  Help = periode d'ecriture du fichier histoire (en jour) 
+       iecri = 1
+       CALL getin('iecri',iecri)
+
+
+!Config  Key  = periodav
+!Config  Desc = periode de stockage fichier histmoy
+!Config  Def  = 1
+!Config  Help = periode de stockage fichier histmoy (en jour) 
+       periodav = 1.
+       CALL getin('periodav',periodav)
+
+!Config  Key  = output_grads_dyn
+!Config  Desc = output dynamics diagnostics in 'dyn.dat' file
+!Config  Def  = n
+!Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
+       output_grads_dyn=.false.
+       CALL getin('output_grads_dyn',output_grads_dyn)
+
+!Config  Key  = dissip_period
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 0
+!Config  Help = periode de la dissipation 
+!Config  dissip_period=0 => la valeur sera calcule dans inidissip       
+!Config  dissip_period>0 => on prend cette valeur
+       dissip_period = 0
+       call getin('idissip',dissip_period) ! old Mars/Genreic model parameter
+       ! if there is a "dissip_period" in run.def, it overrides "idissip"
+       CALL getin('dissip_period',dissip_period)
+
+!cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+!cc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+! For Earth model only:
+! Parametres controlant la variation sur la verticale des constantes de
+! dissipation.
+! Pour le moment actifs uniquement dans la version a 39 niveaux
+! avec ok_strato=y
+
+       dissip_factz=4.
+       dissip_deltaz=10.
+       dissip_zref=30.
+       CALL getin('dissip_factz',dissip_factz )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_zref',dissip_zref )
+
+! For other planets:
+! Parametres controlant la variation sur la verticale des constantes de
+! dissipation.
+! Actifs uniquement avec ok_strato=y
+
+       dissip_fac_mid=2.
+       dissip_fac_up=10.
+       dissip_deltaz=10.! Intervalle (km) pour le changement mid / up
+       dissip_hdelta=5. ! scale height (km) dans la zone de la transition(m)
+       dissip_pupstart=1.e3  ! pression (Pa) au bas la transition mid / up
+       CALL getin('dissip_fac_mid',dissip_fac_mid )
+       CALL getin('dissip_fac_up',dissip_fac_up )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_hdelta',dissip_hdelta )
+       CALL getin('dissip_pupstart',dissip_pupstart )
+
+! top_bound sponge: only active if iflag_top_bound!=0
+!                   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
+       iflag_top_bound=0
+       CALL getin('iflag_top_bound',iflag_top_bound)
+
+! mode_top_bound : fields towards which sponge relaxation will be done:
+!                  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
+       mode_top_bound=3
+       CALL getin('mode_top_bound',mode_top_bound)
+
+! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
+       tau_top_bound=1.e-5
+       CALL getin('tau_top_bound',tau_top_bound)
+
+! the other possible sponge layer (sponge_mod)
+       callsponge=.false. ! default value; don't use the sponge
+       call getin("callsponge",callsponge)
+       ! check that user is not trying to use both sponge models
+       if ((iflag_top_bound.ge.1).and.callsponge) then
+         write(lunout,*)'Bad choice of options:'
+         write(lunout,*)' iflag_top_bound=',iflag_top_bound
+         write(lunout,*)' and callsponge=.true.'
+         write(lunout,*)'But both sponge models should not be',
+     &                  ' used simultaneously!'
+         stop
+       endif
+       
+! nsponge: number of atmospheric layers over which the sponge extends
+       nsponge=3 ! default value
+       call getin("nsponge",nsponge)
+
+! mode_sponge: (quenching is towards ... over the upper nsponge layers)
+!      0: (h=hmean,u=v=0)
+!      1: (h=hmean,u=umean,v=0)
+!      2: (h=hmean,u=umean,v=vmean)"
+       mode_sponge=2 ! default value
+       call getin("mode_sponge",mode_sponge)
+
+! tetasponge: characteristic time scale (seconds) at topmost layer
+!            (time scale then doubles with decreasing layer index)."
+       tetasponge=50000.0
+       call getin("tetasponge",tetasponge)
+
+! FOR TITAN: tidal forces
+       tidal=.TRUE.
+       CALL getin('tidal',tidal)
+
+!Config  Key  = coefdis
+!Config  Desc = coefficient pour gamdissip
+!Config  Def  = 0
+!Config  Help = coefficient pour gamdissip  
+       coefdis = 0.
+       CALL getin('coefdis',coefdis)
+
+!Config  Key  = purmats
+!Config  Desc = Schema d'integration
+!Config  Def  = n
+!Config  Help = Choix du schema d'integration temporel.
+!Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+       purmats = .FALSE.
+       CALL getin('purmats',purmats)
+
+!Config  Key  = ok_guide
+!Config  Desc = Guidage
+!Config  Def  = n
+!Config  Help = Guidage
+       ok_guide = .FALSE.
+       CALL getin('ok_guide',ok_guide)
+
+!     ...............................................................
+
+!Config  Key  =  read_start
+!Config  Desc = Initialize model using a 'start.nc' file
+!Config  Def  = y
+!Config  Help = y: intialize dynamical fields using a 'start.nc' file
+!               n: fields are initialized by 'iniacademic' routine
+       read_start= .true.
+       CALL getin('read_start',read_start)
+
+!Config  Key  = iflag_phys
+!Config  Desc = Avec ls physique 
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       iflag_phys = 1
+       CALL getin('iflag_phys',iflag_phys)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+!Config  Key  = iflag_trac
+!Config  Desc = traceurs presents ou non
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans traceurs
+!Config         
+       iflag_trac = 1 
+       CALL getin('iflag_trac',iflag_trac)
+
+!Config  Key  = ip_ebil_dyn
+!Config  Desc = PRINT level for energy conserv. diag.
+!Config  Def  = 0
+!Config  Help = PRINT level for energy conservation diag. ;
+!               les options suivantes existent :
+!Config         0 pas de print
+!Config         1 pas de print
+!Config         2 print,
+       ip_ebil_dyn = 0
+       CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+       IF (offline .AND. adjust) THEN
+          WRITE(lunout,*) 
+     &         'WARNING : option offline does not work with adjust=y :'
+          WRITE(lunout,*) 'the files defstoke.nc, fluxstoke.nc ', 
+     &         'and fluxstokev.nc will not be created'
+          WRITE(lunout,*) 
+     &         'only the file phystoke.nc will still be created ' 
+       END IF
+       
+!Config  Key  = type_trac
+!Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
+!Config  Def  = lmdz
+!Config  Help = 
+!Config         'lmdz' = pas de couplage, pur LMDZ
+!Config         'inca' = model de chime INCA 
+!Config         'repr' = model de chime REPROBUS
+      type_trac = 'lmdz'
+      CALL getin('type_trac',type_trac)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+!Config  Key  = ok_dynzon 
+!Config  Desc = calcul et sortie des transports 
+!Config  Def  = n 
+!Config  Help = Permet de mettre en route le calcul des transports 
+!Config          
+      ok_dynzon = .FALSE. 
+      CALL getin('ok_dynzon',ok_dynzon) 
+
+!Config  Key  = ok_dyn_ins
+!Config  Desc = sorties instantanees dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ins = .FALSE. 
+      CALL getin('ok_dyn_ins',ok_dyn_ins) 
+
+!Config  Key  = ok_dyn_ave
+!Config  Desc = sorties moyennes dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ave = .FALSE. 
+      CALL getin('ok_dyn_ave',ok_dyn_ave) 
+
+!Config  Key  = use_filtre_fft
+!Config  Desc = flag d'activation des FFT pour le filtre
+!Config  Def  = false
+!Config  Help = permet d'activer l'utilisation des FFT pour effectuer
+!Config         le filtrage aux poles. 
+      use_filtre_fft=.FALSE.
+      CALL getin('use_filtre_fft',use_filtre_fft)
+
+      IF (use_filtre_fft .AND. grossismx /= 1.0) THEN
+        write(lunout,*)'WARNING !!! '
+        write(lunout,*)"Le zoom en longitude est incompatible",
+     &                 " avec l'utilisation du filtre FFT ",
+     &                 "---> FFT filter not active"
+       use_filtre_fft=.FALSE.
+      ENDIF
+
+!Config  Key  = use_mpi_alloc
+!Config  Desc = Utilise un buffer MPI en memoire globale
+!Config  Def  = false
+!Config  Help = permet d'activer l'utilisation d'un buffer MPI
+!Config         en memoire globale a l'aide de la fonction MPI_ALLOC.
+!Config         Cela peut ameliorer la bande passante des transferts MPI
+!Config         d'un facteur 2  
+      use_mpi_alloc=.FALSE.
+      CALL getin('use_mpi_alloc',use_mpi_alloc)
+
+!Config key = ok_strato
+!Config  Desc = activation de la version strato
+!Config  Def  = .FALSE.
+!Config  Help = active la version stratosphérique de LMDZ de F. Lott
+
+      ok_strato=.TRUE.
+      CALL getin('ok_strato',ok_strato)
+
+! NB: vert_prof_dissip is Earth-specific; should not impact other models
+      if (planet_type=="earth") then
+       vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
+       CALL getin('vert_prof_dissip', vert_prof_dissip)
+       call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1,
+     $     "bad value for vert_prof_dissip")
+      else
+       vert_prof_dissip=0 ! default for planets !
+       if (planet_type=="mars") then
+         vert_prof_dissip=1 ! use fac_mid & fac_up & startalt & delta
+       endif
+      endif
+
+!Config  Key  = ok_gradsfile
+!Config  Desc = activation des sorties grads du guidage
+!Config  Def  = n
+!Config  Help = active les sorties grads du guidage
+
+       ok_gradsfile = .FALSE.
+       CALL getin('ok_gradsfile',ok_gradsfile)
+
+!Config  Key  = ok_limit
+!Config  Desc = creation des fichiers limit dans create_etat0_limit
+!Config  Def  = y
+!Config  Help = production du fichier limit.nc requise
+
+       ok_limit = .TRUE.
+       CALL getin('ok_limit',ok_limit)
+
+!Config  Key  = ok_etat0
+!Config  Desc = creation des fichiers etat0 dans create_etat0_limit
+!Config  Def  = y
+!Config  Help = production des fichiers start.nc, startphy.nc requise
+
+      ok_etat0 = .TRUE.
+      CALL getin('ok_etat0',ok_etat0)
+
+!----------------------------------------
+! Parameters for zonal averages in the case of Titan
+      moyzon_mu = .false.
+      moyzon_ch = .false.
+      if (planet_type=="titan") then
+       CALL getin('moyzon_mu', moyzon_mu)
+       CALL getin('moyzon_ch', moyzon_ch)
+      endif
+!----------------------------------------
+
+!----------------------------------------
+!cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+!     .........   (  modif  le 17/04/96 )   .........
+!
+! ZOOM PARAMETERS ... the ones read in start.nc prevail anyway ! (SL, 2012)
+!
+!----------------------------------------
+      IF( etatinit ) then
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)
+     &   'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)
+     &  'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
+!
+!    alphax et alphay sont les anciennes formulat. des grossissements
+!
+!
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+!
+!----------------------------------------
+       else ! etatinit=false
+!----------------------------------------
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clonn = 0.
+       CALL getin('clon',clonn)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clatt = 0.
+       CALL getin('clat',clatt)
+
+!
+!
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def',
+     &    ' est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismxx = 1.0
+       CALL getin('grossismx',grossismxx)
+
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ',
+     &  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismyy = 1.0
+       CALL getin('grossismy',grossismyy)
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ',
+     & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)
+     &       'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)
+     &       'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
+!
+!    alphax et alphay sont les anciennes formulat. des grossissements
+!
+!
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+         IF( fxyhypbb )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** fxyhypb lu sur le fichier start est ',
+     *       'F alors  qu il est  T  sur  run.def  ***'
+              STOP
+         ENDIF
+      ELSE
+         IF( .NOT.fxyhypbb )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' ***  fxyhypb lu sur le fichier start est ',
+     *        'T alors  qu il est  F  sur  run.def  ****  '
+              STOP
+         ENDIF
+      ENDIF
+!
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ',
+     *  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomyy = 0.0
+       CALL getin('dzoomy',dzoomyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ',
+     * 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+      
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       tauxx = 3.0
+       CALL getin('taux',tauxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de taux passee par ',
+     * 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = tauyy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauyy = 3.0
+       CALL getin('tauy',tauyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de tauy passee par ',
+     * 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!c
+      IF( .NOT.fxyhypb  )  THEN
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinuss = .TRUE.
+       CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+          IF( ysinuss )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+            STOP
+          ENDIF
+        ELSE
+          IF( .NOT.ysinuss )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est T',
+     *        ' alors  qu il est  F  sur  run.def  ****  '
+              STOP
+          ENDIF
+        ENDIF
+      ENDIF ! of IF( .NOT.fxyhypb  )
+
+      endif ! etatinit
+!----------------------------------------
+
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres lus via run.def '
+      write(lunout,*)' planet_type = ', planet_type
+      write(lunout,*)' calend = ', calend
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      if (ndynstep.ne.-9999) write(lunout,*)' ndynstep = ', ndynstep
+      if (less1day) write(lunout,*)' fractday = ', fractday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' nsplit_phys = ', nsplit_phys
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+      write(lunout,*)' dissip_period = ', dissip_period
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' read_start = ', read_start
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' iflag_trac = ', iflag_trac
+      write(lunout,*)' clon = ', clon
+      write(lunout,*)' clat = ', clat
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypb = ', fxyhypb
+      write(lunout,*)' dzoomx = ', dzoomx
+      write(lunout,*)' dzoomy = ', dzoomy
+      write(lunout,*)' taux = ', taux
+      write(lunout,*)' tauy = ', tauy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' type_trac = ', type_trac
+      write(lunout,*)' config_inca = ', config_inca
+      write(lunout,*)' ok_dynzon = ', ok_dynzon 
+      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
+      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+      write(lunout,*)' use_filtre_fft = ', use_filtre_fft
+      write(lunout,*)' use_mpi_alloc = ', use_mpi_alloc
+      write(lunout,*)' ok_strato = ', ok_strato
+      write(lunout,*)' ok_gradsfile = ', ok_gradsfile
+      write(lunout,*)' ok_limit = ', ok_limit
+      write(lunout,*)' ok_etat0 = ', ok_etat0
+      if (planet_type=="titan") then
+       write(lunout,*)' moyzon_mu = ', moyzon_mu
+       write(lunout,*)' moyzon_ch = ', moyzon_ch
+      endif
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convflu_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convflu_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convflu_p.F	(revision 222)
@@ -0,0 +1,84 @@
+      SUBROUTINE convflu_p( xflu,yflu,nbniv,convfl )
+c
+c  P. Le Van
+c
+c
+c    *******************************************************************
+c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+c      composantes xflu et yflu ,variables extensives .  ......
+c    *******************************************************************
+c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+c      convfl                est  un argument de sortie pour le s-pg .
+c
+c     njxflu  est le nombre de lignes de latitude de xflu, 
+c     ( = jjm ou jjp1 )
+c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      REAL       xflu,yflu,convfl,convpn,convps
+      INTEGER    l,ij,nbniv
+      DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) ,
+     *         convfl( ip1jmp1,nbniv )
+c
+      INTEGER ijb,ije
+      EXTERNAL   SSUM
+      REAL       SSUM
+c
+c
+#include "comgeom.h"
+c
+     
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+      DO 5 l = 1,nbniv
+c
+        ijb=ij_begin
+        ije=ij_end+iip1
+      
+        IF (pole_nord) ijb=ij_begin+iip1
+        IF (pole_sud)  ije=ij_end-iip1
+        
+        DO 2  ij = ijb , ije - 1
+          convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   +
+     *                     yflu(ij +1,l ) - yflu( ij -iim,l )
+   2    CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+        DO 3 ij = ijb,ije,iip1
+          convfl( ij,l ) = convfl( ij + iim,l )
+   3    CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+        IF (pole_nord) THEN
+      
+          convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+        
+          DO ij = 1,iip1
+            convfl(ij,l) = convpn * aire(ij) / apoln
+          ENDDO
+        
+        ENDIF
+      
+        IF (pole_sud) THEN
+        
+          convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+        
+          DO ij = 1,iip1
+            convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
+          ENDDO
+        
+        ENDIF
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT   
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas1_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas1_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas1_p.F	(revision 222)
@@ -0,0 +1,62 @@
+      SUBROUTINE convmas1_p (pbaru, pbarv, convm )
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL, target :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_p( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas2_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas2_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas2_p.F	(revision 222)
@@ -0,0 +1,56 @@
+      SUBROUTINE convmas2_p ( convm )
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+      INTEGER ijb,ije,jjb,jje
+ 
+c$OMP MASTER
+c    integration de la convergence de masse de haut  en bas ......
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+c$OMP END MASTER
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/convmas_p.F	(revision 222)
@@ -0,0 +1,71 @@
+      SUBROUTINE convmas_p (pbaru, pbarv, convm )
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL, target :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_p( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/covcont_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/covcont_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/covcont_p.F	(revision 222)
@@ -0,0 +1,59 @@
+      SUBROUTINE covcont_p (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( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER ijb_u,ijb_v,ije_u,ije_v
+
+      
+      ijb_u=ij_begin-iip1
+      ijb_v=ij_begin-iip1
+      ije_u=ij_end+iip1
+      ije_v=ij_end+iip1
+      
+      if (pole_nord) then 
+        ijb_u=ij_begin+iip1
+        ijb_v=ij_begin
+      endif
+      
+      if (pole_sud) then
+        ije_u=ij_end-iip1
+        ije_v=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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/covnat_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/covnat_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/covnat_p.F	(revision 222)
@@ -0,0 +1,76 @@
+!
+! $Header$
+!
+      SUBROUTINE covnat_p(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( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER :: ijb,ije
+      
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (pole_nord) then
+        DO l = 1,klevel
+           DO ij = 1, iip1
+              unat (ij,l) =0.
+           END DO
+        ENDDO
+      endif
+
+      if (pole_sud) then
+        DO l = 1,klevel
+           DO ij = ip1jm+1, ip1jmp1  
+            unat (ij,l) =0.
+           END DO
+        ENDDO
+      endif
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO l = 1,klevel
+         DO ij = ijb, ije
+            unat( ij,l ) = ucov( ij,l ) / cu(ij)
+         ENDDO
+      END DO
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+     
+      DO l = 1,klevel
+         DO ij = ijb,ije
+            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+         ENDDO
+
+      ENDDO
+      
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dissip_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dissip_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dissip_p.F	(revision 222)
@@ -0,0 +1,215 @@
+!
+! $Id: $
+!
+      SUBROUTINE dissip_p( vcov,ucov,teta,p, dv,du,dh )
+c
+      USE parallel_lmdz
+      USE write_field_p
+      IMPLICIT NONE
+
+
+c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+c                                 (  10/01/98  )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation horizontale
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comdissnew.h"
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
+      REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
+      REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potentail temperature
+      REAL,INTENT(IN) :: p(ip1jmp1,llmp1) ! pressure
+      ! tendencies (.../s) on covariant winds and potential temperature
+      REAL,INTENT(OUT) :: dv(ip1jm,llm)
+      REAL,INTENT(OUT) :: du(ip1jmp1,llm)
+      REAL,INTENT(OUT) :: dh(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
+      REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
+      REAL te1dt(llm),te2dt(llm),te3dt(llm)
+      REAL deltapres(ip1jmp1,llm)
+
+      INTEGER l,ij
+
+      REAL  SSUM
+      integer :: ijb,ije
+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_p( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+         CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,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_p( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+         CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,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_p( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+         CALL divgrad_p ( llm,teta, niterh, gdx        )
+      ENDIF
+
+c      call write_field3d_p('gdx2',reshape(gdx,(/iip1,jmp1,llm/)))
+c      stop
+
+      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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/diverg_gam_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/diverg_gam_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/diverg_gam_p.F	(revision 222)
@@ -0,0 +1,97 @@
+      SUBROUTINE diverg_gam_p(klevel,cuvscvgam,cvuscugam,unsairegam ,
+     *                       unsapolnga,unsapolsga,  x, y,  div )
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      USE parallel_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 )
+      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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/diverg_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/diverg_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/diverg_p.F	(revision 222)
@@ -0,0 +1,106 @@
+      SUBROUTINE diverg_p(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      USE parallel_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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divergf_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divergf_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divergf_p.F	(revision 222)
@@ -0,0 +1,115 @@
+      SUBROUTINE divergf_p(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      USE parallel_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
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if(pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO 10 l = 1,klevel
+c
+        DO  ij = ijb, ije - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = ijb,ije,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        if (pole_nord) then
+        
+          DO  ij  = 1,iim
+           aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+          ENDDO
+          sumypn = SSUM ( iim,aiy1,1 ) / apoln
+
+c
+          DO  ij = 1,iip1
+           div(     ij    , l ) = - sumypn
+          ENDDO
+          
+        endif
+        
+        if (pole_sud) then
+        
+          DO  ij  = 1,iim
+           aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+          ENDDO
+          sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+          DO  ij = 1,iip1
+           div( ij + ip1jm, l ) =   sumyps
+          ENDDO
+          
+        endif
+        
+  10    CONTINUE
+c$OMP END DO NOWAIT
+
+c
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        
+        CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, klevel
+           DO ij = ijb,ije
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divgrad2_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divgrad2_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divgrad2_p.F	(revision 222)
@@ -0,0 +1,120 @@
+      SUBROUTINE divgrad2_p ( klevel, h, deltapres, lh, divgra_out )
+c
+c     P. Le Van
+c
+c   ***************************************************************
+c
+c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
+c   ****************************************************************
+c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+c         divgra     est  un argument  de sortie pour le s-prg
+c
+      USE parallel_lmdz
+      USE times
+      USE mod_hallo
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comdissipn.h"
+
+c    .......    variables en arguments   .......
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+      REAL divgra_out( ip1jmp1,klevel)
+      REAL,SAVE :: divgra( ip1jmp1,llm)
+
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+      Type(Request) :: request_dissip
+      INTEGER ijb,ije
+c
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+c      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, klevel
+        divgra(ijb:ije,l)=h(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c$OMP BARRIER
+       call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      CALL laplacien_p( klevel, divgra, divgra )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO l = 1, klevel
+       DO ij = ijb, ije
+        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO l = 1, klevel
+        DO ij = ijb, ije
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+   
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+c$OMP BARRIER
+       call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+
+c$OMP BARRIER
+
+
+       CALL laplacien_gam_p ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
+     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
+      ENDDO
+c
+c    ...............................................................
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO l = 1, klevel
+        DO ij = ijb, ije
+          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c$OMP BARRIER
+       call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      CALL laplacien_p ( klevel, divgra, divgra )
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l  = 1,klevel
+      DO ij = ijb,ije
+      divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+      ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divgrad_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divgrad_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/divgrad_p.F	(revision 222)
@@ -0,0 +1,91 @@
+      SUBROUTINE divgrad_p (klevel,h, lh, divgra_out )
+      USE parallel_lmdz
+      USE times
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c  Auteur :   P. Le Van
+c  ----------
+c
+c                              lh
+c      calcul de  (div( grad ))   de h  .....
+c      h  et lh  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra_out( ip1jmp1,klevel )
+      REAL,SAVE :: divgra( ip1jmp1,llm )
+
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+      
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, klevel      
+      divgra(ijb:ije,l)=h(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+c
+
+c
+      DO 10 iter = 1,lh
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1  )
+
+c      call exchange_Hallo(divgra,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(divgra,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER       
+      CALL    grad_p (klevel,divgra, ghx  , ghy          )
+
+c$OMP BARRIER
+c$OMP MASTER   
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(ghy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER            
+
+      CALL  diverg_p (klevel,  ghx , ghy  , divgra       )
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1)
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,klevel
+      DO 4  ij = ijb, ije
+      divgra_out( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dteta1_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dteta1_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dteta1_p.F	(revision 222)
@@ -0,0 +1,88 @@
+      SUBROUTINE dteta1_p ( teta, pbaru, pbarv, dteta)
+      USE parallel_lmdz
+      USE write_field_p
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+c
+c   ********************************************************************
+c   ... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dteta 	          sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dteta( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,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_p ( 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,jje,jjp1, llm, 2, 2, .true., 1)
+      
+      
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dudv1_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dudv1_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dudv1_p.F	(revision 222)
@@ -0,0 +1,64 @@
+      SUBROUTINE dudv1_p ( 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( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) ,
+     *     pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dudv2_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dudv2_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dudv2_p.F	(revision 222)
@@ -0,0 +1,69 @@
+      SUBROUTINE dudv2_p ( 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"
+#include "comvert.h"
+
+      REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ),
+     *         du( ip1jmp1,llm ),  dv( ip1jm,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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dynredem_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dynredem_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/dynredem_p.F	(revision 222)
@@ -0,0 +1,808 @@
+!
+! $Id: dynredem_p.F 1635 2012-07-12 11:37:16Z lguez $
+!
+c
+      SUBROUTINE dynredem0_p(fichnom,iday_end,phis)
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE parallel_lmdz
+      USE infotrac
+      use netcdf95, only: NF95_PUT_VAR
+      use control_mod, only : planet_type
+
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(iip1, jjp1)
+      CHARACTER*(*) fichnom
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+      character(len=12) :: start_file_type="earth" ! default start file type
+      INTEGER idecal
+
+c-----------------------------------------------------------------------
+      if (mpi_rank==0) then
+      
+      modname='dynredem0_p'
+
+#ifdef CPP_IOIPSL
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+#else
+! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
+      yyears0=0
+      mmois0=1
+      jjour0=1
+#endif        
+
+      !!! AS: idecal is a hack to be able to read planeto starts...
+      !!!     .... while keeping everything OK for LMDZ EARTH
+      if ((planet_type.eq."generic").or.(planet_type.eq."mars")) then
+          write(lunout,*) trim(modname),' : Planeto-like start file'
+          start_file_type="planeto"
+          idecal = 4
+      else
+          write(lunout,*) trim(modname),' : Earth-like start file'
+          idecal = 5
+      endif
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  = REAL(iim)
+       tab_cntrl(2)  = REAL(jjm)
+       tab_cntrl(3)  = REAL(llm)
+       if (start_file_type.eq."earth") then
+         tab_cntrl(4)=REAL(day_ref)
+       else
+         !tab_cntrl(4)=REAL(day_end)
+         tab_cntrl(4)=REAL(iday_end)
+       endif
+       tab_cntrl(5)  = REAL(annee_ref)
+       tab_cntrl(idecal+1)  = rad
+       tab_cntrl(idecal+2)  = omeg
+       tab_cntrl(idecal+3)  = g
+       tab_cntrl(idecal+4)  = cpp
+       tab_cntrl(idecal+5) = kappa
+       tab_cntrl(idecal+6) = daysec
+       tab_cntrl(idecal+7) = dtvr
+       tab_cntrl(idecal+8) = etot0
+       tab_cntrl(idecal+9) = ptot0
+       tab_cntrl(idecal+10) = ztot0
+       tab_cntrl(idecal+11) = stot0
+       tab_cntrl(idecal+12) = ang0
+       tab_cntrl(idecal+13) = pa
+       tab_cntrl(idecal+14) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(idecal+15)  = clon
+       tab_cntrl(idecal+16)  = clat
+       tab_cntrl(idecal+17)  = grossismx
+       tab_cntrl(idecal+18)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(idecal+19) = 1.
+       tab_cntrl(idecal+20) = dzoomx
+       tab_cntrl(idecal+21) = dzoomy
+       tab_cntrl(idecal+22) = 0.
+       tab_cntrl(idecal+23) = taux
+       tab_cntrl(idecal+24) = tauy
+      ELSE
+       tab_cntrl(idecal+19) = 0.
+       tab_cntrl(idecal+20) = dzoomx
+       tab_cntrl(idecal+21) = dzoomy
+       tab_cntrl(idecal+22) = 0.
+       tab_cntrl(idecal+23) = 0.
+       tab_cntrl(idecal+24) = 0.
+       IF( ysinus )  tab_cntrl(idecal+22) = 1.
+      ENDIF
+
+      if (start_file_type.eq."earth") then
+       tab_cntrl(idecal+25) = REAL(iday_end)
+       tab_cntrl(idecal+26) = REAL(itau_dyn + itaufin)
+c start_time: start_time of simulation (not necessarily 0.)
+       tab_cntrl(idecal+27) = start_time
+      endif
+
+      if (planet_type=="mars") then ! For Mars only
+        tab_cntrl(29)=hour_ini
+      endif
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      if (start_file_type.eq."earth") then
+        ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+        ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+        ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+        ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+        ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+        ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+        ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+        ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+      else
+        ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+        ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+        ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+        ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+        ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+        ierr = NF_DEF_DIM (nid, "altitude", llm, idim_s)
+        ierr = NF_DEF_DIM (nid, "interlayer", llmp1, idim_sig)
+        ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_tim)
+      endif
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,rlonu)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR (nid,nvarid,rlatu)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,rlonv)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,rlatv)
+c
+      if (start_file_type.eq."earth") then
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,nivsigs)
+c
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,nivsig)
+      endif ! of if (start_file_type.eq."earth")
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,ap)
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,bp)
+c
+      if (start_file_type.ne."earth") then
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"aps",NF_DOUBLE,1,idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"aps",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 37,
+     .                       "Coef AS: hybrid pressure at midlayers")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,aps)
+c
+        ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"bps",NF_DOUBLE,1,idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"bps",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+        ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 34,
+     .                       "Coef BS: hybrid sigma at midlayers")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,bps)
+      endif ! of if (start_file_type.ne."earth")
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,presnivs)
+c
+      if (start_file_type.ne."earth") then
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR(nid,"latitude",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+        ierr = NF_DEF_VAR(nid,"latitude",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+        ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .        "North latitude")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,rlatu*180/pi)
+c
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr=NF_DEF_VAR(nid,"longitude",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+        ierr=NF_DEF_VAR(nid,"longitude",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .        "East longitude")
+        ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,rlonv*180/pi)
+c
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1,
+     .       idim_s,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1,
+     .       idim_s,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"pseudo-alt")
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+        ierr = NF_ENDDEF(nid)
+        call NF95_PUT_VAR(nid,nvarid,pseudoalt)
+      endif ! of if (start_file_type.ne."earth")
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,cu)
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,cv)
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,aire)
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+      call NF95_PUT_VAR(nid,nvarid,phis)
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+      if (start_file_type.eq."earth") then
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      else ! start_file_type=="planeto"
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"Time",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"Time",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+      endif ! of if (start_file_type.eq."earth")
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+
+      DO iq=1,nqtot
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      endif  ! mpi_rank==0
+      RETURN
+      END
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE dynredem1_p(fichnom,time,
+     .                     vcov,ucov,teta,q,masse,ps)
+      USE parallel_lmdz
+      USE infotrac
+      USE control_mod, only : planet_type
+      use netcdf, only: NF90_get_VAR
+      use netcdf95, only: NF95_PUT_VAR
+
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "iniprint.h"
+
+      INTEGER l
+      REAL vcov(iip1,jjm,llm),ucov(iip1, jjp1,llm) 
+      REAL teta(iip1, jjp1,llm)                   
+      REAL ps(iip1, jjp1),masse(iip1, jjp1,llm)                   
+      REAL q(iip1, jjp1, llm, nqtot)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid, nid_trac, nvarid_trac
+      REAL trac_tmp(ip1jmp1,llm)      
+      INTEGER ierr, ierr_file 
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character(len=*),parameter :: modname='dynredem1'
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      logical exist_file
+      character(len=12) :: start_file_type="earth" ! default start file type
+
+      if ((planet_type.eq."generic").or.(planet_type.eq."mars")) then
+          write(lunout,*) trim(modname),' : Planeto-like start file'
+          start_file_type="planeto"
+      else
+          write(lunout,*) trim(modname),' : Earth-like start file'
+      endif 
+
+      call Gather_Field(ucov,ip1jmp1,llm,0)
+      call Gather_Field(vcov,ip1jm,llm,0)
+      call Gather_Field(teta,ip1jmp1,llm,0)
+      call Gather_Field(masse,ip1jmp1,llm,0)
+      call Gather_Field(ps,ip1jmp1,1,0)
+      
+      do iq=1,nqtot
+        call Gather_Field(q(:,:,:,iq),ip1jmp1,llm,0)
+      enddo
+      
+      
+      if (mpi_rank==0) then
+      
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynredem1: Pb. d ouverture "//trim(fichnom)
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      if (start_file_type.eq."earth") then
+        ierr = NF_INQ_VARID(nid, "temps", nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+          write(lunout,*) NF_STRERROR(ierr)
+          abort_message='Variable temps n est pas definie'
+          CALL abort_gcm(modname,abort_message,ierr)
+        ENDIF
+      else
+        ierr = NF_INQ_VARID(nid,"Time", nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+          write(lunout,*) NF_STRERROR(ierr)
+          abort_message='Variable Time not found'
+          CALL abort_gcm(modname,abort_message,ierr)
+        ENDIF
+      endif ! of if (start_file_type.eq."earth") 
+      call NF95_PUT_VAR(nid,nvarid,time,start=(/nb/))
+      PRINT*, "Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+      ierr = NF90_GET_VAR(nid, nvarid, tab_cntrl)
+      if (start_file_type=="earth") then
+        tab_cntrl(31) = REAL(itau_dyn + itaufin)
+      else
+        tab_cntrl(31) = 0
+      endif
+      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,ucov,start=(/1,1,1,nb/))
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,vcov,start=(/1,1,1,nb/))
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,teta,start=(/1,1,1,nb/))
+
+      IF (type_trac == 'inca') THEN
+! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc
+         inquire(FILE="start_trac.nc", EXIST=exist_file) 
+         print *, "EXIST", exist_file
+         if (exist_file) then 
+            ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
+            IF (ierr_file .NE.NF_NOERR) THEN
+               write(6,*)' Pb d''ouverture du fichier start_trac.nc'
+               write(6,*)' ierr = ', ierr_file 
+            ENDIF
+         else
+            ierr_file = 2
+         endif
+      END IF
+
+      do iq=1,nqtot 
+
+         IF (type_trac /= 'inca') THEN
+            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+            IF (ierr .NE. NF_NOERR) THEN
+               PRINT*, "Variable  tname(iq) n est pas definie"
+               CALL abort
+            ENDIF
+            call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq),start=(/1,1,1,nb/))
+        ELSE ! type_trac = inca
+! lecture de la valeur du traceur dans start_trac.nc
+           IF (ierr_file .ne. 2) THEN
+             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, tname(iq),"est absent de start_trac.nc"
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+                call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
+                
+             ELSE
+                PRINT*, tname(iq), "est present dans start_trac.nc"
+               ierr = NF90_GET_VAR(nid_trac, nvarid_trac, trac_tmp)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Lecture echouee pour", tname(iq)
+                   CALL abort
+                ENDIF
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+                call NF95_PUT_VAR(nid, nvarid, trac_tmp)
+               
+             ENDIF ! IF (ierr .NE. NF_NOERR)
+! fin lecture du traceur
+          ELSE                  ! si il n'y a pas de fichier start_trac.nc
+!             print *, 'il n y a pas de fichier start_trac'
+             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, "Variable  tname(iq) n est pas definie"
+                CALL abort
+             ENDIF
+             call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq),
+     &                  start=(/1,1,1,nb/))
+          ENDIF ! (ierr_file .ne. 2)
+       END IF   !type_trac
+      
+      ENDDO
+
+
+
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,masse,start=(/1,1,1,nb/))
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+      call NF95_PUT_VAR(nid,nvarid,ps,start=(/1,1,nb/))
+
+      ierr = NF_CLOSE(nid)
+c
+      endif ! mpi_rank==0
+      
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/enercin_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/enercin_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/enercin_p.F	(revision 222)
@@ -0,0 +1,121 @@
+      SUBROUTINE enercin_p ( vcov, ucov, vcont, ucont, ecin )
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i,ijb,ije
+
+      EXTERNAL    SSUM
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      IF (pole_nord) ijb=ij_begin+iip1
+      IF (pole_sud)  ije=ij_end-iip1
+      
+      DO 1  ij = ijb, ije -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = ijb, ije, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+      IF (pole_nord) THEN
+    
+        DO  i = 1, iim
+         ecinni(i) = vcov(    i  ,  l) * 
+     *               vcont(    i    ,l) * aire(   i   )
+        ENDDO
+
+        ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+
+        DO ij = 1,iip1
+          ecin(   ij     , l ) = ecinpn
+        ENDDO
+   
+      ENDIF
+
+      IF (pole_sud) THEN
+    
+        DO  i = 1, iim
+         ecinsi(i) = vcov(i+ip1jmi1,l)* 
+     *               vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+        ENDDO
+
+        ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+        DO ij = 1,iip1
+          ecin( ij+ ip1jm, l ) = ecinps
+        ENDDO
+   
+      ENDIF
+
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/exner_hyb_p_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/exner_hyb_p_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/exner_hyb_p_m.F90	(revision 222)
@@ -0,0 +1,187 @@
+module exner_hyb_p_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_hyb_p ( ngrid, ps, p, pks, pk, pkf )
+
+    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !                                 -------- z
+    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    !    on determine successivement , du haut vers le bas des couches, les 
+    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+    !
+    !
+    USE parallel_lmdz
+    !
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom.h"
+    include "comvert.h"
+    include "serre.h"
+
+    INTEGER  ngrid
+    REAL p(ngrid,llmp1),pk(ngrid,llm)
+    REAL, optional:: pkf(ngrid,llm)
+    REAL ps(ngrid),pks(ngrid)
+    REAL alpha(ngrid,llm),beta(ngrid,llm)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL unpl2k,dellta
+
+    INTEGER ije,ijb,jje,jjb
+    logical,save :: firstcall=.true.
+    !$OMP THREADPRIVATE(firstcall) 
+    character(len=*),parameter :: modname="exner_hyb_p"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    !$OMP BARRIER
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+       ijb=ij_begin
+       ije=ij_end
+       !$OMP DO SCHEDULE(STATIC)
+       DO ij=ijb, ije
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+          if (present(pkf)) pkf(ij,1)=pk(ij,1)
+       ENDDO
+       !$OMP ENDDO
+
+       !$OMP BARRIER
+       if (present(pkf)) then
+          jjb=jj_begin
+          jje=jj_end
+          CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    unpl2k    = 1.+ 2.* kappa
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    ijb=ij_begin
+    ije=ij_end
+
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij  = ijb, ije
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+    !$OMP ENDDO
+    ! Synchro OPENMP ici
+
+    !$OMP BARRIER
+    !
+    !
+    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+    !
+    !$OMP DO SCHEDULE(STATIC)
+    DO     ij      = ijb,ije
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+    ENDDO
+    !$OMP ENDDO NOWAIT
+    !
+    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+    !
+    DO l = llm -1 , 2 , -1
+       !
+       !$OMP DO SCHEDULE(STATIC)
+       DO ij = ijb, ije
+          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+          beta (ij,l)  =   p(ij,l  ) / dellta   
+       ENDDO
+       !$OMP ENDDO NOWAIT
+    ENDDO
+
+    !  ***********************************************************************
+    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+    !
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij   = ijb, ije
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
+            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+    ENDDO
+    !$OMP ENDDO NOWAIT
+    !
+    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+    !
+    DO l = 2, llm
+       !$OMP DO SCHEDULE(STATIC)
+       DO   ij   = ijb, ije
+          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+       ENDDO
+       !$OMP ENDDO NOWAIT        
+    ENDDO
+
+    if (present(pkf)) then
+       !    calcul de pkf
+
+       DO l = 1, llm
+          !$OMP DO SCHEDULE(STATIC)
+          DO   ij   = ijb, ije
+             pkf(ij,l)=pk(ij,l)
+          ENDDO
+          !$OMP ENDDO NOWAIT             
+       ENDDO
+
+       !$OMP BARRIER
+
+       jjb=jj_begin
+       jje=jj_end
+       CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_hyb_p
+
+end module exner_hyb_p_m
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/exner_milieu_p_m.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/exner_milieu_p_m.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/exner_milieu_p_m.F90	(revision 222)
@@ -0,0 +1,160 @@
+module exner_milieu_p_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_milieu_p ( ngrid, ps, p, pks, pk, pkf )
+    !
+    !     Auteurs :  F. Forget , Y. Wanherdrick
+    ! P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !     WARNING : CECI est une version speciale de exner_hyb originale
+    !               Utilise dans la version martienne pour pouvoir 
+    !               tourner avec des coordonnees verticales complexe
+    !              => Il ne verifie PAS la condition la proportionalite en 
+    !              energie totale/ interne / potentielle (F.Forget 2001)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    USE parallel_lmdz
+    !
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom.h"
+    include "comvert.h"
+    include "serre.h"
+
+    INTEGER  ngrid
+    REAL p(ngrid,llmp1),pk(ngrid,llm)
+    REAL, optional:: pkf(ngrid,llm)
+    REAL ps(ngrid),pks(ngrid)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij,ijb,ije,jjb,jje
+    REAL dum1
+
+    logical,save :: firstcall=.true.
+    !$OMP THREADPRIVATE(firstcall) 
+    character(len=*),parameter :: modname="exner_milieu_p"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    !$OMP BARRIER
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+       ijb=ij_begin
+       ije=ij_end
+       !$OMP DO SCHEDULE(STATIC)
+       DO ij=ijb, ije
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+          if (present(pkf)) pkf(ij,1)=pk(ij,1)
+       ENDDO
+       !$OMP ENDDO
+
+       !$OMP BARRIER
+       if (present(pkf)) then
+          jjb=jj_begin
+          jje=jj_end
+          CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    ijb=ij_begin
+    ije=ij_end
+
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij  = ijb, ije
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+    !$OMP ENDDO
+    ! Synchro OPENMP ici
+
+    !$OMP BARRIER
+    !
+    !
+    !    .... Calcul de pk  pour la couche l 
+    !    --------------------------------------------
+    !
+    dum1 = cpp * (2*preff)**(-kappa) 
+    DO l = 1, llm-1
+       !$OMP DO SCHEDULE(STATIC)
+       DO   ij   = ijb, ije
+          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+       ENDDO
+       !$OMP ENDDO NOWAIT
+    ENDDO
+
+    !    .... Calcul de pk  pour la couche l = llm ..
+    !    (on met la meme distance (en log pression)  entre Pk(llm)
+    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij   = ijb, ije
+       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+    ENDDO
+    !$OMP ENDDO NOWAIT        
+
+    if (present(pkf)) then
+       !    calcul de pkf
+
+       DO l = 1, llm
+          !$OMP DO SCHEDULE(STATIC)
+          DO   ij   = ijb, ije
+             pkf(ij,l)=pk(ij,l)
+          ENDDO
+          !$OMP ENDDO NOWAIT
+       ENDDO
+
+       !$OMP BARRIER
+
+       jjb=jj_begin
+       jje=jj_end
+       CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_milieu_p
+
+end module exner_milieu_p_m
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/filtreg_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/filtreg_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/filtreg_p.F	(revision 222)
@@ -0,0 +1,433 @@
+
+
+      SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, 
+     &     ifiltre, iaire, griscal ,iter)
+      USE parallel_lmdz, only : OMP_CHUNK
+      USE mod_filtre_fft
+      USE timer_filtre
+      
+      USE filtreg_mod
+      
+      IMPLICIT NONE
+      
+c=======================================================================
+c
+c   Auteur: P. Le Van        07/10/97
+c   ------
+c
+c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+c                     pour l'operateur  Filtre    .
+c   ------
+c
+c   Arguments:
+c   ----------
+c
+c      
+c      ibeg..iend            lattitude a filtrer
+c      nlat                  nombre de latitudes du champ
+c      nbniv                 nombre de niveaux verticaux a filtrer
+c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+c                            en sortie : champ filtre
+c      ifiltre               +1  Transformee directe
+c                            -1  Transformee inverse
+c                            +2  Filtre directe
+c                            -2  Filtre inverse
+c
+c      iaire                 1   si champ intensif
+c                            2   si champ extensif (pondere par les aires)
+c
+c      iter                  1   filtre simple
+c
+c=======================================================================
+c
+c
+c                      Variable Intensive
+c                ifiltre = 1     filtre directe
+c                ifiltre =-1     filtre inverse
+c
+c                      Variable Extensive
+c                ifiltre = 2     filtre directe
+c                ifiltre =-2     filtre inverse
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "coefils.h"
+c
+      INTEGER ibeg,iend,nlat,nbniv,ifiltre,iter
+      INTEGER i,j,l,k
+      INTEGER iim2,immjm
+      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+      
+      REAL  champ( iip1,nlat,nbniv)
+      
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+      
+      REAL :: champ_fft(iip1,nlat,nbniv)
+      REAL :: champ_in(iip1,nlat,nbniv)
+      
+      LOGICAL,SAVE     :: first=.TRUE.
+c$OMP THREADPRIVATE(first) 
+
+      REAL, DIMENSION(iip1,nlat,nbniv) :: champ_loc
+      INTEGER :: ll_nb, nbniv_loc
+      REAL, SAVE :: sdd12(iim,4)
+c$OMP THREADPRIVATE(sdd12) 
+
+      INTEGER, PARAMETER :: type_sddu=1
+      INTEGER, PARAMETER :: type_sddv=2
+      INTEGER, PARAMETER :: type_unsddu=3
+      INTEGER, PARAMETER :: type_unsddv=4
+
+      INTEGER :: sdd1_type, sdd2_type
+
+      IF (first) THEN
+         sdd12(1:iim,type_sddu) = sddu(1:iim)
+         sdd12(1:iim,type_sddv) = sddv(1:iim)
+         sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+         sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+
+         CALL Init_timer
+         first=.FALSE.
+      ENDIF
+
+c$OMP MASTER      
+      CALL start_timer
+c$OMP END MASTER
+
+c-------------------------------------------------------c
+
+      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
+     &     STOP'Pas de transformee simple dans cette version'
+      
+      IF( iter.EQ. 2 )  THEN
+         PRINT *,' Pas d iteration du filtre dans cette version !'
+     &        , ' Utiliser old_filtreg et repasser !'
+         STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+         PRINT *,' Cette routine ne calcule le filtre inverse que '
+     &        , ' sur la grille des scalaires !'
+         STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     &        , ' corriger et repasser !'
+         STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+            PRINT  1111
+            STOP
+         ELSE
+c     
+            IF( iaire.EQ.1 )  THEN
+               sdd1_type = type_sddv
+               sdd2_type = type_unsddv
+            ELSE
+               sdd1_type = type_unsddv
+               sdd2_type = type_sddv
+            ENDIF
+c
+            jdfil1 = 2
+            jffil1 = jfiltnu
+            jdfil2 = jfiltsu
+            jffil2 = jjm
+         ENDIF
+      ELSE
+         IF( nlat.NE.jjm )  THEN
+            PRINT  2222
+            STOP
+         ELSE
+c
+            IF( iaire.EQ.1 )  THEN
+               sdd1_type = type_sddu
+               sdd2_type = type_unsddu
+            ELSE
+               sdd1_type = type_unsddu
+               sdd2_type = type_sddu
+            ENDIF
+c     
+            jdfil1 = 1
+            jffil1 = jfiltnv
+            jdfil2 = jfiltsv
+            jffil2 = jjm
+         ENDIF
+      ENDIF
+c      
+      DO hemisph = 1, 2
+c     
+         IF ( hemisph.EQ.1 )  THEN
+cym
+            jdfil = max(jdfil1,ibeg)
+            jffil = min(jffil1,iend)
+         ELSE
+cym
+            jdfil = max(jdfil2,ibeg)
+            jffil = min(jffil2,iend)
+         ENDIF
+
+
+cccccccccccccccccccccccccccccccccccccccccccc
+c Utilisation du filtre classique
+cccccccccccccccccccccccccccccccccccccccccccc
+
+         IF (.NOT. use_filtre_fft) THEN
+      
+c     !---------------------------------!
+c     ! Agregation des niveau verticaux !
+c     ! uniquement necessaire pour une  !
+c     ! execution OpenMP                !
+c     !---------------------------------!
+            ll_nb = 0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            DO l = 1, nbniv
+               ll_nb = ll_nb+1
+               DO j = jdfil,jffil
+                  DO i = 1, iim
+                     champ_loc(i,j,ll_nb) = 
+     &                    champ(i,j,l) * sdd12(i,sdd1_type)
+                  ENDDO
+               ENDDO
+            ENDDO
+c$OMP END DO NOWAIT
+
+            nbniv_loc = ll_nb
+
+            IF( hemisph.EQ.1 )      THEN
+               
+               IF( ifiltre.EQ.-2 )   THEN
+                  DO j = jdfil,jffil
+#ifdef BLAS
+                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
+     &                    matrinvn(1,1,j), iim, 
+     &                    champ_loc(1,j,1), iip1*nlat, 0.0,
+     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                     champ_fft(:iim,j-jdfil+1,:)
+     &                    =matmul(matrinvn(:,:,j),champ_loc(:iim,j,:))
+#endif
+                  ENDDO
+                  
+               ELSE IF ( griscal )     THEN
+                  DO j = jdfil,jffil
+#ifdef BLAS
+                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
+     &                    matriceun(1,1,j), iim, 
+     &                    champ_loc(1,j,1), iip1*nlat, 0.0,
+     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                     champ_fft(:iim,j-jdfil+1,:)
+     &                    =matmul(matriceun(:,:,j),champ_loc(:iim,j,:))
+#endif
+                  ENDDO
+                  
+               ELSE 
+                  DO j = jdfil,jffil
+#ifdef BLAS
+                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
+     &                    matricevn(1,1,j), iim, 
+     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
+     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                     champ_fft(:iim,j-jdfil+1,:)
+     &                    =matmul(matricevn(:,:,j),champ_loc(:iim,j,:))
+#endif
+                  ENDDO
+                  
+               ENDIF
+               
+            ELSE
+               
+               IF( ifiltre.EQ.-2 )   THEN
+                  DO j = jdfil,jffil
+#ifdef BLAS
+                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
+     &                    matrinvs(1,1,j-jfiltsu+1), iim, 
+     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
+     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                     champ_fft(:iim,j-jdfil+1,:)
+     &                    =matmul(matrinvs(:,:,j-jfiltsu+1),
+     &                            champ_loc(:iim,j,:))
+#endif
+                  ENDDO
+                  
+               ELSE IF ( griscal )     THEN
+                  
+                  DO j = jdfil,jffil
+#ifdef BLAS
+                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
+     &                    matriceus(1,1,j-jfiltsu+1), iim, 
+     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
+     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                     champ_fft(:iim,j-jdfil+1,:)
+     &                    =matmul(matriceus(:,:,j-jfiltsu+1),
+     &                            champ_loc(:iim,j,:))
+#endif
+                  ENDDO
+                  
+               ELSE 
+                  
+                  DO j = jdfil,jffil
+#ifdef BLAS
+                     CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, 
+     &                    matricevs(1,1,j-jfiltsv+1), iim, 
+     &                    champ_loc(1,j,1), iip1*nlat, 0.0, 
+     &                    champ_fft(1,j-jdfil+1,1), iip1*nlat)
+#else
+                     champ_fft(:iim,j-jdfil+1,:)
+     &                    =matmul(matricevs(:,:,j-jfiltsv+1),
+     &                            champ_loc(:iim,j,:))
+#endif
+                  ENDDO
+                  
+               ENDIF
+               
+            ENDIF
+!     c     
+            IF( ifiltre.EQ.2 )  THEN
+               
+c     !-------------------------------------!
+c     ! DÃ©s-agregation des niveau verticaux !
+c     ! uniquement necessaire pour une      !
+c     ! execution OpenMP                    !
+c     !-------------------------------------!
+               ll_nb = 0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+               DO l = 1, nbniv
+                  ll_nb = ll_nb + 1
+                  DO j = jdfil,jffil
+                     DO i = 1, iim
+                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
+     &                       + champ_fft(i,j-jdfil+1,ll_nb))
+     &                       * sdd12(i,sdd2_type)
+                     ENDDO
+                  ENDDO
+               ENDDO
+c$OMP END DO NOWAIT
+               
+            ELSE
+               
+               ll_nb = 0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+               DO l = 1, nbniv_loc
+                  ll_nb = ll_nb + 1
+                  DO j = jdfil,jffil
+                     DO i = 1, iim
+                        champ( i,j,l ) = (champ_loc(i,j,ll_nb) 
+     &                       - champ_fft(i,j-jdfil+1,ll_nb))
+     &                       * sdd12(i,sdd2_type)
+                     ENDDO
+                  ENDDO
+               ENDDO
+c$OMP END DO NOWAIT
+               
+            ENDIF
+            
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            DO l = 1, nbniv
+               DO j = jdfil,jffil
+                  champ( iip1,j,l ) = champ( 1,j,l )
+               ENDDO
+            ENDDO
+c$OMP END DO NOWAIT
+            
+ccccccccccccccccccccccccccccccccccccccccccccc
+c Utilisation du filtre FFT
+ccccccccccccccccccccccccccccccccccccccccccccc
+        
+         ELSE
+       
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            DO l=1,nbniv
+               DO j=jdfil,jffil
+                  DO  i = 1, iim
+                     champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
+                     champ_fft( i,j,l) = champ(i,j,l)
+                  ENDDO
+               ENDDO
+            ENDDO
+c$OMP END DO NOWAIT
+
+            IF (jdfil<=jffil) THEN
+               IF( ifiltre. EQ. -2 )   THEN
+                  CALL Filtre_inv_fft(champ_fft,nlat,jdfil,jffil,nbniv) 
+               ELSE IF ( griscal )     THEN
+                  CALL Filtre_u_fft(champ_fft,nlat,jdfil,jffil,nbniv)
+               ELSE
+                  CALL Filtre_v_fft(champ_fft,nlat,jdfil,jffil,nbniv)
+               ENDIF
+            ENDIF
+
+
+            IF( ifiltre.EQ. 2 )  THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+               DO l=1,nbniv
+                  DO j=jdfil,jffil
+                     DO  i = 1, iim
+                        champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l))
+     &                       *sdd12(i,sdd2_type)
+                     ENDDO
+                  ENDDO
+               ENDDO
+c$OMP END DO NOWAIT	  
+            ELSE
+        
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+               DO l=1,nbniv
+                  DO j=jdfil,jffil
+                     DO  i = 1, iim
+                        champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l))
+     &                       *sdd12(i,sdd2_type)
+                     ENDDO
+                  ENDDO
+               ENDDO
+c$OMP END DO NOWAIT          
+            ENDIF
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+            DO l=1,nbniv
+               DO j=jdfil,jffil
+!            champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
+                  champ( iip1,j,l ) = champ( 1,j,l )
+               ENDDO
+            ENDDO
+c$OMP END DO NOWAIT          	
+         ENDIF 
+c Fin de la zone de filtrage
+
+	
+      ENDDO
+
+!      DO j=1,nlat
+!     
+!          PRINT *,"check FFT ----> Delta(",j,")=",
+!     &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
+!     &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) 
+!      ENDDO
+      
+!          PRINT *,"check FFT ----> Delta(",j,")=",
+!     &            sum(champ-champ_fft)/sum(champ)
+!      
+      
+c
+ 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
+     &     filtrer, sur la grille des scalaires'/)
+ 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
+     &     ltrer, sur la grille de V ou de Z'/)
+c$OMP MASTER      
+      CALL stop_timer
+c$OMP END MASTER
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/flumass_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/flumass_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/flumass_p.F	(revision 222)
@@ -0,0 +1,152 @@
+      SUBROUTINE flumass_p(massebx,masseby, vcont, ucont, pbaru, pbarv)
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
+     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
+     * pbarv( ip1jm,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+      INTEGER ijb,ije
+      
+      EXTERNAL   SSUM
+      REAL       SSUM
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO  5 l = 1,llm
+
+        ijb=ij_begin
+        ije=ij_end+iip1
+      
+        if (pole_nord) ijb=ij_begin+iip1
+        if (pole_sud)  ije=ij_end-iip1
+        
+        DO  1 ij = ijb,ije
+          pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1    CONTINUE
+
+        ijb=ij_begin-iip1
+        ije=ij_end+iip1
+      
+        if (pole_nord) ijb=ij_begin
+        if (pole_sud)  ije=ij_end-iip1
+        
+        DO 3 ij = ijb,ije
+          pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3    CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      IF (pole_nord) THEN
+     
+        sairen = SSUM( iim,  aire(   1     ), 1 )
+        saireun= SSUM( iim, aireu(   1     ), 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+        DO l = 1,llm
+ 
+          ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      
+          pbaru(1,l)=pbarv(1,l) - ctn * aire(1)
+        
+          DO i = 2,iim
+            pbaru(i,l) = pbaru(i- 1,l )    +
+     *                   pbarv(i,l) - ctn * aire(i )
+          ENDDO
+        
+          DO i = 1,iim
+            apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+          ENDDO
+      
+          ctn0 = -SSUM( iim,apbarun,1 )/saireun
+        
+          DO i = 1,iim
+            pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+          ENDDO
+       
+          pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+        
+        ENDDO
+c$OMP END DO NOWAIT              
+
+      ENDIF
+
+      
+      IF (pole_sud) THEN
+  
+        saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+        saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+        DO  l = 1,llm
+ 
+          cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+          pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1)
+   
+          DO i = 2,iim
+            pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l)    -
+     *                          pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
+          ENDDO
+        
+          DO i = 1,iim
+            apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+          ENDDO
+
+          cts0 = -SSUM( iim,apbarus,1 )/saireus
+
+          DO i = 1,iim
+            pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+          ENDDO
+
+          pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+       
+        ENDDO
+c$OMP END DO NOWAIT         
+      ENDIF
+      
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/fluxstokenc_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/fluxstokenc_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/fluxstokenc_p.F	(revision 222)
@@ -0,0 +1,250 @@
+!
+! $Id: fluxstokenc_p.F 1454 2010-11-18 12:01:24Z fairhead $
+!
+      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
+     . time_step,itau )
+#ifdef CPP_IOIPSL
+! This routine is designed to work with ioipsl
+
+       USE IOIPSL
+       USE parallel_lmdz
+       USE misc_mod
+       USE mod_hallo
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "tracstoke.h"
+#include "temps.h"
+#include "iniprint.h"
+
+      REAL time_step,t_wrt, t_ops
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+      REAL phis(ip1jmp1)
+
+      REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
+
+      REAL pbarvst(iip1,jjp1,llm),zistdyn
+	real dtcum
+
+      INTEGER iadvtr,ndex(1) 
+      integer nscal
+      real tst(1),ist(1),istp(1)
+      INTEGER ij,l,irec,i,j,itau
+      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
+ 
+      SAVE iadvtr, massem,irec
+      SAVE phic,tetac
+      logical first
+      save first
+      data first/.true./
+      DATA iadvtr/0/
+      integer :: ijb,ije,jjb,jje,jjn
+      type(Request) :: Req
+
+c AC initialisations
+      pbarug(:,:)   = 0.
+cym      pbarvg(:,:,:) = 0.
+cym      wg(:,:)       = 0.
+
+c$OMP MASTER
+
+      if(first) then
+
+	CALL initfluxsto_p( 'fluxstoke',
+     .  time_step,istdyn* time_step,istdyn* time_step,
+     .  fluxid,fluxvid,fluxdid) 
+	
+        ijb=ij_begin
+        ije=ij_end
+        jjn=jj_nb
+
+	ndex(1) = 0
+        call histwrite(fluxid, 'phis', 1, phis(ijb:ije),
+     .	               iip1*jjn, ndex)
+        call histwrite(fluxid, 'aire', 1, aire(ijb:ije),
+     .                 iip1*jjn, ndex)
+	
+	ndex(1) = 0
+        nscal = 1
+        
+	if (mpi_rank==0) then
+          tst(1) = time_step
+          call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
+          ist(1)=istdyn
+          call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
+          istp(1)= istphy
+          call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
+	endif
+	first = .false.
+
+      endif
+
+
+      IF(iadvtr.EQ.0) THEN
+cym         CALL initial0(ijp1llm,phic)
+cym        CALL initial0(ijp1llm,tetac)
+cym         CALL initial0(ijp1llm,pbaruc)
+cym         CALL initial0(ijmllm,pbarvc)
+        ijb=ij_begin
+        ije=ij_end
+        phic(ijb:ije,1:llm)=0
+	tetac(ijb:ije,1:llm)=0
+	pbaruc(ijb:ije,1:llm)=0
+	
+	IF (pole_sud) ije=ij_end-iip1
+	pbarvc(ijb:ije,1:llm)=0
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,llm
+         DO ij = ijb,ije
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+            phic(ij,l) = phic(ij,l) + phi(ij,l)
+         ENDDO
+       ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+	
+      DO l=1,llm
+         DO ij = ijb,ije
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+cym         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+        ijb=ij_begin
+        ije=ij_end 
+	massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+c$OMP END MASTER
+c$OMP BARRIER
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.istdyn ) THEN
+c$OMP MASTER
+c    normalisation
+      ijb=ij_begin
+      ije=ij_end 
+
+      DO l=1,llm
+         DO ij = ijb,ije
+            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
+            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
+            phic(ij,l) = phic(ij,l)/REAL(istdyn)
+         ENDDO
+      ENDDO
+
+      ijb=ij_begin
+      ije=ij_end 
+      if (pole_sud) ije=ij_end-iip1      
+      
+      DO l=1,llm
+          DO ij = ijb,ije
+            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
+         ENDDO
+      ENDDO
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+c$OMP END MASTER
+c$OMP BARRIER 
+        call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req)
+	call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req)
+        call SendRequest(Req)
+c$OMP BARRIER
+        call WaitRequest(Req)
+c$OMP BARRIER
+c$OMP MASTER
+        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+        
+        jjb=jj_begin
+	jje=jj_end
+	if (pole_sud) jje=jj_end-1
+	
+        do l=1,llm
+           do j=jjb,jje
+              do i=1,iip1
+                 pbarvst(i,j,l)=pbarvg(i,j,l)
+              enddo
+           enddo
+	 enddo
+	 
+	 if (pole_sud) then
+           do i=1,iip1
+              pbarvst(i,jjp1,l)=0.
+           enddo
+        endif
+      
+         iadvtr=0
+	write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
+	
+        ijb=ij_begin
+	ije=ij_end
+	jjn=jj_nb
+	
+	call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:),
+     .               iip1*jjn*llm, ndex)
+	
+	call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:),
+     .               iip1*jjn*llm, ndex)
+	
+        jjb=jj_begin
+	jje=jj_end
+	jjn=jj_nb
+	if (pole_sud) then
+	  jje=jj_end-1
+	  jjn=jj_nb-1
+	endif
+	
+	call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:),
+     .               iip1*jjn*llm, ndex)
+	
+        ijb=ij_begin
+	ije=ij_end
+	jjn=jj_nb
+	
+        call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:), 
+     .             iip1*jjn*llm, ndex) 
+	
+	call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:), 
+     .             iip1*jjn*llm, ndex) 
+	
+	call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:), 
+     .             iip1*jjn*llm, ndex) 
+	
+C
+c$OMP END MASTER
+      ENDIF ! if iadvtr.EQ.istdyn
+
+#else
+      write(lunout,*)
+     & 'fluxstokenc: Needs IOIPSL to function'
+#endif
+! of #ifdef CPP_IOIPSL
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/friction_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/friction_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/friction_p.F	(revision 222)
@@ -0,0 +1,202 @@
+!
+! $Id: friction_p.F 1437 2010-09-30 08:29:10Z emillour $
+!
+c=======================================================================
+      SUBROUTINE friction_p(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
+      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 "comconst.h"
+#include "iniprint.h"
+#include "academic.h"
+
+! arguments:
+      REAL,INTENT(inout) :: ucov( iip1,jjp1,llm )
+      REAL,INTENT(inout) :: vcov( iip1,jjm,llm )
+      REAL,INTENT(in) :: pdt ! time step
+
+! local variables:
+      REAL modv(iip1,jjp1),zco,zsi
+      REAL vpn,vps,upoln,upols,vpols,vpoln
+      REAL u2(iip1,jjp1),v2(iip1,jjm)
+      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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gcm.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gcm.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gcm.F	(revision 222)
@@ -0,0 +1,608 @@
+!
+! $Id: gcm.F 1446 2010-10-22 09:27:25Z emillour $
+!
+c
+c
+      PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+
+
+      USE mod_const_mpi, ONLY: init_const_mpi
+      USE parallel_lmdz
+      USE infotrac
+      USE mod_interface_dyn_phys
+      USE mod_hallo
+      USE Bands
+      USE getparam
+      USE filtreg_mod
+      USE control_mod, only: planet_type,nday,day_step,iperiod,iphysiq,
+     &                       raz_date,anneeref,starttime,dayref,
+     &                       ok_dyn_ins,ok_dyn_ave,iecri,periodav,
+     &                       less1day,fractday,ndynstep,nsplit_phys
+      use cpdet_mod, only: ini_cpdet
+
+
+#ifdef INCA
+! Only INCA needs these informations (from the Earth's physics)
+      USE indice_sol_mod
+#endif
+
+! Ehouarn: the following are needed with (parallel) physics:
+#ifdef CPP_PHYS
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+      USE mod_phys_lmdz_omp_data, ONLY: klon_omp 
+      USE dimphy
+      USE comgeomphy
+#endif
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+c  ... Possibilite de choisir le schema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+!!!!!!!!!!!#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+!#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "tracstoke.h"
+#ifdef INCA
+! Only INCA needs these informations (from the Earth's physics)
+#include "indicesol.h"
+#endif
+
+
+      REAL zdtvr
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+c      REAL pks(ip1jmp1)                      ! exner au  sol
+c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+c      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+c      REAL w(ip1jmp1,llm)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL time_0
+
+      LOGICAL lafin
+c      INTEGER ij,iq,l,i,j
+      INTEGER i,j
+
+
+      real time_step, t_wrt, t_ops
+
+
+      LOGICAL call_iniphys
+      data call_iniphys/.true./
+
+c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+c+jld variables test conservation energie
+c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+c      REAL dhecdt(ip1jmp1,llm)
+c      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+c      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+c      CHARACTER (len=15) :: ztit
+c-jld 
+
+
+      character (len=80) :: dynhist_file, dynhistave_file
+      character (len=20) :: modname
+      character (len=80) :: abort_message
+! locales pour gestion du temps
+      INTEGER :: an, mois, jour
+      REAL :: heure
+
+
+c-----------------------------------------------------------------------
+c    variables pour l'initialisation de la physique :
+c    ------------------------------------------------
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx)
+      REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
+      
+      INTEGER :: ierr
+
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      abort_message = 'last timestep reached'
+      modname = 'gcm'
+      descript = 'Run GCM LMDZ'
+      lafin    = .FALSE.
+      dynhist_file = 'dyn_hist'
+      dynhistave_file = 'dyn_hist_ave'
+
+
+
+c----------------------------------------------------------------------
+c  lecture des fichiers gcm.def ou run.def
+c  ---------------------------------------
+c
+! Ehouarn: dump possibility of using defrun
+!#ifdef CPP_IOIPSL
+      CALL conf_gcm( 99, .TRUE. )
+!#else
+!      CALL defrun( 99, .TRUE. , clesphy0 )
+!#endif
+c
+c
+c------------------------------------
+c   Initialisation partie parallele
+c------------------------------------
+
+      CALL init_const_mpi
+      call init_parallel
+      call ini_getparam("out.def")
+      call Read_Distrib
+
+#ifdef CPP_PHYS
+        CALL init_phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys)
+#endif
+      CALL set_bands
+#ifdef CPP_PHYS
+      CALL Init_interface_dyn_phys
+#endif
+      CALL barrier
+
+      if (mpi_rank==0) call WriteBands
+      call SetDistrib(jj_Nb_Caldyn)
+
+c$OMP PARALLEL
+      call Init_Mod_hallo
+c$OMP END PARALLEL
+
+#ifdef CPP_PHYS
+c$OMP PARALLEL
+      call initcomgeomphy
+c$OMP END PARALLEL 
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Initialisation de XIOS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+c
+c Initialisations pour Cp(T) Venus
+      call ini_cpdet
+c
+c-----------------------------------------------------------------------
+c   Choix du calendrier
+c   -------------------
+
+c      calend = 'earth_365d'
+
+#ifdef CPP_IOIPSL
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360d')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+      else if (calend == 'earth_365d') then
+        call ioconf_calendar('noleap')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+      else if (calend == 'earth_366d') then
+        call ioconf_calendar('gregorian')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
+      else if (calend == 'titan') then
+!        call ioconf_calendar('titan')
+        write(lunout,*)'CALENDRIER CHOISI: Titan'
+        abort_message = 'A FAIRE...'
+        call abort_gcm(modname,abort_message,1)
+      else if (calend == 'venus') then
+!        call ioconf_calendar('venus')
+        write(lunout,*)'CALENDRIER CHOISI: Venus'
+        abort_message = 'A FAIRE...'
+        call abort_gcm(modname,abort_message,1)
+      else
+        abort_message = 'Mauvais choix de calendrier'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#endif
+c-----------------------------------------------------------------------
+
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+         call init_const_lmdz(
+     $        nbtr,anneeref,dayref,
+     $        iphysiq,day_step,nday, 
+     $        nbsrf, is_oce,is_sic,
+     $        is_ter,is_lic)
+
+         call init_inca_para(
+     $        iim,jjm+1,llm,klon_glo,mpi_size,
+     $        distrib_phys,COMM_LMDZ)
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des traceurs
+c   ---------------------------
+c  Choix du nombre de traceurs et du schema pour l'advection
+c  dans fichier traceur.def, par default ou via INCA
+      call infotrac_init
+
+c Allocation de la tableau q : champs advectes   
+      ALLOCATE(q(ip1jmp1,llm,nqtot))
+
+c-----------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+
+c  lecture du fichier start.nc
+      if (read_start) then
+      ! we still need to run iniacademic to initialize some
+      ! constants & fields, if we run the 'newtonian' or 'SW' cases:
+        if (iflag_phys.ne.1) then
+          CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+        endif
+
+        CALL dynetat0("start.nc",vcov,ucov,
+     &              teta,q,masse,ps,phis, time_0)
+       
+        ! Load relaxation fields (simple nudging). AS 09/2013
+        ! ---------------------------------------------------
+        if (planet_type.eq."generic") then
+         if (ok_guide) then
+           CALL relaxetat0("relax.nc")
+         endif
+        endif
+ 
+c       write(73,*) 'ucov',ucov
+c       write(74,*) 'vcov',vcov
+c       write(75,*) 'teta',teta
+c       write(76,*) 'ps',ps
+c       write(77,*) 'q',q
+
+      endif ! of if (read_start)
+
+c le cas echeant, creation d un etat initial
+      IF (prt_level > 9) WRITE(lunout,*)
+     .              'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
+      if (.not.read_start) then
+         CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+      endif
+
+
+c-----------------------------------------------------------------------
+c   Lecture des parametres de controle pour la simulation :
+c   -------------------------------------------------------
+c  on recalcule eventuellement le pas de temps
+
+      IF(MOD(day_step,iperiod).NE.0) THEN
+        abort_message = 
+     .  'Il faut choisir un nb de pas par jour multiple de iperiod'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      IF(MOD(day_step,iphysiq).NE.0) THEN
+        abort_message = 
+     * 'Il faut choisir un nb de pas par jour multiple de iphysiq'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      zdtvr    = daysec/REAL(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         WRITE(lunout,*)
+     .    'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+C
+C on remet le calendrier à zero si demande
+c
+      IF (start_time /= starttime) then
+        WRITE(lunout,*)' GCM: Attention l''heure de depart lue dans le'
+     &,' fichier restart ne correspond pas à celle lue dans le run.def'
+        IF (raz_date == 1) then
+          WRITE(lunout,*)'Je prends l''heure lue dans run.def'
+          start_time = starttime
+        ELSE
+          call abort_gcm("gcm", "'Je m''arrete'", 1)
+        ENDIF
+      ENDIF
+      IF (raz_date == 1) THEN
+        annee_ref = anneeref
+        day_ref = dayref
+        day_ini = dayref
+        itau_dyn = 0
+        itau_phy = 0
+        time_0 = 0.
+        write(lunout,*)
+     .   'GCM: On reinitialise a la date lue dans gcm.def'
+      ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
+        write(lunout,*)
+     .  'GCM: Attention les dates initiales lues dans le fichier'
+        write(lunout,*)
+     .  ' restart ne correspondent pas a celles lues dans '
+        write(lunout,*)' gcm.def'
+        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+        write(lunout,*)' Pas de remise a zero'
+      ENDIF
+
+c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+c        write(lunout,*)
+c     .  'GCM: Attention les dates initiales lues dans le fichier'
+c        write(lunout,*)
+c     .  ' restart ne correspondent pas a celles lues dans '
+c        write(lunout,*)' gcm.def'
+c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+c        if (raz_date .ne. 1) then
+c          write(lunout,*)
+c     .    'GCM: On garde les dates du fichier restart'
+c        else
+c          annee_ref = anneeref
+c          day_ref = dayref
+c          day_ini = dayref
+c          itau_dyn = 0
+c          itau_phy = 0
+c          time_0 = 0.
+c          write(lunout,*)
+c     .   'GCM: On reinitialise a la date lue dans gcm.def'
+c        endif
+c      ELSE
+c        raz_date = 0
+c      endif
+
+#ifdef CPP_IOIPSL
+      mois = 1
+      heure = 0.
+! Ce n'est defini pour l'instant que pour la Terre... 
+      if (planet_type.eq.'earth') then
+      call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
+      jH_ref = jD_ref - int(jD_ref)
+      jD_ref = int(jD_ref)
+
+      call ioconf_startdate(INT(jD_ref), jH_ref)
+
+      write(lunout,*)'DEBUG'
+      write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
+      write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
+      call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
+      write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
+      write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
+      else
+! A voir pour Titan et Venus
+        jD_ref=0
+        jH_ref=0
+      write(lunout,*)'A VOIR POUR VENUS ET TITAN: jD_ref, jH_ref'
+      write(lunout,*)jD_ref,jH_ref
+      endif ! planet_type
+#else
+! Ehouarn: we still need to define JD_ref and JH_ref
+! and since we don't know how many days there are in a year
+! we set JD_ref to 0 (this should be improved ...)
+      jD_ref=0
+      jH_ref=0
+#endif
+
+      if (iflag_phys.eq.1) then
+      ! these initialisations have already been done (via iniacademic)
+      ! if running in SW or Newtonian mode
+c-----------------------------------------------------------------------
+c   Initialisation des constantes dynamiques :
+c   ------------------------------------------
+        dtvr = zdtvr
+        CALL iniconst
+
+c-----------------------------------------------------------------------
+c   Initialisation de la geometrie :
+c   --------------------------------
+        CALL inigeom
+
+c-----------------------------------------------------------------------
+c   Initialisation du filtre :
+c   --------------------------
+        CALL inifilr
+      endif ! of if (iflag_phys.eq.1)
+c
+c-----------------------------------------------------------------------
+c   Initialisation de la dissipation :
+c   ----------------------------------
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
+
+c-----------------------------------------------------------------------
+c   Initialisation de la physique :
+c   -------------------------------
+
+      IF (call_iniphys.and.(iflag_phys==1.or.iflag_phys>=100)) THEN
+         latfi(1)=rlatu(1)
+         lonfi(1)=0.
+         zcufi(1) = cu(1)
+         zcvfi(1) = cv(1)
+         DO j=2,jjm
+            DO i=1,iim
+               latfi((j-2)*iim+1+i)= rlatu(j)
+               lonfi((j-2)*iim+1+i)= rlonv(i)
+               zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i)
+               zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i)
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)
+         lonfi(ngridmx)= 0.
+         zcufi(ngridmx) = cu(ip1jm+1)
+         zcvfi(ngridmx) = cv(ip1jm-iim)
+
+         ! build airefi(), mesh area on physics grid
+         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+         ! Poles are single points on physics grid
+         airefi(1)=airefi(1)*iim
+         airefi(ngridmx)=airefi(ngridmx)*iim
+
+! Physics
+#ifdef CPP_PHYS
+         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys,
+     &                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp,
+     &                iflag_phys)
+#endif
+         call_iniphys=.false.
+      ENDIF ! of IF (call_iniphys.and.(iflag_phys==1.or.iflag_phys>=100))
+
+
+c-----------------------------------------------------------------------
+c   Initialisation des dimensions d'INCA :
+c   --------------------------------------
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+!$OMP PARALLEL
+         CALL init_inca_dim(klon_omp,llm,iim,jjm,
+     $        rlonu,rlatu,rlonv,rlatv)
+!$OMP END PARALLEL
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des I/O :
+c   ------------------------
+
+
+      if (nday>=0) then ! standard case
+        day_end=day_ini+nday
+      else ! special case when nday <0, run -nday dynamical steps
+        day_end=day_ini-nday/day_step
+      endif
+      if (less1day) then
+        day_end=day_ini+floor(time_0+fractday)
+      endif
+      if (ndynstep.gt.0) then
+        day_end=day_ini+floor(time_0+float(ndynstep)/float(day_step))
+      endif
+      
+      WRITE(lunout,'(a,i7,a,i7)')
+     &             "run from day ",day_ini,"  to day",day_end
+
+#ifdef CPP_IOIPSL
+! Ce n'est defini pour l'instant que pour la Terre... 
+      if (planet_type.eq.'earth') then
+      call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
+      write (lunout,301)jour, mois, an
+      call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
+      write (lunout,302)jour, mois, an
+      else
+! A voir pour Titan et Venus
+      write(lunout,*)'A VOIR POUR VENUS/TITAN: separation en annees...'
+      endif ! planet_type
+
+ 301  FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
+ 302  FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
+#endif
+
+      if (planet_type=="mars") then
+         ! For Mars we transmit day_ini
+        CALL dynredem0_p("restart.nc", day_ini, phis)
+      else
+        CALL dynredem0_p("restart.nc", day_end, phis)
+      endif
+      ecripar = .TRUE.
+
+#ifdef CPP_IOIPSL
+      time_step = zdtvr
+      IF (mpi_rank==0) then
+        if (ok_dyn_ins) then
+        ! initialize output file for instantaneous outputs
+        ! t_ops = iecri * daysec ! do operations every t_ops
+        t_ops =((1.0*iecri)/day_step) * daysec  
+        t_wrt = daysec ! iecri * daysec ! write output every t_wrt
+        CALL inithist(day_ref,annee_ref,time_step,
+     &                  t_ops,t_wrt)
+        endif
+
+        IF (ok_dyn_ave) THEN 
+          ! initialize output file for averaged outputs
+          t_ops = iperiod * time_step ! do operations every t_ops
+          t_wrt = periodav * daysec   ! write output every t_wrt
+          CALL initdynav(day_ref,annee_ref,time_step,
+     &                   t_ops,t_wrt)
+!         CALL initdynav_p(dynhistave_file,day_ref,annee_ref,time_step,
+!     .        t_ops, t_wrt, histaveid)
+        END IF
+      ENDIF
+      dtav = iperiod*dtvr/daysec
+#endif
+! #endif of #ifdef CPP_IOIPSL
+
+c  Choix des frequences de stokage pour le offline
+c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
+      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
+      istphy=istdyn/iphysiq     
+
+
+c
+c-----------------------------------------------------------------------
+c   Integration temporelle du modele :
+c   ----------------------------------
+
+c       write(78,*) 'ucov',ucov
+c       write(78,*) 'vcov',vcov
+c       write(78,*) 'teta',teta
+c       write(78,*) 'ps',ps
+c       write(78,*) 'q',q
+
+c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logici/,/logicl/)
+      CALL leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,
+     .              time_0)
+c$OMP END PARALLEL
+
+
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/geopot_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/geopot_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/geopot_p.F	(revision 222)
@@ -0,0 +1,66 @@
+      SUBROUTINE geopot_p ( 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"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+      INTEGER ngrid
+      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
+     *       phi(ngrid,llm)
+
+
+c   Local:
+c   ------
+      
+      INTEGER  l, ij,ijb,ije
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      IF (pole_sud)  ije=ij_end
+
+      DO  ij  = ijb, ije
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+      ENDDO
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = ijb,ije
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/getparam.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/getparam.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/getparam.F90	(revision 222)
@@ -0,0 +1,118 @@
+!
+! $Id: getparam.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE getparam
+#ifdef CPP_IOIPSL
+   USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+   USE ioipsl_getincom
+#endif
+
+   INTERFACE getpar
+     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml
+   END INTERFACE
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted')
+    
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+      IF (mpi_rank==0) CLOSE(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+    
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) comment
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+    
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+       
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_dyn_fi_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_dyn_fi_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_dyn_fi_p.F	(revision 222)
@@ -0,0 +1,44 @@
+!
+! $Id: gr_dyn_fi_p.F 1615 2012-02-10 15:42:26Z emillour $
+!
+      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
+#ifdef CPP_PHYS
+! Interface with parallel physics,
+      USE mod_interface_dyn_phys
+      USE dimphy
+      USE parallel_lmdz
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ig,l
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+c      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+c   traitement des poles
+c   traitement des point normaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,nfield    
+       DO ig=1,klon
+         i=index_i(ig)
+         j=index_j(ig)
+         pfi(ig,l)=pdyn(i,j,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+! of #ifdef CPP_PHYS
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_fi_dyn_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_fi_dyn_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_fi_dyn_p.F	(revision 222)
@@ -0,0 +1,56 @@
+!
+! $Id: gr_fi_dyn_p.F 1615 2012-02-10 15:42:26Z emillour $
+!
+      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
+#ifdef CPP_PHYS
+! Interface with parallel physics,
+      USE mod_interface_dyn_phys
+      USE dimphy
+      use parallel_lmdz
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO ifield=1,nfield
+
+        do ig=1,klon
+          i=index_i(ig)
+          j=index_j(ig)
+          pdyn(i,j,ifield)=pfi(ig,ifield)
+          if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield)
+	enddo
+
+c   traitement des poles
+      if (pole_nord) then
+        do i=1,im
+	  pdyn(i,1,ifield)=pdyn(1,1,ifield)
+	enddo
+      endif
+       
+      if (pole_sud) then
+        do i=1,im
+	  pdyn(i,jm,ifield)=pdyn(1,jm,ifield)
+	enddo
+      endif
+      
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+! of #ifdef CPP_PHYS
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_u_scal_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_u_scal_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_u_scal_p.F	(revision 222)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_u_scal_p(nx,x_u,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      USE parallel_lmdz
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+      INTEGER :: ijb,ije
+
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,nx
+         DO ij=ijb+1,ije
+            x_scal(ij,l)=
+     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
+     s      /(aireu(ij)+aireu(ij-1))
+         ENDDO
+      ENDDO
+
+cym      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+      ijb=ij_begin
+      ije=ij_end
+
+      DO l=1,nx
+         DO ij=ijb,ije-iip1+1,iip1
+	   x_scal(ij,l)=x_scal(ij+iip1-1,l)
+	 ENDDO
+      ENDDO
+      RETURN
+      
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_v_scal_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_v_scal_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gr_v_scal_p.F	(revision 222)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_v_scal_p(nx,x_v,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      USE parallel_lmdz
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+      INTEGER :: ijb,ije
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO l=1,nx
+         DO ij=ijb,ije
+            x_scal(ij,l)=
+     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
+     s      /(airev(ij-iip1)+airev(ij))
+         ENDDO
+      ENDDO
+      
+      if (pole_nord) then
+        DO l=1,nx
+           DO ij=1,iip1
+              x_scal(ij,l)=0.
+           ENDDO
+        ENDDO
+      endif
+    
+      if (pole_sud) then
+        DO l=1,nx
+           DO ij=ip1jm+1,ip1jmp1
+              x_scal(ij,l)=0.
+           ENDDO
+        ENDDO
+      endif
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/grad_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/grad_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/grad_p.F	(revision 222)
@@ -0,0 +1,53 @@
+      SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      USE parallel_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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gradiv2_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gradiv2_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gradiv2_p.F	(revision 222)
@@ -0,0 +1,147 @@
+      SUBROUTINE gradiv2_p(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+c
+c     P. Le Van
+c
+c   **********************************************************
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   **********************************************************
+c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
+      USE parallel_lmdz
+      USE times
+      USE Write_field_p
+      USE mod_hallo
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+c
+c     ........    variables en arguments      ........
+
+      INTEGER klevel
+      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE ::  gdx( ip1jmp1,llm ),  gdy( ip1jm,llm )
+      REAL   gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL,SAVE :: div(ip1jmp1,llm)
+      REAL      :: tmp_div2(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      INTEGER :: ijb,ije,jjb,jje
+      Type(Request)  :: request_dissip
+      
+c    ........................................................
+c
+c
+c      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+c      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO   l = 1, klevel
+        gdx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT      
+      
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO   l = 1, klevel
+        gdy(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP BARRIER
+       call Register_Hallo(gdy,ip1jm,llm,1,0,0,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+
+
+      CALL    divergf_p( klevel, gdx,   gdy , div )
+c      call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
+
+      IF( ld.GT.1 )   THEN
+c$OMP BARRIER
+       call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+	CALL laplacien_p ( klevel, div,  div     )
+
+c    ......  Iteration de l'operateur laplacien_gam   .......
+c         call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
+
+        DO iter = 1, ld -2
+c$OMP BARRIER
+       call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+
+c$OMP BARRIER
+
+         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
+     *                       unsapolnga1, unsapolsga1,  div, div       )
+        ENDDO
+c        call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
+      ENDIF
+
+       jjb=jj_begin
+       jje=jj_end
+       
+       CALL filtreg_p( div   ,jjb,jje, jjp1, klevel, 2, 1, .TRUE., 1 )
+c       call exchange_Hallo(div,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+       call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+
+c$OMP BARRIER
+
+
+       CALL  grad_p  ( klevel,  div,   gdx,  gdy             )
+
+c
+      ijb=ij_begin
+      ije=ij_end
+         
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+       DO   l = 1, klevel
+         
+         if (pole_sud) ije=ij_end
+         DO  ij = ijb, ije
+          gdx_out( ij,l ) = gdx( ij,l ) * nugrads
+         ENDDO
+         
+         if (pole_sud) ije=ij_end-iip1
+         DO  ij = ijb, ije
+          gdy_out( ij,l ) = gdy( ij,l ) * nugrads
+         ENDDO
+       
+       ENDDO
+c$OMP END DO NOWAIT
+c
+       RETURN
+       END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gradiv_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gradiv_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/gradiv_p.F	(revision 222)
@@ -0,0 +1,109 @@
+      SUBROUTINE gradiv_p(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+c
+c    Auteur :   P. Le Van
+c
+c   ***************************************************************
+c
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   ****************************************************************
+c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+c
+c     
+      USE parallel_lmdz
+      USE times
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE :: gdx( ip1jmp1,llm ),   gdy( ip1jm,llm )
+
+      REAL gdx_out( ip1jmp1,klevel ),   gdy_out( ip1jm,klevel )
+
+      REAL,SAVE ::  div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+c      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+      
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1,klevel
+        gdx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1,klevel
+        gdy(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+      DO 10 iter = 1,ld
+
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(gdy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER      
+c$OMP BARRIER
+
+      CALL  diverg_p( klevel,  gdx , gdy, div          )
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2,1, .true.,2 )
+      
+c      call exchange_Hallo(div,ip1jmp1,llm,0,1)
+
+c$OMP BARRIER
+c$OMP MASTER       
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(div,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL    grad_p( klevel,  div, gdx, gdy           )
+c
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 5  l = 1, klevel
+      
+      if(pole_sud) ije=ij_end
+      DO 3 ij = ijb, ije
+        gdx_out( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+   
+      if(pole_sud) ije=ij_end-iip1
+      DO 4 ij = ijb, ije
+        gdy_out( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/groupe_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/groupe_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/groupe_p.F	(revision 222)
@@ -0,0 +1,143 @@
+      subroutine groupe_p(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      USE parallel_lmdz
+      implicit none
+
+c   sous-programme servant a fitlrer les champs de flux de masse aux
+c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+c   et a mesure qu'on se rapproche du pole.
+c
+c   en entree: pext, pbaru et pbarv
+c
+c   en sortie:  pbarum,pbarvm et wm.
+c
+c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+c   pas besoin de w en entree.
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "comvert.h"
+
+      integer ngroup
+      parameter (ngroup=3)
+
+
+      real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
+      real pext(iip1,jjp1,llm)
+
+      real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
+      real wm(iip1,jjp1,llm)
+
+      real,save :: zconvm(iip1,jjp1,llm)
+      real,save :: zconvmm(iip1,jjp1,llm)
+
+      real uu
+
+      integer i,j,l
+
+      logical firstcall,groupe_ok
+      save firstcall,groupe_ok
+c$OMP THREADPRIVATE(firstcall,groupe_ok)
+
+      data firstcall/.true./
+      data groupe_ok/.true./
+
+      integer ijb,ije,jjb,jje
+      
+      if (iim==1) then
+         groupe_ok=.false.
+      endif
+
+      if (firstcall) then
+         if (groupe_ok) then
+           if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre de point'
+         endif
+         firstcall=.false.
+      endif
+
+c   Champs 1D
+
+      call convflu_p(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
+
+      if (groupe_ok) then
+         call groupeun_p(jjp1,llm,jjb,jje,zconvmm)
+      endif
+      
+      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
+
+      if (groupe_ok) then
+         call groupeun_p(jjm,llm,jjb,jje,pbarvm)
+      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_p(zconvmm(1,1,1),wm(1,1,1))
+
+      return
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/groupeun_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/groupeun_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/groupeun_p.F	(revision 222)
@@ -0,0 +1,201 @@
+      SUBROUTINE groupeun_p(jjmax,llmax,jjb,jje,q)
+      USE parallel_lmdz
+      USE Write_Field_p
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      INTEGER jjmax,llmax,jjb,jje
+      REAL q(iip1,jjmax,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 à 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_P(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_P(airen_tab, aires_tab)
+
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      INTEGER ngroup
+      PARAMETER (ngroup=3)
+
+      REAL airen,airecn
+      REAL aires,airecs
+
+      INTEGER i,j,l,ig,j1,j2,i0,jd
+
+      INTEGER j_start, j_finish
+
+      REAL :: airen_tab(iip1,jjp1,0:1)
+      REAL :: aires_tab(iip1,jjp1,0:1)
+
+      DO jd=0, 1
+         j1=1+jd
+         j2=2
+         DO ig=1,ngroup
+            
+!     c     Concerne le pole nord
+            j_start = j1-jd
+            j_finish = j2-jd
+            DO j=j_start, j_finish
+               DO i0=1,iim,2**(ngroup-ig+1)
+                  airen=0.
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     airen = airen+aire(i,j)
+                  ENDDO
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     airen_tab(i,j,jd) = 
+     &                    aire(i,j) / airen
+                  ENDDO
+               ENDDO
+            ENDDO
+            
+!     c     Concerne le pole sud
+            j_start = j1-jd
+            j_finish = j2-jd
+            DO j=j_start, j_finish
+               DO i0=1,iim,2**(ngroup-ig+1)
+                  aires=0.
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     aires=aires+aire(i,jjp1-j+1)
+                  ENDDO
+                  DO i=i0,i0+2**(ngroup-ig+1)-1
+                     aires_tab(i,jjp1-j+1,jd) = 
+     &                    aire(i,jjp1-j+1) / aires
+                  ENDDO
+               ENDDO
+            ENDDO
+            
+            j1=j2+1
+            j2=j2+2**ig
+         ENDDO
+      ENDDO
+      
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/guide_p_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/guide_p_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/guide_p_mod.F90	(revision 222)
@@ -0,0 +1,2002 @@
+!
+! $Id$
+!
+MODULE guide_p_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam
+  USE Write_Field_p
+  USE netcdf, ONLY: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
+  USE pres2lev_mod
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+  
+  INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v
+  INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v
+
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+    
+    USE control_mod
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'forÃ¯Â¿Âœage constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    
+! Sauvegarde du forÃ¯Â¿Âœage
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+        iguide_sav=day_step/iguide_sav
+    ELSE
+        iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
+    IF (iguide_int.EQ.0) THEN
+        iguide_int=1
+    ELSEIF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
+    ! Pour compatibilite avec ancienne version avec guide_modele
+    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
+    IF (guide_modele) THEN
+        guide_plevs=1
+    ENDIF
+    ! Fin raccord
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_plevs.EQ.1) then
+       if (ncidpl.eq.-99) then 
+          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier apbp.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_plevs.EQ.2) then
+       if (ncidpl.EQ.-99) then 
+          rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_u) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier u.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_v) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier v.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_T) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier T.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_Q) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             print *,'Guide: probleme -> pas de fichier hur.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        print *,'Guide: probleme lecture niveaux pression'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    print *,'Guide: nombre niveaux vert. nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='pb in allocation guide'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ip1jm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_plevs.EQ.2) THEN
+        ALLOCATE(pnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(pnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        pnat1=0.;pnat2=0.;
+    ENDIF
+
+    IF (guide_P.OR.guide_plevs.EQ.1) THEN
+        ALLOCATE(psnat1(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_plevs.EQ.2) pnat1=pnat2
+    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+    use exner_hyb_p_m, only: exner_hyb_p
+    use exner_milieu_p_m, only: exner_milieu_p
+    USE parallel_lmdz
+    USE control_mod
+    
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+
+    ! Variables entree
+    INTEGER,                       INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
+    ! Variables pour fonction Exner (P milieu couche)
+    REAL, DIMENSION (iip1,jjp1,llm)    :: pk
+    REAL, DIMENSION (iip1,jjp1)        :: pks    
+    REAL                               :: unskap
+    REAL, DIMENSION (ip1jmp1,llmp1)    :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+    
+    INTEGER       :: i,j,l
+    
+    ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1  
+    jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 
+    ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1   
+    jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 
+    IF (pole_sud) THEN
+      ije_v=ij_end-iip1
+      jje_v=jj_end-1
+      ijn_v=ije_v-ijb_v+1
+      jjn_v=jje_v-jjb_v+1 
+    ENDIF
+      
+     PRINT *,'---> on rentre dans guide_main'
+!    CALL AllGather_Field(ucov,ip1jmp1,llm)
+!    CALL AllGather_Field(vcov,ip1jm,llm)
+!    CALL AllGather_Field(teta,ip1jmp1,llm)
+!    CALL AllGather_Field(ps,ip1jmp1,1)
+!    CALL AllGather_Field(q,ip1jmp1,llm)
+    
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+
+    IF (first) THEN
+        first=.FALSE.
+        CALL guide_init 
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
+            enddo
+        endif
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:)
+            IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:)
+            IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:)
+            IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)
+            IF (guide_P) THEN
+                ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u)
+                CALL pression_p(ip1jmp1,ap,bp,ps,p)
+                CALL massdair_p(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+        IF (guide_u) THEN
+            CALL writefield_p('unat',unat1)
+            CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
+        ENDIF
+        IF (guide_T) THEN
+            CALL writefield_p('tnat',tnat1)
+            CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/REAL(iguide_read)
+      ELSE
+          tau=REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+              write(*,*)'deuxieme passage de advreel a itau=',itau
+              stop
+          ELSE
+              IF (guide_v) vnat1(:,jjb_v:jje_v,:)=vnat2(:,jjb_v:jje_v,:)
+              IF (guide_u) unat1(:,jjb_u:jje_u,:)=unat2(:,jjb_u:jje_u,:)
+              IF (guide_T) tnat1(:,jjb_u:jje_u,:)=tnat2(:,jjb_u:jje_u,:)
+              IF (guide_Q) qnat1(:,jjb_u:jje_u,:)=qnat2(:,jjb_u:jje_u,:)
+              IF (guide_plevs.EQ.2) pnat1(:,jjb_u:jje_u,:)=pnat2(:,jjb_u:jje_u,:)
+              IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjb_u:jje_u)=psnat2(:,jjb_u:jje_u)
+              step_rea=step_rea+1
+              itau_test=itau
+              print*,'Lecture fichiers guidage, pas ',step_rea, &
+                    'apres ',count_no_rea,' non lectures'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) THEN
+!       Calcul niveaux pression milieu de couches 
+        CALL pression_p( ip1jmp1, ap, bp, ps, p )
+        if (pressure_exner) then
+          CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk)
+        else
+          CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk)
+        endif
+        unskap=1./kappa
+        DO l = 1, llm
+           DO j=jjb_u,jje_u
+              DO i =1, iip1
+                 p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+              ENDDO
+           ENDDO
+        ENDDO
+        CALL guide_out("SP",jjp1,llm,p(1:ip1jmp1,1:llm),1.)
+    ENDIF
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:)
+        endif 
+
+        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("u",jjp1,llm,ucov,factt)
+        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1(:,:)+tau*ugui2(:,:),factt)
+        IF (f_out) CALL guide_out("ucov",jjp1,llm,f_add(:,:)/factt,factt)
+        ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("teta",jjp1,llm,f_add(:,:)/factt,factt)
+        teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)
+        else
+           f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
+        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
+        IF (f_out) CALL guide_out("ps",jjp1,1,f_add(1:ip1jmp1,1)/factt,factt)
+        ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1)
+        CALL pression_p(ip1jmp1,ap,bp,ps,p)
+        CALL massdair_p(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)
+        else
+           f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:)
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("q",jjp1,llm,f_add(:,:)/factt,factt)
+        q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:)
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)
+        else
+           f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:)
+        endif 
+        
+        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
+        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
+        IF (f_out) CALL guide_out("v",jjm,llm,vcov(1:ip1jm,:),factt)
+        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1(:,:)+tau*vgui2(:,:),factt)
+        IF (f_out) CALL guide_out("vcov",jjm,llm,f_add(1:ip1jm,:)/factt,factt)
+        vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:)
+    endif
+
+  END SUBROUTINE guide_main
+
+!=======================================================================
+  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: hsize
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    IF (hsize==ip1jm) THEN
+      do l=1,vsize
+        field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l)
+      enddo
+    ELSE
+      do l=1,vsize
+        field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l)
+      enddo
+    ENDIF    
+
+  END SUBROUTINE guide_addfield
+
+!=======================================================================
+  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    INCLUDE "comconst.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    
+    IF (hsize==jjm) THEN
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_v,jje_v
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ELSE
+      DO l=1,vsize
+      ! Compute zonal average
+          DO j=jjb_v,jje_v
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO 
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjb_u,jje_u
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+    ENDIF    
+
+  END SUBROUTINE guide_zonave
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+    use exner_hyb_p_m, only: exner_hyb_p
+    use exner_milieu_p_m, only: exner_milieu_p
+  USE parallel_lmdz
+  USE mod_hallo
+  USE Bands
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comvert.h"
+  include "comgeom2.h"
+  include "comconst.h"
+
+  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
+  REAL, DIMENSION (iip1,jjp1,llmp1)  :: p           ! pression intercouches 
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pbarx 
+  REAL, DIMENSION (iip1,jjm,llm)     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
+  REAL, DIMENSION (iip1,jjp1)        :: pks    
+  REAL                               :: unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
+  !Variables intermediaires interpolation
+  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
+  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  TYPE(Request) :: Req  
+
+    print *,'Guide: conversion variables guidage'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage (pour T et Q)
+! -----------------------------------------------------------------
+    IF (guide_plevs.EQ.0) THEN
+        DO l=1,nlevnc
+            DO j=jjb_u,jje_u
+                DO i=1,iip1
+                    plnc2(i,j,l)=apnc(l)
+                    plnc1(i,j,l)=apnc(l)
+               ENDDO
+            ENDDO
+        ENDDO
+    ENDIF   
+
+    if (first) then
+        first=.FALSE.
+        print*,'Guide: verification ordre niveaux verticaux'
+        print*,'LMDZ :'
+        do l=1,llm
+            print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jje_u)*(bp(l)+bp(l+1))/2.
+        enddo
+        print*,'Fichiers guidage'
+        SELECT CASE (guide_plevs)
+        CASE (0) 
+            do l=1,nlevnc
+                 print*,'PL(',l,')=',plnc2(1,jjb_u,l)
+            enddo
+        CASE (1)
+            DO l=1,nlevnc
+                 print*,'PL(',l,')=',apnc(l)+bpnc(l)*psnat2(i,jjb_u)
+             ENDDO
+        CASE (2)
+            do l=1,nlevnc
+                 print*,'PL(',l,')=',pnat2(1,jjb_u,l)
+            enddo
+        END SELECT
+        print *,'inversion de l''ordre: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+                print*,'U(',l,')=',unat2(1,jjb_u,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+                print*,'T(',l,')=',tnat2(1,jjb_u,l)
+            enddo
+        endif
+    endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    IF (guide_plevs.EQ.1) THEN
+        DO l=1,llm
+            DO j=jjb_u,jje_u
+                DO i =1, iip1
+                    pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
+                ENDDO
+            ENDDO
+        ENDDO
+    ELSE
+        CALL pression_p( ip1jmp1, ap, bp, psi, p )
+        if (pressure_exner) then
+          CALL exner_hyb_p(ip1jmp1,psi,p,pks,pk)
+        else
+          CALL exner_milieu_p(ip1jmp1,psi,p,pks,pk)
+        endif
+        unskap=1./kappa
+        DO l = 1, llm
+            DO j=jjb_u,jje_u
+                DO i =1, iip1
+                    pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+                ENDDO
+            ENDDO
+        ENDDO
+    ENDIF
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+
+     CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+     CALL SendRequest(Req)
+     CALL WaitRequest(Req)
+
+     call massbar_p(pext, pbarx, pbary )
+    do l=1,llm
+        do j=jjb_u,jje_u
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=jjb_v,jje_v
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation verticale champs guidage sur niveaux modele
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=jjb_u,jje_u
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_T) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+        CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                    plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,           &
+                    plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjb_u,jje_u
+                IF (guide_teta) THEN
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)
+                    enddo
+                ELSE
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+                    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(i,l)=tgui2(1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+            enddo
+        enddo
+    ENDIF
+
+    IF (guide_Q) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+        CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,             &
+                      plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        ! Conversion en variables GCM
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        do l=1,llm
+            do j=jjb_u,jje_u
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(i,l)=qgui2(1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+            enddo
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp,       &
+                       plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:))
+            qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en %
+            qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 
+        ENDIF
+    ENDIF
+
+    IF (guide_u) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iim
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+            DO l=1,nlevnc
+                DO j=jjb_u,jje_u
+                    DO i=1,iim
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ENDIF
+        
+        ! Interpolation verticale
+        CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+        CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm,            &
+                      plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p)
+
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjb_u,jje_u
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                ugui1(i,l)=0.
+                ugui1(ip1jm+i,l)=0.
+                ugui2(i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_v) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+         CALL Register_SwapFieldHallo(psnat1,psnat1,ip1jmp1,1,jj_Nb_caldyn,1,2,Req)
+         CALL SendRequest(Req)
+         CALL WaitRequest(Req)
+         CALL Register_SwapFieldHallo(psnat2,psnat2,ip1jmp1,1,jj_Nb_caldyn,1,2,Req)
+         CALL SendRequest(Req)
+         CALL WaitRequest(Req)
+            DO l=1,nlevnc
+                DO j=jjb_v,jje_v
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+         CALL Register_SwapFieldHallo(pnat1,pnat1,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+         CALL SendRequest(Req)
+         CALL WaitRequest(Req)
+         CALL Register_SwapFieldHallo(pnat2,pnat2,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req)
+         CALL SendRequest(Req)
+         CALL WaitRequest(Req)
+            DO l=1,nlevnc
+                DO j=jjb_v,jje_v
+                    DO i=1,iip1
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+        ! Interpolation verticale
+        CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+        CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm,             &
+                      plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p)
+        ! Conversion en variables GCM
+        do l=1,llm
+            do j=jjb_v,jje_v
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comconst.h"
+    include "comgeom2.h"
+    include "serre.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                 print*,'ATTENTION modele peu zoome'
+                 print*,'ATTENTION on prend une constante de guidage cste'
+                 gamma=0.
+            else
+                gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+                print*,'gamma=',gamma
+                if (gamma.lt.1.e-5) then
+                  print*,'gamma =',gamma,'<1e-5'
+                  stop
+                endif
+                gamma=log(0.5)/log(gamma)
+                if (gamma4) then 
+                  gamma=min(gamma,4.)
+                endif
+                print*,'gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read'
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Ap et Bp si Niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             print *,'Lecture du guidage sur niveaux modele'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable BP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression si guidage sur niveaux P variables
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable PRES, fichier P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF 
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable UWND, fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable VWND, fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AIR, fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable RH, fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable SP, fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         IF (guide_plevs.EQ.1) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         ELSEIF (guide_plevs.EQ.0) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         ENDIF
+         first=.FALSE.
+     ENDIF ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+! Pression 
+     if (guide_plevs.EQ.2) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,pnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidp,varidp,start,count,pnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
+         ENDIF
+     endif
+
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
+#endif
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjp1,llm) :: zu
+    REAL, DIMENSION (jjm,llm)  :: zv
+    INTEGER               :: i
+
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read2D'
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         print*,'Guide: ouverture des fichiers guidage '
+! Ap et Bp si niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             print *,'Lecture du guidage sur niveaux modÃ¯Â¿Âœle'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable BP, fichier apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable PRES, fichier P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable UWND, fichier u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF 
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable VWND, fichier v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable AIR, fichier T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable RH, fichier hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              print *,'Guide: probleme -> pas de variable SP, fichier ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             print*,'ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              print*,'ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_plevs.EQ.1) then
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
+             status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
+#endif
+         elseif (guide_plevs.EQ.0) THEN
+#ifdef NC_DOUBLE
+             status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
+#else
+             status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
+#endif
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Pression
+     if (guide_plevs.EQ.2) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidp,varidp,start,count,zu)
+#endif
+         DO i=1,iip1
+             pnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
+         ENDIF
+     endif
+!  Vent zonal
+     if (guide_u) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
+#endif
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+     endif
+
+!  Temperature
+     if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
+#endif
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
+#endif
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+         
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
+#endif
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
+#endif
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field,factt)
+    USE parallel_lmdz
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    INCLUDE "comconst.h"
+    INCLUDE "comvert.h"
+    
+    ! Variables entree
+    CHARACTER*(*), INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+    REAL, INTENT (IN)                              :: factt
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER       :: vid_au,vid_av
+    INTEGER       :: l
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid
+    REAL, DIMENSION (iip1,hsize,vsize) :: field2
+    
+    CALL gather_field(field,iip1*hsize,vsize,0)
+    
+    IF (mpi_rank /= 0) RETURN
+    
+    print *,'Guide: output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        print*,'id_lonu 1 ',id_lonu
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        print*,'id_lonu 2 ',id_lonu
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au)
+        ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+#ifdef NC_DOUBLE
+        print*,'id_lonu DOUBLE ',id_lonu,rlonu*180./pi
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_au,alpha_u)
+        ierr = NF_PUT_VAR_DOUBLE(nid,vid_av,alpha_v)
+#else
+        print*,'id_lonu 3 ',id_lonu,rlonu*180./pi
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
+        ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
+        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
+        ierr = NF_PUT_VAR_REAL(nid,vid_au,alpha_u)
+        ierr = NF_PUT_VAR_REAL(nid,vid_av,alpha_v)
+#endif
+! --------------------------------------------------------------------
+! CrÃ¯Â¿Âœation des variables sauvegardÃ¯Â¿Âœes
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Pressure (GCM)
+        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,4,dim4,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+        print*,'id_lonu 4 ',id_lonu,varname
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+ 
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    IF (varname=="SP") timestep=timestep+1
+
+    IF (varname=="SP") THEN
+      print*,'varname=SP=',varname
+    ELSE
+      print*,'varname diff SP=',varname
+    ENDIF
+
+
+    ierr = NF_INQ_VARID(nid,varname,varid)
+    SELECT CASE (varname)
+    CASE ("SP","ps")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    CASE ("v","va","vcov")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+    CASE DEFAULT
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    END SELECT
+
+    SELECT CASE (varname)
+    CASE("u","ua")
+        DO l=1,llm ; field2(:,2:jjm,l)=field(:,2:jjm,l)/cu(:,2:jjm) ; ENDDO
+        field2(:,1,:)=0. ; field2(:,jjp1,:)=0.
+    CASE("v","va")
+        DO l=1,llm ; field2(:,:,l)=field(:,:,l)/cv(:,:) ; ENDDO
+    CASE DEFAULT
+        field2=field
+    END SELECT
+
+#ifdef NC_DOUBLE
+    ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field2)
+#else
+    ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field2)
+#endif
+ 
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_p_mod
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/init_gcm_lmdz.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/init_gcm_lmdz.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/init_gcm_lmdz.F	(revision 222)
@@ -0,0 +1,633 @@
+!
+! $Id: gcm.F 1446 2010-10-22 09:27:25Z emillour $
+!
+c
+c
+      SUBROUTINE init_gcm_lmdz(nbp,nproc,distrib_icosa,latfi,lonfi,
+     &                         airefi)
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+
+
+      USE mod_const_mpi, ONLY: init_const_mpi
+      USE parallel_lmdz
+      USE infotrac
+      USE mod_interface_dyn_phys
+      USE mod_hallo
+      USE Bands
+      USE getparam
+      USE filtreg_mod
+      USE control_mod, only: planet_type,nday,day_step,iperiod,iphysiq,
+     &                       raz_date,anneeref,starttime,dayref,
+     &                       ok_dyn_ins,ok_dyn_ave,iecri,periodav,
+     &                       less1day,fractday,ndynstep,nsplit_phys
+      use cpdet_mod, only: ini_cpdet
+
+
+#ifdef INCA
+! Only INCA needs these informations (from the Earth's physics)
+      USE indice_sol_mod
+#endif
+
+! Ehouarn: the following are needed with (parallel) physics:
+#ifdef CPP_PHYS
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+      USE mod_phys_lmdz_omp_data, ONLY: klon_omp 
+      USE dimphy
+      USE comgeomphy
+#endif
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: nbp
+      INTEGER, INTENT(IN) :: nproc
+      INTEGER, INTENT(IN) :: distrib_icosa(nproc)
+      REAL, INTENT(IN) :: latfi(nbp)
+      REAL, INTENT(IN) :: lonfi(nbp)
+      REAL, INTENT(IN) :: airefi(nbp)
+
+      REAL :: zcufi(nbp)
+      REAL :: zcvfi(nbp)
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+c  ... Possibilite de choisir le schema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+!!!!!!!!!!!#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+!#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "tracstoke.h"
+#ifdef INCA
+! Only INCA needs these informations (from the Earth's physics)
+#include "indicesol.h"
+#endif
+
+
+      REAL zdtvr
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+c      REAL pks(ip1jmp1)                      ! exner au  sol
+c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+c      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+c      REAL w(ip1jmp1,llm)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL time_0
+
+      LOGICAL lafin
+c      INTEGER ij,iq,l,i,j
+      INTEGER i,j
+
+
+      real time_step, t_wrt, t_ops
+
+
+      LOGICAL call_iniphys
+      data call_iniphys/.true./
+
+c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+c+jld variables test conservation energie
+c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+c      REAL dhecdt(ip1jmp1,llm)
+c      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+c      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+c      CHARACTER (len=15) :: ztit
+c-jld 
+
+
+      character (len=80) :: dynhist_file, dynhistave_file
+      character (len=20) :: modname
+      character (len=80) :: abort_message
+! locales pour gestion du temps
+      INTEGER :: an, mois, jour
+      REAL :: heure
+
+
+c-----------------------------------------------------------------------
+c    variables pour l'initialisation de la physique :
+c    ------------------------------------------------
+      INTEGER ngridmx
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+!      REAL zcufi(ngridmx),zcvfi(ngridmx)
+!      REAL latfi(ngridmx),lonfi(ngridmx)
+!      REAL airefi(ngridmx)
+!      SAVE latfi, lonfi, airefi
+      
+      INTEGER :: ierr
+
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      abort_message = 'last timestep reached'
+      modname = 'gcm'
+      descript = 'Run GCM LMDZ'
+      lafin    = .FALSE.
+      dynhist_file = 'dyn_hist'
+      dynhistave_file = 'dyn_hist_ave'
+
+
+
+c----------------------------------------------------------------------
+c  lecture des fichiers gcm.def ou run.def
+c  ---------------------------------------
+c
+! Ehouarn: dump possibility of using defrun
+!#ifdef CPP_IOIPSL
+      CALL conf_gcm( 99, .TRUE. )
+!#else
+!      CALL defrun( 99, .TRUE. , clesphy0 )
+!#endif
+c
+c
+c------------------------------------
+c   Initialisation partie parallele
+c------------------------------------
+
+      CALL init_const_mpi
+!      call init_parallel
+      call ini_getparam("out.def")
+!      call Read_Distrib
+
+#ifdef CPP_PHYS
+!        CALL init_phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys)
+        CALL Init_Phys_lmdz(iim,jjp1,llm,nproc,distrib_icosa)
+#endif
+!      CALL set_bands
+!#ifdef CPP_PHYS
+!      CALL Init_interface_dyn_phys
+!#endif
+!      CALL barrier
+
+!      if (mpi_rank==0) call WriteBands
+!      call SetDistrib(jj_Nb_Caldyn)
+
+!c$OMP PARALLEL
+!      call Init_Mod_hallo
+!c$OMP END PARALLEL
+
+#ifdef CPP_PHYS
+c$OMP PARALLEL
+      call initcomgeomphy
+c$OMP END PARALLEL 
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Initialisation de XIOS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+c
+c Initialisations pour Cp(T) Venus
+      call ini_cpdet
+c
+c-----------------------------------------------------------------------
+c   Choix du calendrier
+c   -------------------
+
+c      calend = 'earth_365d'
+
+#ifdef CPP_IOIPSL
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360d')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+      else if (calend == 'earth_365d') then
+        call ioconf_calendar('noleap')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+      else if (calend == 'earth_366d') then
+        call ioconf_calendar('gregorian')
+        write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
+      else if (calend == 'titan') then
+!        call ioconf_calendar('titan')
+        write(lunout,*)'CALENDRIER CHOISI: Titan'
+        abort_message = 'A FAIRE...'
+        call abort_gcm(modname,abort_message,1)
+      else if (calend == 'venus') then
+!        call ioconf_calendar('venus')
+        write(lunout,*)'CALENDRIER CHOISI: Venus'
+        abort_message = 'A FAIRE...'
+        call abort_gcm(modname,abort_message,1)
+      else
+        abort_message = 'Mauvais choix de calendrier'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#endif
+c-----------------------------------------------------------------------
+
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+         call init_const_lmdz(
+     $        nbtr,anneeref,dayref,
+     $        iphysiq,day_step,nday, 
+     $        nbsrf, is_oce,is_sic,
+     $        is_ter,is_lic)
+
+         call init_inca_para(
+     $        iim,jjm+1,llm,klon_glo,mpi_size,
+     $        distrib_phys,COMM_LMDZ)
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des traceurs
+c   ---------------------------
+c  Choix du nombre de traceurs et du schema pour l'advection
+c  dans fichier traceur.def, par default ou via INCA
+      call infotrac_init
+
+c Allocation de la tableau q : champs advectes   
+      ALLOCATE(q(ip1jmp1,llm,nqtot))
+
+c-----------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+
+c  lecture du fichier start.nc
+!      if (read_start) then
+!      ! we still need to run iniacademic to initialize some
+!      ! constants & fields, if we run the 'newtonian' or 'SW' cases:
+!        if (iflag_phys.ne.1) then
+!          CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+!        endif
+!
+!        CALL dynetat0("start.nc",vcov,ucov,
+!     &              teta,q,masse,ps,phis, time_0)
+!       
+!        ! Load relaxation fields (simple nudging). AS 09/2013
+!        ! ---------------------------------------------------
+!        if (planet_type.eq."generic") then
+!         if (ok_guide) then
+!           CALL relaxetat0("relax.nc")
+!         endif
+!        endif
+ 
+c       write(73,*) 'ucov',ucov
+c       write(74,*) 'vcov',vcov
+c       write(75,*) 'teta',teta
+c       write(76,*) 'ps',ps
+c       write(77,*) 'q',q
+
+!      endif ! of if (read_start)
+
+c le cas echeant, creation d un etat initial
+      IF (prt_level > 9) WRITE(lunout,*)
+     .              'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
+      if (.not.read_start) then
+         CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+      endif
+
+
+c-----------------------------------------------------------------------
+c   Lecture des parametres de controle pour la simulation :
+c   -------------------------------------------------------
+c  on recalcule eventuellement le pas de temps
+      call conf_planete
+      dtvr    = daysec/REAL(day_step)
+      zdtvr=dtvr
+      CALL iniconst
+      CALL inigeom
+      CALL inifilr
+
+      IF(MOD(day_step,iperiod).NE.0) THEN
+        abort_message = 
+     .  'Il faut choisir un nb de pas par jour multiple de iperiod'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      IF(MOD(day_step,iphysiq).NE.0) THEN
+        abort_message = 
+     * 'Il faut choisir un nb de pas par jour multiple de iphysiq'
+        call abort_gcm(modname,abort_message,1)
+      ENDIF
+
+      zdtvr    = daysec/REAL(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         WRITE(lunout,*)
+     .    'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+C
+C on remet le calendrier à zero si demande
+c
+      IF (start_time /= starttime) then
+        WRITE(lunout,*)' GCM: Attention l''heure de depart lue dans le'
+     &,' fichier restart ne correspond pas à celle lue dans le run.def'
+        IF (raz_date == 1) then
+          WRITE(lunout,*)'Je prends l''heure lue dans run.def'
+          start_time = starttime
+        ELSE
+          call abort_gcm("gcm", "'Je m''arrete'", 1)
+        ENDIF
+      ENDIF
+      IF (raz_date == 1) THEN
+        annee_ref = anneeref
+        day_ref = dayref
+        day_ini = dayref
+        itau_dyn = 0
+        itau_phy = 0
+        time_0 = 0.
+        write(lunout,*)
+     .   'GCM: On reinitialise a la date lue dans gcm.def'
+      ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
+        write(lunout,*)
+     .  'GCM: Attention les dates initiales lues dans le fichier'
+        write(lunout,*)
+     .  ' restart ne correspondent pas a celles lues dans '
+        write(lunout,*)' gcm.def'
+        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+        write(lunout,*)' Pas de remise a zero'
+      ENDIF
+
+c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+c        write(lunout,*)
+c     .  'GCM: Attention les dates initiales lues dans le fichier'
+c        write(lunout,*)
+c     .  ' restart ne correspondent pas a celles lues dans '
+c        write(lunout,*)' gcm.def'
+c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+c        if (raz_date .ne. 1) then
+c          write(lunout,*)
+c     .    'GCM: On garde les dates du fichier restart'
+c        else
+c          annee_ref = anneeref
+c          day_ref = dayref
+c          day_ini = dayref
+c          itau_dyn = 0
+c          itau_phy = 0
+c          time_0 = 0.
+c          write(lunout,*)
+c     .   'GCM: On reinitialise a la date lue dans gcm.def'
+c        endif
+c      ELSE
+c        raz_date = 0
+c      endif
+
+#ifdef CPP_IOIPSL
+      mois = 1
+      heure = 0.
+! Ce n'est defini pour l'instant que pour la Terre... 
+      if (planet_type.eq.'earth') then
+      call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
+      jH_ref = jD_ref - int(jD_ref)
+      jD_ref = int(jD_ref)
+
+!      call ioconf_startdate(INT(jD_ref), jH_ref)
+
+      write(lunout,*)'DEBUG'
+      write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
+      write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
+      call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
+      write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
+      write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
+      else
+! A voir pour Titan et Venus
+        jD_ref=0
+        jH_ref=0
+      write(lunout,*)'A VOIR POUR VENUS ET TITAN: jD_ref, jH_ref'
+      write(lunout,*)jD_ref,jH_ref
+      endif ! planet_type
+#else
+! Ehouarn: we still need to define JD_ref and JH_ref
+! and since we don't know how many days there are in a year
+! we set JD_ref to 0 (this should be improved ...)
+      jD_ref=0
+      jH_ref=0
+#endif
+
+      if (iflag_phys.eq.1) then
+      ! these initialisations have already been done (via iniacademic)
+      ! if running in SW or Newtonian mode
+c-----------------------------------------------------------------------
+c   Initialisation des constantes dynamiques :
+c   ------------------------------------------
+        dtvr = zdtvr
+        CALL iniconst
+
+c-----------------------------------------------------------------------
+c   Initialisation de la geometrie :
+c   --------------------------------
+        CALL inigeom
+
+c-----------------------------------------------------------------------
+c   Initialisation du filtre :
+c   --------------------------
+!        CALL inifilr
+      endif ! of if (iflag_phys.eq.1)
+c
+c-----------------------------------------------------------------------
+c   Initialisation de la dissipation :
+c   ----------------------------------
+
+!      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+!     *                tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
+
+c-----------------------------------------------------------------------
+c   Initialisation de la physique :
+c   -------------------------------
+
+!      IF (call_iniphys.and.(iflag_phys==1.or.iflag_phys>=100)) THEN
+!         latfi(1)=rlatu(1)
+!         lonfi(1)=0.
+!         zcufi(1) = cu(1)
+!         zcvfi(1) = cv(1)
+!         DO j=2,jjm
+!            DO i=1,iim
+!               latfi((j-2)*iim+1+i)= rlatu(j)
+!               lonfi((j-2)*iim+1+i)= rlonv(i)
+!               zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i)
+!               zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i)
+!            ENDDO
+!         ENDDO
+!         latfi(ngridmx)= rlatu(jjp1)
+!         lonfi(ngridmx)= 0.
+!         zcufi(ngridmx) = cu(ip1jm+1)
+!         zcvfi(ngridmx) = cv(ip1jm-iim)
+!
+!         ! build airefi(), mesh area on physics grid
+!         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+!         ! Poles are single points on physics grid
+!         airefi(1)=airefi(1)*iim
+!         airefi(ngridmx)=airefi(ngridmx)*iim
+
+! Physics
+#ifdef CPP_PHYS
+!         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys,
+!     &                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp,
+!     &                iflag_phys)
+
+         zcufi(nbp)=1.
+         zcvfi(nbp)=1.
+
+         CALL iniphysiq(klon_glo,llm,daysec,day_ini,dtphys/nsplit_phys, 
+     &                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp, 
+     &                iflag_phys) 
+
+#endif
+         call_iniphys=.false.
+!      ENDIF ! of IF (call_iniphys.and.(iflag_phys==1.or.iflag_phys>=100))
+
+
+c-----------------------------------------------------------------------
+c   Initialisation des dimensions d'INCA :
+c   --------------------------------------
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+!$OMP PARALLEL
+         CALL init_inca_dim(klon_omp,llm,iim,jjm,
+     $        rlonu,rlatu,rlonv,rlatv)
+!$OMP END PARALLEL
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des I/O :
+c   ------------------------
+
+
+      if (nday>=0) then ! standard case
+        day_end=day_ini+nday
+      else ! special case when nday <0, run -nday dynamical steps
+        day_end=day_ini-nday/day_step
+      endif
+      if (less1day) then
+        day_end=day_ini+floor(time_0+fractday)
+      endif
+      if (ndynstep.gt.0) then
+        day_end=day_ini+floor(time_0+float(ndynstep)/float(day_step))
+      endif
+      
+      WRITE(lunout,'(a,i7,a,i7)')
+     &             "run from day ",day_ini,"  to day",day_end
+
+#ifdef CPP_IOIPSL
+! Ce n'est defini pour l'instant que pour la Terre... 
+      if (planet_type.eq.'earth') then
+      call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
+      write (lunout,301)jour, mois, an
+      call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
+      write (lunout,302)jour, mois, an
+      else
+! A voir pour Titan et Venus
+      write(lunout,*)'A VOIR POUR VENUS/TITAN: separation en annees...'
+      endif ! planet_type
+
+ 301  FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
+ 302  FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
+#endif
+
+      if (planet_type=="mars") then
+         ! For Mars we transmit day_ini
+        CALL dynredem0_p("restart.nc", day_ini, phis)
+      else
+        CALL dynredem0_p("restart.nc", day_end, phis)
+      endif
+      ecripar = .TRUE.
+
+#ifdef CPP_IOIPSL
+      time_step = zdtvr
+      IF (mpi_rank==0) then
+        if (ok_dyn_ins) then
+        ! initialize output file for instantaneous outputs
+        ! t_ops = iecri * daysec ! do operations every t_ops
+        t_ops =((1.0*iecri)/day_step) * daysec  
+        t_wrt = daysec ! iecri * daysec ! write output every t_wrt
+        CALL inithist(day_ref,annee_ref,time_step,
+     &                  t_ops,t_wrt)
+        endif
+
+        IF (ok_dyn_ave) THEN 
+          ! initialize output file for averaged outputs
+          t_ops = iperiod * time_step ! do operations every t_ops
+          t_wrt = periodav * daysec   ! write output every t_wrt
+          CALL initdynav(day_ref,annee_ref,time_step,
+     &                   t_ops,t_wrt)
+!         CALL initdynav_p(dynhistave_file,day_ref,annee_ref,time_step,
+!     .        t_ops, t_wrt, histaveid)
+        END IF
+      ENDIF
+      dtav = iperiod*dtvr/daysec
+#endif
+! #endif of #ifdef CPP_IOIPSL
+
+c  Choix des frequences de stokage pour le offline
+c      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+c      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
+      istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
+      istphy=istdyn/iphysiq     
+
+
+c
+c-----------------------------------------------------------------------
+c   Integration temporelle du modele :
+c   ----------------------------------
+
+c       write(78,*) 'ucov',ucov
+c       write(78,*) 'vcov',vcov
+c       write(78,*) 'teta',teta
+c       write(78,*) 'ps',ps
+c       write(78,*) 'q',q
+
+!c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logici/,/logicl/)
+!      CALL leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,
+!     .              time_0)
+!c$OMP END PARALLEL
+
+
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/initdynav_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/initdynav_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/initdynav_p.F	(revision 222)
@@ -0,0 +1,204 @@
+!
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel_lmdz
+       use Write_field
+       use misc_mod
+       USE infotrac
+
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL. Initialisation du fichier histoire moyenne.
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep : frequence d'ecriture
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer thoriid, zvertiid
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer ii,jj
+      integer zan, dayref
+      integer :: jjb,jje,jjn
+
+! definition du domaine d'ecriture pour le rebuild
+
+      INTEGER,DIMENSION(2) :: ddid
+      INTEGER,DIMENSION(2) :: dsg
+      INTEGER,DIMENSION(2) :: dsl
+      INTEGER,DIMENSION(2) :: dpf
+      INTEGER,DIMENSION(2) :: dpl
+      INTEGER,DIMENSION(2) :: dhs
+      INTEGER,DIMENSION(2) :: dhe 
+      
+      INTEGER :: dynave_domain_id
+      
+      if (adjust) return
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = anne0
+      dayref = day0
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj)  = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+      ddid=(/ 1,2 /)
+      dsg=(/ iip1,jjp1 /)
+      dsl=(/ iip1,jjn /)
+      dpf=(/ 1,jjb /)
+      dpl=(/ iip1,jje /)
+      dhs=(/ 0,0 /)
+      dhe=(/ 0,0 /)
+
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
+     .                 'box',dynave_domain_id)
+             
+      call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,tau0, zjulian, tstep, thoriid,
+     .             fileid,dynave_domain_id)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sigss', 'Niveaux sigma','Pa',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      write(6,*)'inithistave',tstep
+      call histdef(fileid, 'u', 'vents u scalaires moyennes',
+     .             'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(fileid, 'v', 'vents v scalaires moyennes',
+     .             'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(fileid, 'temp', 'temperature moyennee', 'K',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel moyenne', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histdef(fileid, ttext(iq), ttext(iq), '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+#else
+      write(lunout,*)'initdynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/initfluxsto_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/initfluxsto_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/initfluxsto_p.F	(revision 222)
@@ -0,0 +1,297 @@
+!
+! $Id: initfluxsto_p.F 1438 2010-10-08 10:19:34Z jghattas $
+!
+      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
+       
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep: duree du pas de temps en seconde
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C      filevid:ID du fichier netcdf pour la grille v
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      real nivd(1)
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+      integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+      integer ii,jj
+      integer zan, idayref
+      logical ok_sync
+      integer :: jjb,jje,jjn
+
+! definition du domaine d'ecriture pour le rebuild
+
+      INTEGER,DIMENSION(2) :: ddid
+      INTEGER,DIMENSION(2) :: dsg
+      INTEGER,DIMENSION(2) :: dsl
+      INTEGER,DIMENSION(2) :: dpf
+      INTEGER,DIMENSION(2) :: dpl
+      INTEGER,DIMENSION(2) :: dhs
+      INTEGER,DIMENSION(2) :: dhe 
+      
+      INTEGER :: dynu_domain_id
+      INTEGER :: dynv_domain_id
+
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+      str='q  '
+      ctrac = 'traceur   '
+      ok_sync = .true.
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = annee_ref
+      idayref = day_ref
+      CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+      tau0 = itau_dyn
+	
+	do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+      ddid=(/ 1,2 /)
+      dsg=(/ iip1,jjp1 /)
+      dsl=(/ iip1,jjn /)
+      dpf=(/ 1,jjb /)
+      dpl=(/ iip1,jje /)
+      dhs=(/ 0,0 /)
+      dhe=(/ 0,0 /)
+
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
+     .                 'box',dynu_domain_id)
+       
+      call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid,
+     .             fileid,dynu_domain_id)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  un meme fichier)
+
+
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jje=jj_end-1
+      if (pole_sud) jjn=jj_nb-1
+
+      ddid=(/ 1,2 /)
+      dsg=(/ iip1,jjm /)
+      dsl=(/ iip1,jjn /)
+      dpf=(/ 1,jjb /)
+      dpl=(/ iip1,jje /)
+      dhs=(/ 0,0 /)
+      dhe=(/ 0,0 /)
+
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
+     .                 'box',dynv_domain_id)
+     
+      call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid,
+     .             filevid,dynv_domain_id)
+	
+      rl(1,1) = 1.	
+      
+      if (mpi_rank==0) then
+          
+        call histbeg('defstoke.nc', 1, rl, 1, rl,
+     .               1, 1, 1, 1,
+     .               tau0, zjulian, tstep, dhoriid, filedid)
+     
+      endif
+C
+C  Appel a histhori pour rajouter les autres grilles horizontales
+C
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+      call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje),
+     .             'scalar','Grille points scalaires', thoriid)
+	
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              llm, nivsigs, zvertiid)
+c pour le fichier def
+      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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/inithist_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/inithist_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/inithist_p.F	(revision 222)
@@ -0,0 +1,257 @@
+!
+! $Id: inithist_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt,
+     .                      fileid,filevid)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+       USE IOIPSL
+#endif
+       use parallel_lmdz
+       use Write_field
+       use misc_mod
+       USE infotrac
+
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep: duree du pas de temps en seconde
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C      filevid:ID du fichier netcdf pour la grille v
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, dayref
+      integer :: jjb,jje,jjn
+
+! definition du domaine d'ecriture pour le rebuild
+
+      INTEGER,DIMENSION(2) :: ddid
+      INTEGER,DIMENSION(2) :: dsg
+      INTEGER,DIMENSION(2) :: dsl
+      INTEGER,DIMENSION(2) :: dpf
+      INTEGER,DIMENSION(2) :: dpl
+      INTEGER,DIMENSION(2) :: dhs
+      INTEGER,DIMENSION(2) :: dhe 
+      
+      INTEGER :: dynu_domain_id
+      INTEGER :: dynv_domain_id
+
+C
+C  Initialisations
+C
+      if (adjust) return
+       
+      pi = 4. * atan (1.)
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = anne0
+      dayref = day0
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+      
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+
+      ddid=(/ 1,2 /)
+      dsg=(/ iip1,jjp1 /)
+      dsl=(/ iip1,jjn /)
+      dpf=(/ 1,jjb /)
+      dpl=(/ iip1,jje /)
+      dhs=(/ 0,0 /)
+      dhe=(/ 0,0 /)
+
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
+     .                 'box',dynu_domain_id)
+      
+       call histbeg(trim(infile),iip1, rlong(:,1), jjn, 
+     .              rlat(1,jjb:jje), 1, iip1, 1, jjn, tau0,
+     .              zjulian, tstep, uhoriid, fileid,dynu_domain_id)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  un meme fichier)
+
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jje=jj_end-1
+      if (pole_sud) jjn=jj_nb-1
+
+      ddid=(/ 1,2 /)
+      dsg=(/ iip1,jjm /)
+      dsl=(/ iip1,jjn /)
+      dpf=(/ 1,jjb /)
+      dpl=(/ iip1,jje /)
+      dhs=(/ 0,0 /)
+      dhe=(/ 0,0 /)
+
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, 
+     .                 'box',dynv_domain_id)
+      
+      call histbeg('dyn_histv', iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn, tau0, zjulian, tstep, vhoriid, 
+     .             filevid,dynv_domain_id)
+C
+C  Appel a histhori pour rajouter les autres grilles horizontales
+C
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+      call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje),
+     .              'scalar','Grille points scalaires', thoriid)
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      jjn=jj_nb
+
+      call histdef(fileid, 'ucov', 'vents u covariants', 'm/s',
+     .             iip1, jjn, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histdef(filevid, 'vcov', 'vents v covariants', 'm/s',
+     .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      jjn=jj_nb
+      
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histdef(fileid, ttext(iq),  ttext(iq), '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+#else
+      write(lunout,*)'inithist_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/integrd_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/integrd_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/integrd_p.F	(revision 222)
@@ -0,0 +1,394 @@
+!
+! $Id: integrd_p.F 1616 2012-02-17 11:59:00Z emillour $
+!
+      SUBROUTINE integrd_p
+     $  (  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, only : planet_type
+      IMPLICIT NONE
+
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Incrementation des tendances dynamiques
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "logic.h"
+#include "temps.h"
+#include "serre.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+
+      integer,intent(in) :: nq ! number of tracers to handle in this routine
+      real,intent(inout) :: vcov(ip1jm,llm) ! covariant meridional wind
+      real,intent(inout) :: ucov(ip1jmp1,llm) ! covariant zonal wind
+      real,intent(inout) :: teta(ip1jmp1,llm) ! potential temperature
+      real,intent(inout) :: q(ip1jmp1,llm,nq) ! advected tracers
+      real,intent(inout) :: ps0(ip1jmp1) ! surface pressure
+      real,intent(inout) :: masse(ip1jmp1,llm) ! atmospheric mass
+      real,intent(in) :: phis(ip1jmp1) ! ground geopotential !!! unused
+      ! values at previous time step
+      real,intent(inout) :: vcovm1(ip1jm,llm)
+      real,intent(inout) :: ucovm1(ip1jmp1,llm)
+      real,intent(inout) :: tetam1(ip1jmp1,llm)
+      real,intent(inout) :: psm1(ip1jmp1)
+      real,intent(inout) :: massem1(ip1jmp1,llm)
+      ! the tendencies to add
+      real,intent(in) :: dv(ip1jm,llm)
+      real,intent(in) :: du(ip1jmp1,llm)
+      real,intent(in) :: dteta(ip1jmp1,llm)
+      real,intent(in) :: dp(ip1jmp1)
+      real,intent(in) :: dq(ip1jmp1,llm,nq) !!! unused
+!      real,intent(out) :: finvmaold(ip1jmp1,llm) !!! unused
+
+c   Local:
+c   ------
+
+      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
+      REAL massescr( ip1jmp1,llm )
+!      REAL finvmasse(ip1jmp1,llm)
+      REAL,SAVE :: p(ip1jmp1,llmp1)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+      REAL,SAVE :: deltap( ip1jmp1,llm )
+
+      INTEGER  l,ij,iq,i,j
+
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ijb,ije,jjb,jje
+      REAL,SAVE :: ps(ip1jmp1)
+      LOGICAL :: checksum
+      INTEGER :: stop_it
+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 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 
+       
+        IF( .NOT. checksum ) THEN
+         write(lunout,*) "integrd: negative surface pressure ",
+     &                                                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"
+         write(lunout,*) " psm1(ij)=",psm1(stop_it)," dt=",dt,
+     &                   " dp(ij)=",dp(stop_it)
+        ENDIF
+
+c
+C$OMP MASTER
+      if (pole_nord) THEN
+      
+        DO  ij    = 1, iim
+         tppn(ij) = aire(   ij   ) * ps(  ij    )
+        ENDDO
+         tpn      = SSUM(iim,tppn,1)/apoln
+        DO ij   = 1, iip1
+         ps(   ij   )  = tpn
+        ENDDO
+      
+      ENDIF
+      
+      if (pole_sud) THEN
+      
+        DO  ij    = 1, iim
+         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+        ENDDO
+         tps      = SSUM(iim,tpps,1)/apols
+        DO ij   = 1, iip1
+         ps(ij+ip1jm)  = tps
+        ENDDO
+      
+      ENDIF
+c$OMP END MASTER
+c$OMP BARRIER
+c
+c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+c
+
+      CALL pression_p ( ip1jmp1, ap, bp, ps, p )
+c$OMP BARRIER
+      CALL massdair_p (     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,jje, jjp1, llm, -2, 2, .TRUE., 1  )
+c
+
+c    ............   integration  de  ucov, vcov,  h     ..............
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO 10 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4 ij = ijb,ije
+      uscr( ij )   =  ucov( ij,l )
+      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+   4  CONTINUE
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 5 ij = ijb,ije
+      vscr( ij )   =  vcov( ij,l )
+      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+   5  CONTINUE
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO 6 ij = ijb,ije
+      hscr( ij )    =  teta(ij,l)
+      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) 
+     $                + dt * dteta(ij,l) / masse(ij,l)
+   6  CONTINUE
+
+c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
+      IF (pole_nord) THEN
+       
+        DO  ij   = 1, iim
+          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+        ENDDO
+          tpn      = SSUM(iim,tppn,1)/apoln
+
+        DO ij   = 1, iip1
+          teta(   ij   ,l)  = tpn
+        ENDDO
+      
+      ENDIF
+      
+      IF (pole_sud) THEN
+       
+        DO  ij   = 1, iim
+          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+        ENDDO
+          tps      = SSUM(iim,tpps,1)/apols
+
+        DO ij   = 1, iip1
+          teta(ij+ip1jm,l)  = tps
+        ENDDO
+      
+      ENDIF
+c
+
+      IF(leapf)  THEN
+c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+        ijb=ij_begin
+        ije=ij_end
+        ucovm1(ijb:ije,l)=uscr(ijb:ije)
+        tetam1(ijb:ije,l)=hscr(ijb:ije)
+        if (pole_sud) ije=ij_end-iip1
+        vcovm1(ijb:ije,l)=vscr(ijb:ije)
+      
+      END IF
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+
+c
+c   .......  integration de   q   ......
+c
+      ijb=ij_begin
+      ije=ij_end
+
+	 if (planet_type.eq."earth") then
+! Earth-specific treatment of first 2 tracers (water)
+c$OMP BARRIER
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+          DO l = 1, llm
+           DO ij = ijb, ije
+            deltap(ij,l) =  p(ij,l) - p(ij,l+1) 
+           ENDDO
+          ENDDO
+c$OMP END DO NOWAIT
+c$OMP BARRIER
+
+          CALL qminimum_p( q, nq, deltap )
+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
+      
+! 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
+
+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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_gam_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_gam_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_gam_p.F	(revision 222)
@@ -0,0 +1,65 @@
+      SUBROUTINE laplacien_gam_p ( klevel, cuvsga, cvusga, unsaigam ,
+     *                        unsapolnga, unsapolsga, teta, divgra )
+
+c  P. Le Van
+c
+c   ************************************************************
+c
+c      ....   calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c    klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    ............     variables  en arguments    ..........
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
+     *     unsapolnga, unsapolsga
+c
+c    ...........    variables  locales    .................
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    ......................................................
+
+      INTEGER :: ijb,ije
+      INTEGER :: l      
+c
+c
+c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+
+c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+      
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud ) ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,klevel      
+        divgra(ijb:ije,l)=teta(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+      CALL   grad_p ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam_p ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_p.F	(revision 222)
@@ -0,0 +1,56 @@
+      SUBROUTINE laplacien_p ( klevel, teta, divgra )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c    ....     calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .........      variables  en arguments   ..............
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      INTEGER :: l
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    .......................................................
+
+      
+      INTEGER :: ijb,ije,jjb,jje
+c
+c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud ) ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,klevel      
+        divgra(ijb:ije,l)=teta(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      jjb=jj_begin-1
+      jje=jj_end+1
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud ) jje=jj_end
+      
+      CALL filtreg_p( divgra,jjb,jje,jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad_p ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf_p ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_rot_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_rot_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_rot_p.F	(revision 222)
@@ -0,0 +1,45 @@
+      SUBROUTINE laplacien_rot_p ( klevel, rotin, rotout,ghx,ghy )
+c
+c    P. Le Van
+c
+c   ************************************************************
+c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+c   ************************************************************
+c
+c     klevel et rotin  sont des arguments  d'entree pour le s-prog
+c      rotout           est  un argument  de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c 
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+c   ........................................................
+c
+c
+      INTEGER :: ijb,ije,jjb,jje
+      
+      jjb=jj_begin-1
+      jje=jj_end+1
+      
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud) jje=jj_end-1
+      
+      CALL  filtreg_p ( rotin ,jjb,jje,jjm, klevel,2, 1, .FALSE., 1)
+
+      CALL   nxgrad_p ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf_p  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_rotgam_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_rotgam_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/laplacien_rotgam_p.F	(revision 222)
@@ -0,0 +1,48 @@
+      SUBROUTINE laplacien_rotgam_p ( klevel, rotin, rotout )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c   ........................................................
+c
+      INTEGER :: ijb,ije
+      
+c
+
+      CALL   nxgrad_gam_p ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil_p ( klevel, ghx  ,   ghy , rotout )
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, klevel
+        DO ij = ijb, ije
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/leapfrog_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/leapfrog_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/leapfrog_p.F	(revision 222)
@@ -0,0 +1,1962 @@
+! 
+! $Id: leapfrog_p.F 1446 2010-10-22 09:27:25Z emillour $
+!
+c
+c
+
+      SUBROUTINE leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,
+     &                    time_0)
+
+      use exner_hyb_m, only: exner_hyb
+      use exner_milieu_m, only: exner_milieu
+      use exner_hyb_p_m, only: exner_hyb_p
+      use exner_milieu_p_m, only: exner_milieu_p
+       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, ONLY: nqtot
+       USE guide_p_mod, ONLY : guide_main
+       USE getparam
+       USE control_mod, only: planet_type,nday,day_step,iperiod,iphysiq,
+     &                       less1day,fractday,ndynstep,iconser,
+     &                       dissip_period,offline,ip_ebil_dyn,
+     &                       ok_dynzon,periodav,ok_dyn_ave,iecri,
+     &                       ok_dyn_ins,output_grads_dyn,
+     &                       iapp_tracvl
+       use cpdet_mod, only: cpdet,tpot2t_glo_p,t2tpot_glo_p
+       use sponge_mod_p, only: callsponge,mode_sponge,sponge_p
+       use comuforc_h
+
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+c  ... Possibilite de choisir le shema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (10/02) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10 
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+!#include "com_io_dyn.h"
+#include "iniprint.h"
+#include "academic.h"
+      
+      REAL,INTENT(IN) :: time_0 ! not used
+
+c   dynamical variables:
+      REAL,INTENT(INOUT) :: ucov(ip1jmp1,llm)    ! zonal covariant wind
+      REAL,INTENT(INOUT) :: vcov(ip1jm,llm)      ! meridional covariant wind
+      REAL,INTENT(INOUT) :: teta(ip1jmp1,llm)    ! potential temperature
+      REAL,INTENT(INOUT) :: ps(ip1jmp1)          ! surface pressure (Pa)
+      REAL,INTENT(INOUT) :: masse(ip1jmp1,llm)   ! air mass
+      REAL,INTENT(INOUT) :: phis(ip1jmp1)        ! geopotentiat at the surface
+      REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers
+      
+      REAL,SAVE :: p (ip1jmp1,llmp1  )       ! interlayer pressure
+      REAL,SAVE :: pks(ip1jmp1)              ! exner at the surface
+      REAL,SAVE :: pk(ip1jmp1,llm)           ! exner at mid-layer
+      REAL,SAVE :: pkf(ip1jmp1,llm)          ! filtered exner at mid-layer
+      REAL,SAVE :: phi(ip1jmp1,llm)          ! geopotential
+      REAL,SAVE :: w(ip1jmp1,llm)            ! vertical velocity
+! ADAPTATION GCM POUR CP(T)
+      REAL,SAVE :: temp(ip1jmp1,llm)                 ! temperature  
+      REAL,SAVE :: tsurpk(ip1jmp1,llm)               ! cpp*T/pk  
+
+      real zqmin,zqmax
+
+c variables dynamiques intermediaire pour le transport
+      REAL,SAVE :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
+
+c   variables dynamiques au pas -1
+      REAL,SAVE :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL,SAVE :: tetam1(ip1jmp1,llm),psm1(ip1jmp1)
+      REAL,SAVE :: massem1(ip1jmp1,llm)
+
+c   tendances dynamiques
+      REAL,SAVE :: dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL,SAVE :: dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
+
+c   tendances de la dissipation
+      REAL,SAVE :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
+      REAL,SAVE :: dtetadis(ip1jmp1,llm)
+
+c   tendances physiques
+      REAL,SAVE :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
+      REAL,SAVE :: dtetafi(ip1jmp1,llm)
+      REAL,SAVE :: dpfi(ip1jmp1)
+      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
+
+c   tendances top_bound (sponge layer)
+c      REAL,SAVE :: dvtop(ip1jm,llm)
+      REAL,SAVE :: dutop(ip1jmp1,llm)
+c      REAL,SAVE :: dtetatop(ip1jmp1,llm)
+c      REAL,SAVE :: dptop(ip1jmp1)
+c      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqtop
+
+c   TITAN : tendances due au forces de marees */s
+      REAL,SAVE :: dvtidal(ip1jm,llm),dutidal(ip1jmp1,llm)
+
+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 :: finvmaold(ip1jmp1,llm)
+
+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
+      real :: rdaym_ini
+      logical :: physic
+      LOGICAL first,callinigrads
+
+      data callinigrads/.true./
+      character*10 string10
+
+      REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale
+
+c+jld variables test conservation energie
+      REAL,SAVE :: ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+      REAL,SAVE :: dtetaecdt(ip1jmp1,llm)
+      REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL,SAVE :: vnat(ip1jm,llm),unat(ip1jmp1,llm)
+      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"
+      character*80 abort_message
+
+
+      logical,PARAMETER :: dissip_conservative=.TRUE.
+ 
+      INTEGER testita
+      PARAMETER (testita = 9)
+
+      logical , parameter :: flag_verif = .false.
+
+      ! for CP(T)  -- Aymeric
+      real :: dtec
+      real,save :: ztetaec(ip1jmp1,llm)  !!SAVE ???
+
+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
+      REAL,SAVE :: dvfi_tmp(iip1,llm),dufi_tmp(iip1,llm)
+      REAL,SAVE :: dtetafi_tmp(iip1,llm)
+      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi_tmp
+      REAL,SAVE :: dpfi_tmp(iip1)
+
+      INTEGER :: true_itau
+      INTEGER :: iapptrac
+      INTEGER :: AdjustCount
+!      INTEGER :: var_time
+      LOGICAL :: ok_start_timer=.FALSE.
+      LOGICAL, SAVE :: firstcall=.TRUE.
+
+c dummy: sinon cette routine n'est jamais compilee...
+      if(1.eq.0) then
+#ifdef CPP_PHYS
+        CALL init_phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+#endif
+      endif
+
+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
+         ! to run a given (-nday) number of dynamical steps
+         itaufin   = -nday
+      endif
+      if (less1day) then
+c MODIF VENUS: to run less than one day:
+        itaufin   = int(fractday*day_step)
+      endif
+      if (ndynstep.gt.0) then
+        ! running a given number of dynamical steps
+        itaufin=ndynstep
+      endif
+      itaufinp1 = itaufin +1
+
+      itau = 0
+      physic=.true.
+      if (iflag_phys==0.or.iflag_phys==2) physic=.false.
+!      iday = day_ini+itau/day_step
+!      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+!         IF(time.GT.1.) THEN
+!          time = time-1.
+!          iday = iday+1
+!         ENDIF
+
+c Allocate variables depending on dynamic variable nqtot
+c$OMP MASTER
+         IF (firstcall) THEN
+            firstcall=.FALSE.
+            ALLOCATE(dq(ip1jmp1,llm,nqtot))
+            ALLOCATE(dqfi(ip1jmp1,llm,nqtot))
+            ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
+c            ALLOCATE(dqtop(ip1jmp1,llm,nqtot))
+         END IF
+c$OMP END MASTER      
+c$OMP BARRIER
+
+c-----------------------------------------------------------------------
+c   On initialise la pression et la fonction d'Exner :
+c   --------------------------------------------------
+
+c$OMP MASTER
+c INITIALISATIONS
+        dudis(:,:)   =0.
+        dvdis(:,:)   =0.
+        dtetadis(:,:)=0.
+        dutop(:,:)   =0.
+c        dvtop(:,:)   =0.
+c        dtetatop(:,:)=0.
+c        dqtop(:,:,:) =0.
+c        dptop(:)     =0.
+        dufi(:,:)   =0.
+        dvfi(:,:)   =0.
+        dtetafi(:,:)=0.
+        dqfi(:,:,:) =0.
+        dpfi(:)     =0.
+        dq(:,:,:)   =0.
+
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      if (pressure_exner) then
+        CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
+      else
+        CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
+      endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+c et du parallelisme !!
+
+   1  CONTINUE ! Matsuno Forward step begins here
+
+      jD_cur = jD_ref + day_ini - day_ref +                             &
+     &          itau/day_step
+      jH_cur = jH_ref + start_time +                                    &
+     &         mod(itau,day_step)/float(day_step) 
+      if (jH_cur > 1.0 ) then
+        jD_cur = jD_cur +1.
+        jH_cur = jH_cur -1.
+      endif
+
+
+#ifdef CPP_IOIPSL
+      IF (planet_type.eq."earth") THEN
+      if (ok_guide) then
+!$OMP MASTER
+        call guide_main(itau,ucov,vcov,teta,q,masse,ps)
+!$OMP END MASTER
+!$OMP BARRIER
+      endif
+      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
+!         CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+c$OMP END MASTER
+c$OMP BARRIER
+       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 ,jj_begin,jj_end,jjp1, 
+!     .                    llm, -2,2, .TRUE., 1 )
+
+       endif ! of if (FirstCaldyn)
+       
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+
+c   ...    P.Le Van .26/04/94  ....
+
+cym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+cym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+cym  ne sert a rien
+cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+
+   2  CONTINUE ! Matsuno backward or leapfrog step begins here
+
+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:
+c   -----
+
+
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+c      idissip=1
+      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
+
+#ifdef NODYN
+      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 SetDistrib(jj_Nb_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      
+     
+      if (Adjust) then
+c$OMP MASTER 
+        AdjustCount=AdjustCount+1
+        if (iapptrac==iapp_tracvl .and. (forward. OR . leapf)
+     &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
+           AdjustCount=0
+           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
+         if (mpi_rank==0) call WriteBands
+         
+         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(1,1,j),q(1,1,j),ip1jmp1,llm,
+     &                                jj_nb_caldyn,0,0,TestRequest)
+        enddo
+! ADAPTATION GCM POUR CP(T)
+         call Register_SwapFieldHallo(temp,temp,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(tsurpk,tsurpk,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+
+         call SetDistrib(jj_nb_caldyn)
+         call SendRequest(TestRequest)
+         call WaitRequest(TestRequest)
+         
+        call AdjustBands_dissip
+        call AdjustBands_physic
+
+      endif
+c$OMP END MASTER  
+      endif ! of if (Adjust)
+     
+      
+      
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+! ADAPTATION GCM POUR CP(T)
+      call tpot2t_glo_p(teta,temp,pk)
+      ijb=ij_begin
+      ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+        tsurpk(ijb:ije,l)=cpp*temp(ijb:ije,l)/pk(ijb:ije,l)
+      enddo
+!$OMP END DO
+
+      if (debug) then
+!$OMP BARRIER
+!$OMP MASTER
+        call WriteField_p('temp',reshape(temp,(/iip1,jmp1,llm/)))
+        call WriteField_p('tsurpk',reshape(tsurpk,(/iip1,jmp1,llm/)))
+!$OMP END MASTER        
+!$OMP BARRIER     
+      endif ! of if (debug)
+      
+c$OMP BARRIER
+c$OMP MASTER
+       call VTb(VThallo)
+c$OMP END MASTER
+
+       call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(teta,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(ps,ip1jmp1,1,1,2,2,1,TestRequest)
+       call Register_Hallo(pkf,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(pk,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(pks,ip1jmp1,1,1,1,1,1,TestRequest)
+       call Register_Hallo(p,ip1jmp1,llmp1,1,1,1,1,TestRequest)
+! ADAPTATION GCM POUR CP(T)
+       call Register_Hallo(temp,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(tsurpk,ip1jmp1,llm,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        
+!$OMP BARRIER
+!$OMP MASTER
+        call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+        call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+        call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+        call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+        call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
+        call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/)))
+        call WriteField_p('pks',reshape(pks,(/iip1,jmp1/)))
+        call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
+        call WriteField_p('phis',reshape(phis,(/iip1,jmp1/)))
+        if (nqtot > 0) then
+        do j=1,nqtot
+          call WriteField_p('q'//trim(int2str(j)),
+     .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+        enddo
+        endif
+!$OMP END MASTER        
+c$OMP BARRIER
+      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()
+! ADAPTATION GCM POUR CP(T)
+!      CALL geopot_p  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+      CALL geopot_p  ( ip1jmp1, tsurpk  , pk , pks,  phis  , phi   )
+      
+      call VTb(VTcaldyn)
+c$OMP END MASTER
+!      var_time=time+iday-day_ini
+
+c$OMP BARRIER
+!      CALL FTRACE_REGION_BEGIN("caldyn")
+      time = jD_cur + jH_cur 
+           rdaym_ini  = itau * dtvr / daysec
+
+#ifdef NODYN
+      WRITE(lunout,*)"NO DYN !!!!!"
+      dv(:,:) = 0.D+0
+      du(:,:) = 0.D+0
+      dteta(:,:) = 0.D+0
+      dq(:,:,:) = 0.D+0
+      dp(:) = 0.D+0
+#else
+! ADAPTATION GCM POUR CP(T)
+!      CALL caldyn_p 
+!     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+!     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+      CALL caldyn_p 
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,tsurpk,phis,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+
+!      CALL FTRACE_REGION_END("caldyn")
+
+c$OMP MASTER
+      call VTe(VTcaldyn)
+c$OMP END MASTER      
+
+cc$OMP BARRIER
+cc$OMP MASTER
+!      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
+!      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
+!      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
+!      call WriteField_p('dp',reshape(dp,(/iip1,jmp1/)))
+!      call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/)))
+!      call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
+!      call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
+!      call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/)))
+!      call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
+!      call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/)))
+cc$OMP END MASTER
+
+
+      ! Simple zonal wind nudging for generic planetary model
+      ! AS 09/2013
+      ! ---------------------------------------------------
+      if (planet_type.eq."generic") then
+       if (ok_guide) then
+         du(:,:) = du(:,:) + ((uforc(:,:)-ucov(:,:)) / facwind)
+       endif
+      endif
+
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+
+      IF( forward. OR . leapf )  THEN
+! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
+         CALL advtrac_p( pbaru,pbarv, 
+     *             p,  masse,q,iapptrac, teta,
+     .             flxw, pk)
+
+C        Stokage du flux de masse pour traceurs OFF-LINE
+         IF (offline .AND. .NOT. adjust) THEN
+            CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
+     .           dtvr, itau)
+         ENDIF
+
+      ENDIF ! of IF( forward. OR . leapf )
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+c$OMP MASTER 
+       call VTb(VTintegre)
+c$OMP END MASTER
+c      call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/)))
+c      call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/)))
+c      call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c      call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+cc$OMP PARALLEL DEFAULT(SHARED)
+c$OMP BARRIER
+!       CALL FTRACE_REGION_BEGIN("integrd")
+
+       CALL integrd_p ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
+!     $              finvmaold                                    )
+
+       IF ((planet_type.eq."titan").and.(tidal)) then
+c-----------------------------------------------------------------------
+c   MarÃ©es gravitationnelles causÃ©es par Saturne
+c   B. Charnay (28/10/2010)
+c   ----------------------------------------------------------
+            CALL tidal_forces(rdaym_ini, dutidal, dvtidal)
+            ucov=ucov+dutidal*dt
+            vcov=vcov+dvtidal*dt
+       ENDIF
+
+!       CALL FTRACE_REGION_END("integrd")
+c$OMP BARRIER
+cc$OMP MASTER
+c      call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/)))
+c      call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/)))
+c      call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c      call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
+c
+c      call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+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
+cc$OMP END MASTER
+
+! NODYN precompiling flag
+#endif
+
+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
+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)
+
+        if (prt_level >= 10) then
+         write(lunout,*)
+     &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
+        endif
+c$OMP END MASTER
+
+         CALL pression_p (  ip1jmp1, ap, bp, ps,  p      )
+
+c$OMP BARRIER
+         if (pressure_exner) then
+           CALL exner_hyb_p(  ip1jmp1, ps, p,pks, pk, pkf )
+         else
+           CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf )
+         endif
+! Compute geopotential (physics might need it)
+         CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+c$OMP BARRIER
+           jD_cur = jD_ref + day_ini - day_ref
+     $        + itau/day_step
+
+           IF ((planet_type .eq."generic").or.
+     &         (planet_type.eq."mars")) THEN
+              ! AS: we make jD_cur to be pday
+              jD_cur = int(day_ini + itau/day_step)
+           ENDIF
+
+           jH_cur = jH_ref + start_time +                                &
+     &              mod(itau,day_step)/float(day_step) 
+!         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
+           if (jH_cur > 1.0 ) then
+             jD_cur = jD_cur +1.
+             jH_cur = jH_cur -1.
+           endif
+
+c rajout debug
+c       lafin = .true.
+
+
+c   Interface avec les routines de phylmd (phymars ... )
+c   -----------------------------------------------------
+
+c+jld
+
+c  Diagnostique de conservation de l'energie : initialisation
+      IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil dyn'
+! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)!
+           IF (planet_type.eq."earth") THEN
+#ifdef CPP_EARTH
+            CALL diagedyn(ztit,2,1,1,dtphys
+     &    , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+#endif
+           ENDIF
+      ENDIF 
+c-jld
+c$OMP BARRIER
+c$OMP MASTER
+        call VTb(VThallo)
+c$OMP END MASTER
+
+        call SetTag(Request_physic,800)
+        
+        call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
+     *                               jj_Nb_physic,1,2,Request_physic)
+
+        call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
+     *                               jj_Nb_physic,2,2,Request_physic)
+
+        call Register_SwapFieldHallo(p,p,ip1jmp1,llmp1,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(w,w,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+c        call SetDistrib(jj_nb_vanleer)
+        do j=1,nqtot
+ 
+          call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        enddo
+
+        call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call SendRequest(Request_Physic)
+c$OMP BARRIER
+        call WaitRequest(Request_Physic)       
+
+c$OMP BARRIER
+c$OMP MASTER
+        call SetDistrib(jj_nb_Physic)
+        call VTe(VThallo)
+        
+        call VTb(VTphysiq)
+c$OMP END MASTER
+c$OMP BARRIER
+
+cc$OMP MASTER        
+c      call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/)))
+c      call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('pfi',reshape(p,(/iip1,jmp1,llmp1/)))
+c      call WriteField_p('pkfi',reshape(pk,(/iip1,jmp1,llm/)))
+cc$OMP END MASTER
+cc$OMP BARRIER
+!        CALL FTRACE_REGION_BEGIN("calfis")
+        CALL calfis_p(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 SetDistrib(jj_nb_Physic_bis)
+
+        call VTb(VThallo)
+c$OMP END MASTER
+c$OMP BARRIER
+ 
+        call Register_Hallo(dufi,ip1jmp1,llm,
+     *                      1,0,0,1,Request_physic)
+        
+        call Register_Hallo(dvfi,ip1jm,llm,
+     *                      1,0,0,1,Request_physic)
+        
+        call Register_Hallo(dtetafi,ip1jmp1,llm,
+     *                      1,0,0,1,Request_physic)
+
+        call Register_Hallo(dpfi,ip1jmp1,1,
+     *                      1,0,0,1,Request_physic)
+
+        if (nqtot > 0) then
+        do j=1,nqtot
+          call Register_Hallo(dqfi(1,1,j),ip1jmp1,llm,
+     *                        1,0,0,1,Request_physic)
+        enddo
+        endif
+        
+        call SendRequest(Request_Physic)
+c$OMP BARRIER
+        call WaitRequest(Request_Physic)
+             
+c$OMP BARRIER
+c$OMP MASTER
+        call VTe(VThallo)
+ 
+        call SetDistrib(jj_nb_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)
+c$OMP BARRIER
+cc$OMP MASTER        
+c      call WriteField_p('dufi',reshape(dufi,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dvfi',reshape(dvfi,(/iip1,jjm,llm/)))
+c      call WriteField_p('dtetafi',reshape(dtetafi,(/iip1,jmp1,llm/)))
+cc$OMP END MASTER
+
+c      ajout des tendances physiques:
+c      ------------------------------
+          CALL addfi_p( dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps ,
+     $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+          ! since addfi updates ps(), also update p(), masse() and pk()
+          CALL pression_p(ip1jmp1,ap,bp,ps,p)
+c$OMP BARRIER
+          CALL massdair_p(p,masse)
+c$OMP BARRIER
+          if (pressure_exner) then
+            CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk,pkf)
+          else
+            CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk,pkf)
+          endif
+c$OMP BARRIER
+
+c      Couche superieure :
+c      -------------------
+         IF (iflag_top_bound > 0) THEN
+           CALL top_bound_p(vcov,ucov,teta,masse,dtphys,
+     $                       dutop)
+        ijb=ij_begin
+        ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+        DO l=1,llm
+          dutop(ijb:ije,l)=dutop(ijb:ije,l)/dtphys ! convert to a tendency in (m/s)/s
+        ENDDO
+c$OMP END DO NOWAIT        
+         ENDIF ! of IF (ok_strato)
+       
+c$OMP BARRIER
+c$OMP MASTER
+        call VTe(VTphysiq)
+
+        call VTb(VThallo)
+c$OMP END MASTER
+
+        call SetTag(Request_physic,800)
+        call Register_SwapField(ucov,ucov,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(vcov,vcov,ip1jm,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(teta,teta,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(masse,masse,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+
+        call Register_SwapField(ps,ps,ip1jmp1,1,
+     *                               jj_Nb_caldyn,Request_physic)
+
+        call Register_SwapField(p,p,ip1jmp1,llmp1,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(pk,pk,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(phis,phis,ip1jmp1,1,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(phi,phi,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(w,w,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+
+        do j=1,nqtot
+        
+          call Register_SwapField(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        enddo
+
+        call SendRequest(Request_Physic)
+c$OMP BARRIER
+        call WaitRequest(Request_Physic)     
+
+c$OMP BARRIER
+c$OMP MASTER
+       call VTe(VThallo)
+       call SetDistrib(jj_Nb_caldyn)
+c$OMP END MASTER
+c$OMP BARRIER
+c
+c  Diagnostique de conservation de l'energie : difference
+      IF ((ip_ebil_dyn.ge.1 ) .and. (nqtot > 1)) THEN 
+          ztit='bil phys'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+      ENDIF 
+
+cc$OMP MASTER      
+c      if (debug) then
+c       call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/)))
+c       call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/)))
+c       call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/)))
+c      endif
+cc$OMP END MASTER
+
+
+c-jld
+c$OMP MASTER
+         call resume_timer(timer_caldyn)
+         if (FirstPhysic) then
+           ok_start_timer=.TRUE.
+           FirstPhysic=.false.
+         endif
+c$OMP END MASTER
+       ENDIF ! of IF( apphys )
+
+      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+!   Academic case : Simple friction and Newtonan relaxation 
+!   -------------------------------------------------------
+c$OMP MASTER
+         if (FirstPhysic) then
+           ok_start_timer=.TRUE.
+           FirstPhysic=.false.
+         endif
+c$OMP END MASTER
+
+       ijb=ij_begin
+       ije=ij_end
+!$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 ! of do l=1,llm
+!$OMP END DO
+
+       if (planet_type.eq."giant") then
+          ! Intrinsic heat flux
+          ! Aymeric -- for giant planets
+          if (ihf .gt. 1.e-6) then
+          !print *, '**** INTRINSIC HEAT FLUX ****', ihf 
+          teta(ijb:ije,1) = teta(ijb:ije,1)
+     &        + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
+          !print *, '**** d teta ' 
+          !print *, dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
+          endif
+       endif
+
+       call Register_Hallo(ucov,ip1jmp1,llm,0,1,1,0,Request_Physic)
+       call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Physic)
+       call SendRequest(Request_Physic)
+c$OMP BARRIER
+       call WaitRequest(Request_Physic)     
+c$OMP BARRIER
+       call friction_p(ucov,vcov,dtvr)
+!$OMP BARRIER
+
+        ! Sponge layer (if any)
+        IF (ok_strato) THEN
+          CALL top_bound_p(vcov,ucov,teta,masse,dtvr,
+     $                     dutop)
+          ijb=ij_begin
+          ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+          DO l=1,llm
+            dutop(ijb:ije,l)=dutop(ijb:ije,l)/dtvr ! convert to a tendency in (m/s)/s
+          ENDDO
+c$OMP END DO NOWAIT        
+!$OMP BARRIER
+        ENDIF ! of IF (ok_strato) 
+      ENDIF ! of IF(iflag_phys.EQ.2)
+
+
+        CALL pression_p ( ip1jmp1, ap, bp, ps, p                  )
+c$OMP BARRIER
+        if (pressure_exner) then
+          CALL exner_hyb_p( ip1jmp1, ps, p, pks, pk, pkf )
+        else
+          CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf )
+        endif
+c$OMP BARRIER
+        CALL massdair_p(p,masse)
+c$OMP BARRIER
+
+cc$OMP END PARALLEL
+
+c-----------------------------------------------------------------------
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+      IF(apdiss) THEN
+
+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
+
+        ! sponge layer
+        if (callsponge) then
+          call Register_Hallo(ps,ip1jm,1,1,1,1,1,Request_Dissip)
+          call SendRequest(Request_Dissip)
+c$OMP BARRIER
+          call WaitRequest(Request_Dissip)
+c$OMP BARRIER
+c$OMP MASTER
+          call VTe(VThallo)
+          call VTb(VThallo)
+c$OMP END MASTER
+c$OMP BARRIER
+          CALL sponge_p(ucov,vcov,teta,ps,dtdiss,mode_sponge)
+        endif
+
+
+c$OMP BARRIER
+
+        call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+     *                          jj_Nb_dissip,1,1,Request_dissip)
+
+        call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+     *                          jj_Nb_dissip,1,1,Request_dissip)
+
+        call Register_SwapField(teta,teta,ip1jmp1,llm,
+     *                          jj_Nb_dissip,Request_dissip)
+
+        call Register_SwapField(p,p,ip1jmp1,llmp1,
+     *                          jj_Nb_dissip,Request_dissip)
+
+        call Register_SwapField(pk,pk,ip1jmp1,llm,
+     *                          jj_Nb_dissip,Request_dissip)
+
+        call SendRequest(Request_dissip)       
+c$OMP BARRIER
+        call WaitRequest(Request_dissip)       
+
+c$OMP BARRIER
+c$OMP MASTER
+        call SetDistrib(jj_Nb_dissip)
+        call VTe(VThallo)
+        call VTb(VTdissipation)
+        call start_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+        call covcont_p(llm,ucov,vcov,ucont,vcont)
+        call enercin_p(vcov,ucov,vcont,ucont,ecin0)
+
+c   dissipation
+! ADAPTATION GCM POUR CP(T)
+        call tpot2t_glo_p(teta,temp,pk)
+
+!        CALL FTRACE_REGION_BEGIN("dissip")
+        CALL dissip_p(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+!        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)
+          dudis(ijb:ije,l)=dudis(ijb:ije,l)/dtdiss   ! passage en (m/s)/s
+        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)
+          dvdis(ijb:ije,l)=dvdis(ijb:ije,l)/dtdiss   ! passage en (m/s)/s
+        ENDDO
+c$OMP END DO NOWAIT        
+
+
+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(ucov,ip1jmp1,llm,1,1,1,1,Request_Dissip)
+            call Register_Hallo(vcov,ip1jm,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_p(llm,ucov,vcov,ucont,vcont)
+            call enercin_p(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
+! ADAPTATION GCM POUR CP(T)
+!                dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+!                dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+                temp(ij,l)=temp(ij,l) +
+     &                      (ecin0(ij,l)-ecin(ij,l))/cpdet(temp(ij,l))
+              enddo
+            enddo
+c$OMP END DO 
+!        call t2tpot_p(ije-ijb+1,llm,temp(ijb:ije,:),ztetaec(ijb:ije,:),
+!     &                            pk(ijb:ije,:))
+         call t2tpot_glo_p(temp,ztetaec,pk)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+            do l=1,llm
+              do ij=ijb,ije
+                dtetaecdt(ij,l)=ztetaec(ij,l)-teta(ij,l)
+                dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+              enddo
+            enddo
+c$OMP END DO NOWAIT
+       endif ! of if (dissip_conservative)
+
+       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)
+              dtetadis(ij,l)=dtetadis(ij,l)/dtdiss   ! passage en K/s
+           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
+
+         if (1 == 0) then
+!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
+!!!                     2) should probably not be here anyway
+!!! but are kept for those who would want to revert to previous behaviour
+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 ! of if (1 == 0)
+        endif ! of of (pole_nord)
+        
+        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
+
+         if (1 == 0) then
+!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
+!!!                     2) should probably not be here anyway
+!!! but are kept for those who would want to revert to previous behaviour
+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 ! of if (1 == 0)
+        endif ! of if (pole_sud)
+
+
+c$OMP BARRIER
+c$OMP MASTER
+        call VTe(VTdissipation)
+
+        call stop_timer(timer_dissip)
+        
+        call VTb(VThallo)
+c$OMP END MASTER
+        call Register_SwapField(ucov,ucov,ip1jmp1,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(vcov,vcov,ip1jm,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(teta,teta,ip1jmp1,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(p,p,ip1jmp1,llmp1,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(pk,pk,ip1jmp1,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call SendRequest(Request_dissip)       
+c$OMP BARRIER
+        call WaitRequest(Request_dissip)       
+
+c$OMP BARRIER
+c$OMP MASTER
+        call SetDistrib(jj_Nb_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
+        
+c   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+
+c   preparation du pas d'integration suivant  ......
+cym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+cym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c$OMP MASTER      
+      call stop_timer(timer_caldyn)
+c$OMP END MASTER
+      IF (itau==itaumax) then
+c$OMP MASTER
+            call allgather_timer_average
+
+      if (mpi_rank==0) then
+        
+        print *,'*********************************'
+        print *,'******    TIMER CALDYN     ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER VANLEER    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER DISSIP    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_dissip(i),timer_dissip,i)
+        enddo
+        
+        print *,'*********************************'
+        print *,'******    TIMER PHYSIC    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_physic(i),timer_physic,i)
+        enddo
+        
+      endif  
+      
+      print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
+      print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
+      print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
+      print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
+      CALL print_filtre_timer
+      call fin_getparam
+        call finalize_parallel
+c$OMP END MASTER
+c$OMP BARRIER
+        RETURN
+      ENDIF ! of IF (itau==itaumax)
+      
+      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
+                if (nqtot > 2) then
+                 WRITE(85,*) 'q1 = ',q(:,:,1)
+                 WRITE(86,*) 'q3 = ',q(:,:,3)
+                endif
+              endif
+  
+
+c$OMP MASTER
+              call fin_getparam
+              call finalize_parallel
+c$OMP END MASTER
+              abort_message = 'Simulation finished'
+              call abort_gcm(modname,abort_message,0)
+              RETURN
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+c$OMP BARRIER
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+#ifdef CPP_IOIPSL
+             IF (ok_dynzon) THEN 
+              CALL bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav, 
+     ,             ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) 
+c les traceurs ne sont pas sortis, trop lourd. 
+c Peut changer eventuellement si besoin.
+!                 CALL bilan_dyn_p(dtvr*iperiod,dtvr*day_step*periodav,
+!     &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,
+!     &                 du,dudis,dutop,dufi)
+              ENDIF !ok_dynzon
+#endif
+               IF (ok_dyn_ave) THEN
+!$OMP MASTER
+#ifdef CPP_IOIPSL
+! Ehouarn: Gather fields and make master send to output
+                call Gather_Field(vcov,ip1jm,llm,0)
+                call Gather_Field(ucov,ip1jmp1,llm,0)
+                call Gather_Field(teta,ip1jmp1,llm,0)
+                call Gather_Field(pk,ip1jmp1,llm,0)
+		call Gather_Field(phi,ip1jmp1,llm,0)
+                 do iq=1,nqtot
+                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+                 enddo
+		call Gather_Field(masse,ip1jmp1,llm,0)
+                call Gather_Field(ps,ip1jmp1,1,0)
+		call Gather_Field(phis,ip1jmp1,1,0)
+                if (mpi_rank==0) then
+                 CALL writedynav(itau,vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+		endif
+#endif
+!$OMP END MASTER
+               ENDIF ! of IF (ok_dyn_ave)
+            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
+
+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
+
+! ADAPTATION GCM POUR CP(T)
+      call tpot2t_glo_p(teta,temp,pk)
+      ijb=ij_begin
+      ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+        tsurpk(ijb:ije,l)=cpp*temp(ijb:ije,l)/pk(ijb:ije,l)
+      enddo
+!$OMP END DO
+
+!$OMP MASTER
+!              CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi)
+      CALL geopot_p  ( ip1jmp1, tsurpk  , pk , pks,  phis  , phi   )
+       
+cym        unat=0.
+        
+              ijb=ij_begin
+              ije=ij_end
+        
+              if (pole_nord) then
+                ijb=ij_begin+iip1
+                unat(1:iip1,:)=0.
+              endif
+        
+              if (pole_sud) then 
+                ije=ij_end-iip1
+                unat(ij_end-iip1+1:ij_end,:)=0.
+              endif
+            
+              do l=1,llm
+                unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije)
+              enddo
+
+              ijb=ij_begin
+              ije=ij_end
+              if (pole_sud) ije=ij_end-iip1
+        
+              do l=1,llm
+                vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije)
+              enddo
+        
+#ifdef CPP_IOIPSL
+              if (ok_dyn_ins) then
+! Ehouarn: Gather fields and make master write to output
+                call Gather_Field(vcov,ip1jm,llm,0)
+                call Gather_Field(ucov,ip1jmp1,llm,0)
+                call Gather_Field(teta,ip1jmp1,llm,0)
+		call Gather_Field(phi,ip1jmp1,llm,0)
+                 do iq=1,nqtot
+                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+                 enddo
+		call Gather_Field(masse,ip1jmp1,llm,0)
+                call Gather_Field(ps,ip1jmp1,1,0)
+		call Gather_Field(phis,ip1jmp1,1,0)
+                if (mpi_rank==0) then
+	         CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
+		endif
+!              CALL writehist_p(histid,histvid, itau,vcov, 
+!     &                         ucov,teta,phi,q,masse,ps,phis)
+! or use writefield_p
+!      call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+!      call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+!      call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+!      call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+              endif ! of if (ok_dyn_ins)
+#endif
+! For some Grads outputs of fields
+              if (output_grads_dyn) then
+! Ehouarn: hope this works the way I think it does:
+                  call Gather_Field(unat,ip1jmp1,llm,0)
+                  call Gather_Field(vnat,ip1jm,llm,0)
+                  call Gather_Field(teta,ip1jmp1,llm,0)
+                  call Gather_Field(ps,ip1jmp1,1,0)
+                  do iq=1,nqtot
+                    call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+                  enddo
+                  if (mpi_rank==0) then
+#include "write_grads_dyn.h"
+                  endif
+              endif ! of if (output_grads_dyn)
+!$OMP END MASTER
+             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
+c$OMP MASTER
+
+              if (planet_type=="mars") then
+                CALL dynredem1_p("restart.nc",REAL(itau)/REAL(day_step),
+     &                           vcov,ucov,teta,q,masse,ps)
+              else
+                CALL dynredem1_p("restart.nc",start_time,
+     &                           vcov,ucov,teta,q,masse,ps)
+              endif
+!              CLOSE(99)
+c$OMP END MASTER
+            ENDIF ! of IF (itau.EQ.itaufin)
+
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2
+                   END IF
+            ELSE
+
+c      ......   pas leapfrog  .....
+
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF ! of IF (MOD(itau,iperiod).EQ.0)
+                   !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
+
+
+      ELSE ! of IF (.not.purmats)
+
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+
+             itau =  itau + 1
+!             iday = day_ini+itau/day_step
+!             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+!
+!                  IF(time.GT.1.) THEN
+!                   time = time-1.
+!                   iday = iday+1
+!                  ENDIF
+
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then  
+c$OMP MASTER
+                 call fin_getparam
+                 call finalize_parallel
+c$OMP END MASTER
+                 abort_message = 'Simulation finished'
+                 call abort_gcm(modname,abort_message,0)
+                 RETURN
+               ENDIF
+               GO TO 2
+
+            ELSE ! of IF(forward) i.e. backward step
+
+              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+#ifdef CPP_IOIPSL
+               IF (ok_dynzon) THEN
+               CALL bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+c les traceurs ne sont pas sortis, trop lourd. 
+c Peut changer eventuellement si besoin.
+!                 CALL bilan_dyn_p(dtvr*iperiod,dtvr*day_step*periodav,
+!     &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,
+!     &                 du,dudis,dutop,dufi)
+               END IF !ok_dynzon
+#endif
+               IF (ok_dyn_ave) THEN
+!$OMP MASTER
+#ifdef CPP_IOIPSL
+! Ehouarn: Gather fields and make master send to output
+                call Gather_Field(vcov,ip1jm,llm,0)
+                call Gather_Field(ucov,ip1jmp1,llm,0)
+                call Gather_Field(teta,ip1jmp1,llm,0)
+                call Gather_Field(pk,ip1jmp1,llm,0)
+		call Gather_Field(phi,ip1jmp1,llm,0)
+                do iq=1,nqtot
+                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+                enddo
+		call Gather_Field(masse,ip1jmp1,llm,0)
+                call Gather_Field(ps,ip1jmp1,1,0)
+		call Gather_Field(phis,ip1jmp1,1,0)
+                if (mpi_rank==0) then
+                 CALL writedynav(itau,vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+		endif
+#endif
+!$OMP END MASTER
+               ENDIF ! of IF (ok_dyn_ave)
+
+              ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
+
+
+               IF(MOD(itau,iecri         ).EQ.0) THEN
+c              IF(MOD(itau,iecri*day_step).EQ.0) THEN
+c$OMP BARRIER
+
+! ADAPTATION GCM POUR CP(T)
+                call tpot2t_glo_p(teta,temp,pk)
+                ijb=ij_begin
+                ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+                do l=1,llm      
+                  tsurpk(ijb:ije,l)=cpp*temp(ijb:ije,l)/
+     &                                             pk(ijb:ije,l)
+                enddo
+!$OMP END DO
+
+!$OMP MASTER
+!                CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi)
+                CALL geopot_p(ip1jmp1,tsurpk,pk,pks,phis,phi)
+
+cym        unat=0.
+                ijb=ij_begin
+                ije=ij_end
+        
+                if (pole_nord) then
+                  ijb=ij_begin+iip1
+                  unat(1:iip1,:)=0.
+                endif
+        
+                if (pole_sud) then 
+                  ije=ij_end-iip1
+                  unat(ij_end-iip1+1:ij_end,:)=0.
+                endif
+            
+                do l=1,llm
+                  unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije)
+                enddo
+
+                ijb=ij_begin
+                ije=ij_end
+                if (pole_sud) ije=ij_end-iip1
+        
+                do l=1,llm
+                  vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije)
+                enddo
+
+#ifdef CPP_IOIPSL
+              if (ok_dyn_ins) then
+! Ehouarn: Gather fields and make master send to output
+                call Gather_Field(vcov,ip1jm,llm,0)
+                call Gather_Field(ucov,ip1jmp1,llm,0)
+                call Gather_Field(teta,ip1jmp1,llm,0)
+		call Gather_Field(phi,ip1jmp1,llm,0)
+                 do iq=1,nqtot
+                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+                 enddo
+		call Gather_Field(masse,ip1jmp1,llm,0)
+                call Gather_Field(ps,ip1jmp1,1,0)
+		call Gather_Field(phis,ip1jmp1,1,0)
+                if (mpi_rank==0) then
+                 CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
+		endif
+!                CALL writehist_p(histid, histvid, itau,vcov , 
+!     &                           ucov,teta,phi,q,masse,ps,phis)
+              endif ! of if (ok_dyn_ins)
+#endif
+! For some Grads output (but does it work?)
+                if (output_grads_dyn) then
+                  call Gather_Field(unat,ip1jmp1,llm,0)
+                  call Gather_Field(vnat,ip1jm,llm,0)
+                  call Gather_Field(teta,ip1jmp1,llm,0)
+                  call Gather_Field(ps,ip1jmp1,1,0)
+                   do iq=1,nqtot
+                    call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+                   enddo
+c      
+                  if (mpi_rank==0) then
+#include "write_grads_dyn.h"
+                  endif
+                endif ! of if (output_grads_dyn)
+
+!$OMP END MASTER
+              ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+
+              IF(itau.EQ.itaufin) THEN
+c$OMP MASTER
+                if (planet_type=="mars") then
+                  CALL dynredem1_p("restart.nc",
+     &                              REAL(itau)/REAL(day_step),
+     &                               vcov,ucov,teta,q,masse,ps)
+                else
+                  CALL dynredem1_p("restart.nc",start_time,
+     &                               vcov,ucov,teta,q,masse,ps)
+                
+                endif
+c$OMP END MASTER
+              ENDIF ! of IF(itau.EQ.itaufin)
+
+              forward = .TRUE.
+              GO TO  1
+
+            ENDIF ! of IF (forward)
+
+      END IF ! of IF(.not.purmats)
+c$OMP MASTER
+      call fin_getparam
+      call finalize_parallel
+c$OMP END MASTER
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/logic.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/logic.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/logic.h	(revision 222)
@@ -0,0 +1,29 @@
+!
+! $Id: logic.h 1520 2011-05-23 11:37:09Z emillour $
+!
+!
+! NB: keep items of different kinds in seperate common blocs to avoid
+!     "misaligned commons" issues
+!-----------------------------------------------------------------------
+! INCLUDE 'logic.h'
+
+      COMMON/logicl/ purmats,forward,leapf,apphys,                      &
+     &  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus       &
+     &  ,read_start,ok_guide,ok_strato,tidal,ok_gradsfile               &
+     &  ,ok_limit,ok_etat0,hybrid                                       &
+     &  ,moyzon_mu,moyzon_ch
+
+      COMMON/logici/ iflag_phys,iflag_trac
+      
+      LOGICAL purmats,forward,leapf,apphys,statcl,conser,               &
+     & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus                      &
+     &  ,read_start,ok_guide,ok_strato,tidal,ok_gradsfile               &
+     &  ,ok_limit,ok_etat0
+      logical hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
+                     ! (only used if disvert_type==2)
+      logical moyzon_mu,moyzon_ch ! used for zonal averages in Titan
+
+      integer iflag_phys,iflag_trac
+!$OMP THREADPRIVATE(/logicl/)
+!$OMP THREADPRIVATE(/logici/)
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massbar_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massbar_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massbar_p.F	(revision 222)
@@ -0,0 +1,117 @@
+      SUBROUTINE massbar_p(  masse, massebx, masseby )
+     
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+      INTEGER ij,l,ijb,ije
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+      
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+      DO   100    l = 1 , llm
+c
+        ijb=ij_begin
+        ije=ij_end+iip1
+        if (pole_sud) ije=ije-iip1
+        
+        DO  ij = ijb, ije - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+
+        
+
+        DO  ij = ijb+iim, ije+iim, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+      
+        ijb=ij_begin-iip1
+        ije=ij_end+iip1
+        if (pole_nord) ijb=ij_begin
+        if (pole_sud) ije=ij_end-iip1
+
+         DO  ij = ijb,ije
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massbarxy_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massbarxy_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massbarxy_p.F	(revision 222)
@@ -0,0 +1,55 @@
+      SUBROUTINE massbarxy_p(  masse, massebxy )
+      USE parallel_lmdz
+      implicit none
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+      INTEGER ij,l,ijb,ije
+
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = ijb, ije - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = ijb+iip1-1, ije+iip1-1, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massdair_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massdair_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/massdair_p.F	(revision 222)
@@ -0,0 +1,120 @@
+      SUBROUTINE massdair_p( 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 "comconst.h"
+#include "comgeom.h"
+c
+c  .....   arguments  ....
+c
+      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_const_mpi.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_const_mpi.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_const_mpi.F90	(revision 222)
@@ -0,0 +1,104 @@
+! 
+! $Id: mod_const_mpi.F90 2055 2014-06-04 12:33:27Z acaubel $
+!
+MODULE mod_const_mpi
+  IMPLICIT NONE
+  INTEGER,SAVE :: COMM_LMDZ
+  INTEGER,SAVE :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+#ifdef CPP_IOIPSL
+    USE IOIPSL, ONLY: getin
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+    USE ioipsl_getincom, only: getin
+#endif
+! Use of Oasis-MCT coupler 
+#ifdef CPP_OMCT
+    USE mod_prism
+#endif
+#ifdef CPP_XIOS
+    USE wxios, only: wxios_init
+#endif
+    IMPLICIT NONE
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER             :: ierr
+    INTEGER             :: comp_id
+    INTEGER             :: thread_required
+    INTEGER             :: thread_provided
+    CHARACTER(len = 6)  :: type_ocean
+
+!$OMP MASTER
+    type_ocean = 'force '
+    CALL getin('type_ocean', type_ocean)
+!$OMP END MASTER
+!$OMP BARRIER
+
+    IF (type_ocean=='couple') THEN
+#ifdef CPP_COUPLE
+!$OMP MASTER
+#ifdef CPP_XIOS
+      CALL wxios_init("LMDZ", outcom=COMM_LMDZ, type_ocean=type_ocean)
+#else
+       CALL prism_init_comp_proto (comp_id, 'LMDZ', ierr)
+       CALL prism_get_localcomm_proto(COMM_LMDZ,ierr)
+#endif
+!$OMP END MASTER
+#endif
+#ifdef CPP_MPI
+      MPI_REAL_LMDZ=MPI_REAL8
+#endif
+    ELSE
+      CALL init_mpi
+    ENDIF
+
+  END SUBROUTINE Init_const_mpi
+  
+  SUBROUTINE Init_mpi
+#ifdef CPP_XIOS
+    USE wxios, only: wxios_init
+#endif
+  IMPLICIT NONE
+#ifdef CPP_MPI
+     INCLUDE 'mpif.h'
+#endif
+    INTEGER             :: ierr
+    INTEGER             :: thread_required
+    INTEGER             :: thread_provided
+
+#ifdef CPP_MPI
+!$OMP MASTER
+!      thread_required=MPI_THREAD_SERIALIZED
+
+!      CALL MPI_INIT_THREAD(thread_required,thread_provided,ierr)
+!      IF (thread_provided < thread_required) THEN
+!        PRINT *,'Warning : The multithreaded level of MPI librairy do not provide the requiered level',  &
+!                ' in mod_const_mpi::Init_const_mpi'
+!      ENDIF
+      COMM_LMDZ=MPI_COMM_WORLD
+      MPI_REAL_LMDZ=MPI_REAL8
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Initialisation de XIOS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#ifdef CPP_XIOS
+      CALL wxios_init("LMDZ", outcom=COMM_LMDZ)
+#endif
+!$OMP END MASTER
+#else
+#ifdef CPP_XIOS
+!$OMP MASTER
+      CALL wxios_init("LMDZ")
+!$OMP END MASTER
+#endif
+#endif
+
+   END SUBROUTINE Init_mpi
+    
+END MODULE mod_const_mpi
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_hallo.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_hallo.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_hallo.F90	(revision 222)
@@ -0,0 +1,814 @@
+module mod_Hallo
+USE parallel_lmdz
+implicit none
+  logical,save :: use_mpi_alloc
+  integer, parameter :: MaxRequest=200
+  integer, parameter :: MaxProc=80
+  integer, parameter :: MaxBufferSize=1024*1024*16
+  integer, parameter :: ListSize=1000
+  
+  integer,save       :: MaxBufferSize_Used
+!$OMP THREADPRIVATE( MaxBufferSize_Used)
+
+   real,save,pointer,dimension(:) :: Buffer
+!$OMP THREADPRIVATE(Buffer)
+
+   integer,save,dimension(Listsize) :: Buffer_Pos
+   integer,save :: Index_Pos
+!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
+   
+  type Hallo
+    real, dimension(:,:),pointer :: Field
+    integer :: offset
+    integer :: size
+    integer :: NbLevel
+    integer :: Stride
+  end type Hallo
+  
+  type request_SR
+    integer :: NbRequest=0
+    integer :: Pos
+    integer :: Index 
+    type(Hallo),dimension(MaxRequest) :: Hallo
+    integer :: MSG_Request
+  end type request_SR
+
+  type request
+    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
+    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
+    integer :: tag=1
+  end type request
+  
+    
+  contains
+
+  subroutine Init_mod_hallo
+    implicit none
+
+    Index_Pos=1
+    Buffer_Pos(Index_Pos)=1
+    MaxBufferSize_Used=0
+
+    IF (use_mpi_alloc .AND. using_mpi) THEN
+      CALL create_global_mpi_buffer
+    ELSE 
+      CALL create_standard_mpi_buffer
+    ENDIF
+     
+  end subroutine init_mod_hallo
+
+  SUBROUTINE create_standard_mpi_buffer
+  IMPLICIT NONE
+    
+    ALLOCATE(Buffer(MaxBufferSize))
+    
+  END SUBROUTINE create_standard_mpi_buffer
+  
+  SUBROUTINE create_global_mpi_buffer
+  IMPLICIT NONE
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif  
+    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
+    REAL :: MPI_Buffer
+#ifdef CPP_MPI
+    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
+#else
+    INTEGER(KIND=8) :: BS
+#endif
+    INTEGER :: i,ierr
+
+!  Allocation du buffer MPI
+      Bs=8*MaxBufferSize
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      DO i=1,MaxBufferSize
+	MPI_Buffer(i)=i
+      ENDDO
+     
+      CALL  Associate_buffer(MPI_Buffer)
+      
+  CONTAINS
+     
+     SUBROUTINE Associate_buffer(MPI_Buffer)
+     IMPLICIT NONE
+       REAL,DIMENSION(:),target :: MPI_Buffer  
+
+         Buffer=>MPI_Buffer
+ 
+      END SUBROUTINE  Associate_buffer
+                                      
+  END SUBROUTINE create_global_mpi_buffer
+ 
+      
+  subroutine allocate_buffer(Size,Index,Pos)
+  implicit none
+    integer :: Size
+    integer :: Index
+    integer :: Pos
+
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
+      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+    
+    if (Index_pos>=ListSize) then
+      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+     
+    Pos=Buffer_Pos(Index_Pos)
+    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
+    Index_Pos=Index_Pos+1
+    Index=Index_Pos
+    
+  end subroutine allocate_buffer
+     
+  subroutine deallocate_buffer(Index)
+  implicit none
+    integer :: Index
+    
+    Buffer_Pos(Index)=-1
+    
+    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
+      Index_Pos=Index_Pos-1
+    end do
+
+  end subroutine deallocate_buffer  
+  
+  subroutine SetTag(a_request,tag)
+  implicit none
+    type(request):: a_request
+    integer :: tag
+    
+    a_request%tag=tag
+  end subroutine SetTag
+  
+  
+  subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
+    integer :: Stride
+    integer :: NbLevel
+    integer :: size
+    integer :: offset
+    real, dimension(Stride,NbLevel),target :: Field
+    type(Hallo) :: NewHallo
+    
+    NewHallo%Field=>Field
+    NewHallo%Stride=Stride
+    NewHallo%NbLevel=NbLevel
+    NewHallo%size=size
+    NewHallo%offset=offset
+    
+    
+  end subroutine Init_Hallo
+  
+  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
+  implicit none
+
+#include "dimensions.h"
+#include "paramet.h"    
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestSend(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif      
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+      
+   end subroutine Register_SendField      
+      
+  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
+  implicit none
+
+#include "dimensions.h"
+#include "paramet.h"    
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestRecv(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif   
+            
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+
+      
+   end subroutine Register_RecvField      
+  
+  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapField    
+  
+  
+    subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
+      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
+    enddo
+   
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapFieldHallo
+  
+  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo
+    
+    subroutine SendRequest(a_Request)
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer :: SizeBuffer
+      integer :: i,rank,l,ij,Pos,ierr
+      integer :: offset
+      real,dimension(:,:),pointer :: Field
+      integer :: Nb
+       
+      do rank=0,MPI_SIZE-1
+      
+        Req=>a_Request%RequestSend(rank)
+        
+        SizeBuffer=0
+        do i=1,Req%NbRequest
+          PtrHallo=>Req%Hallo(i)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+          DO l=1,PtrHallo%NbLevel
+            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+          ENDDO
+!$OMP ENDDO NOWAIT          
+        enddo
+      
+        if (SizeBuffer>0) then
+       
+          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
+
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+            Nb=iip1*PtrHallo%size-1
+            Field=>PtrHallo%Field
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+            do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        Buffer(Pos+ij)=Field(Offset+ij,l)
+	      enddo
+              
+              Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT            
+          enddo
+    
+!$OMP CRITICAL (MPI)
+         
+#ifdef CPP_MPI
+         call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                         COMM_LMDZ,Req%MSG_Request,ierr)
+#endif
+         IF (.NOT.using_mpi) THEN
+           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+           STOP
+         ENDIF
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+        endif
+
+    enddo
+   
+           
+      do rank=0,MPI_SIZE-1
+         
+          Req=>a_Request%RequestRecv(rank)
+          SizeBuffer=0
+          
+	  do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+            DO l=1,PtrHallo%NbLevel
+              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+            ENDDO
+!$OMP ENDDO NOWAIT          
+          enddo
+        
+          if (SizeBuffer>0) then
+
+             call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
+!$OMP CRITICAL (MPI)
+
+#ifdef CPP_MPI
+             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                           COMM_LMDZ,Req%MSG_Request,ierr)
+#endif             
+             IF (.NOT.using_mpi) THEN
+               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+               STOP
+             ENDIF
+
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+          endif
+      
+      enddo
+                        
+   end subroutine SendRequest 
+   
+   subroutine WaitRequest(a_Request)
+   implicit none
+   
+#include "dimensions.h"
+#include "paramet.h"
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(2*mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
+#else
+      integer, dimension(1,2*mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      integer :: Nb
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+      endif
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+
+              Pos=Pos+Nb+1
+	    enddo
+!$OMP ENDDO NOWAIT	    
+          enddo
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRequest
+     
+   subroutine WaitSendRequest(a_Request)
+   implicit none
+   
+#include "dimensions.h"
+#include "paramet.h"
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+
+      if (NbRequest>0) THEN 
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+      endif      
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      a_request%tag=1
+    end subroutine WaitSendRequest
+    
+   subroutine WaitRecvRequest(a_Request)
+   implicit none
+   
+#include "dimensions.h"
+#include "paramet.h"
+#ifdef CPP_MPI
+      include 'mpif.h'   
+#endif
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+#ifdef CPP_MPI
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+#else
+      integer, dimension(1,mpi_size) :: TabStatus
+#endif
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset,Nb
+      
+      
+      NbRequest=0
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+#ifdef CPP_MPI
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+#endif
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)     
+      endif
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+                 Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT
+          enddo
+        endif
+      enddo
+      
+           
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRecvRequest
+    
+    
+    
+    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    
+    INTEGER :: ij,ll,l
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb,ijb,ije
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
+    jje=min(jj_end,jj_end_new(MPI_Rank))
+    if (ij==ip1jm) jje=min(jje,jjm)
+
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+    endif
+
+
+  end subroutine CopyField    
+
+  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+
+    integer ::i,jje,jjb,ijb,ije,l
+
+     
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+
+        
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
+    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
+    if (ij==ip1jm) jje=min(jje,jjm)
+    
+    
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+
+    endif
+   end subroutine CopyFieldHallo        
+          
+end module mod_Hallo 
+   
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_interface_dyn_phys.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_interface_dyn_phys.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/mod_interface_dyn_phys.F90	(revision 222)
@@ -0,0 +1,58 @@
+! 
+! $Id: mod_interface_dyn_phys.F90 1615 2012-02-10 15:42:26Z emillour $
+!
+MODULE mod_interface_dyn_phys
+  INTEGER,SAVE,dimension(:),allocatable :: index_i
+  INTEGER,SAVE,dimension(:),allocatable :: index_j
+  
+  
+#ifdef CPP_PHYS
+! Interface with parallel physics,
+CONTAINS
+  
+  SUBROUTINE Init_interface_dyn_phys
+    USE mod_phys_lmdz_mpi_data
+    IMPLICIT NONE
+    include 'dimensions.h'    
+    
+    INTEGER :: i,j,k
+    
+    ALLOCATE(index_i(klon_mpi))
+    ALLOCATE(index_j(klon_mpi))
+    
+    k=1
+    IF (is_north_pole) THEN
+      index_i(k)=1
+      index_j(k)=1
+      k=2
+    ELSE
+      DO i=ii_begin,iim
+	index_i(k)=i
+	index_j(k)=jj_begin
+	k=k+1
+       ENDDO
+    ENDIF
+    
+    DO j=jj_begin+1,jj_end-1
+      DO i=1,iim
+	index_i(k)=i
+	index_j(k)=j
+	k=k+1
+      ENDDO
+    ENDDO
+    
+    IF (is_south_pole) THEN
+      index_i(k)=1
+      index_j(k)=jj_end
+    ELSE
+      DO i=1,ii_end
+	index_i(k)=i
+	index_j(k)=jj_end
+	k=k+1
+       ENDDO
+    ENDIF
+  
+  END SUBROUTINE Init_interface_dyn_phys 
+#endif
+! of #ifdef CPP_PHYS
+END MODULE mod_interface_dyn_phys
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/moyzon_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/moyzon_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/moyzon_mod.F90	(revision 222)
@@ -0,0 +1,82 @@
+      MODULE moyzon_mod
+! Moyennes zonales pour transmission a la physique 
+!======================================================================
+! Specifique a Titan
+!
+!======================================================================
+! Declaration des variables
+
+      REAL,ALLOCATABLE,SAVE :: zplevbar_mpi(:,:),zplaybar_mpi(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfibar_mpi(:,:),zqfibar_mpi(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zphibar_mpi(:,:),zphisbar_mpi(:)
+      REAL,ALLOCATABLE,SAVE :: zpkbar_mpi(:,:),ztetabar_mpi(:,:)
+
+      REAL,ALLOCATABLE,SAVE :: zplevbar(:,:),zplaybar(:,:)
+      REAL,ALLOCATABLE,SAVE :: ztfibar(:,:),zqfibar(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zphibar(:,:),zphisbar(:)
+      REAL,ALLOCATABLE,SAVE :: zzlevbar(:,:),zzlaybar(:,:)
+!$OMP THREADPRIVATE(zplevbar,zplaybar,ztfibar,zqfibar)
+!$OMP THREADPRIVATE(zphibar,zphisbar,zzlevbar,zzlaybar)
+
+! pmoy: global averaged pressure...
+! tmoy: global averaged temperature...
+! put here to be transfered to Titan routines...
+! to be changed...
+      REAL,ALLOCATABLE,SAVE :: plevmoy(:),playmoy(:)
+      REAL,ALLOCATABLE,SAVE :: zlevmoy(:),zlaymoy(:),phimoy(:)
+      REAL,ALLOCATABLE,SAVE :: tmoy(:),tetamoy(:),pkmoy(:)
+      INTEGER,ALLOCATABLE,SAVE :: klat(:)
+
+CONTAINS
+
+!======================================================================
+SUBROUTINE moyzon_init(klon,llm,nqtot)
+#ifdef CPP_PHYS
+!! This routine needs physics
+IMPLICIT NONE
+       INTEGER :: klon,llm,nqtot
+
+      ALLOCATE(zplevbar_mpi(klon,llm+1),zplaybar_mpi(klon,llm))
+      ALLOCATE(zphibar_mpi(klon,llm),zphisbar_mpi(klon))
+      ALLOCATE(ztfibar_mpi(klon,llm),zqfibar_mpi(klon,llm,nqtot))
+      ALLOCATE(zpkbar_mpi(klon,llm),ztetabar_mpi(klon,llm))
+#endif
+END SUBROUTINE moyzon_init
+
+!======================================================================
+SUBROUTINE moyzon_init_omp(nlon,llm,nqtot)
+#ifdef CPP_PHYS
+IMPLICIT NONE
+
+      INTEGER :: nlon,llm,nqtot
+
+      ALLOCATE(zplevbar(nlon,llm+1),zplaybar(nlon,llm))
+      ALLOCATE(zphibar(nlon,llm),zphisbar(nlon))
+      ALLOCATE(ztfibar(nlon,llm),zqfibar(nlon,llm,nqtot))
+      ALLOCATE(zzlevbar(nlon,llm+1),zzlaybar(nlon,llm))
+#endif
+END SUBROUTINE moyzon_init_omp
+
+!======================================================================
+SUBROUTINE moyzon(nlev,var,varbar)
+
+IMPLICIT NONE
+#include "dimensions.h"
+#include "paramet.h"
+
+      INTEGER :: nlev
+      REAL,dimension(iip1,nlev) :: var
+      REAL,dimension(nlev)      :: varbar
+
+      INTEGER :: i
+
+      varbar(:) = 0.
+      do i=1,iim
+        varbar(:)=varbar(:)+var(i,:)/iim
+      enddo
+
+      return
+END SUBROUTINE moyzon
+
+!======================================================================
+      END MODULE moyzon_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrad_gam_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrad_gam_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrad_gam_p.F	(revision 222)
@@ -0,0 +1,67 @@
+      SUBROUTINE nxgrad_gam_p( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+      integer ismin,ismax
+      external ismin,ismax
+      INTEGER :: ijb,ije
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if(pole_nord) ijb=ij_begin+iip1
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+    
+      if (pole_nord) then
+        DO  ij = 1,iip1
+         x(    ij    ,l ) = 0.
+        ENDDO
+      endif
+
+      if (pole_sud) then
+        DO  ij = 1,iip1
+         x( ij +ip1jm,l ) = 0.
+        ENDDO
+      endif
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrad_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrad_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrad_p.F	(revision 222)
@@ -0,0 +1,67 @@
+      SUBROUTINE nxgrad_p (klevel, rot, x, y )
+c
+c     P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER :: ijb,ije
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+       
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_nord)  ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+   
+      if (pole_nord) then 
+        DO ij = 1,iip1
+          x(    ij    ,l ) = 0.
+        ENDDO
+      endif
+      
+      if (pole_sud) then 
+        DO ij = 1,iip1
+          x( ij +ip1jm,l ) = 0.
+        ENDDO
+      endif
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgraro2_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgraro2_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgraro2_p.F	(revision 222)
@@ -0,0 +1,141 @@
+       SUBROUTINE nxgraro2_p (klevel,xcov, ycov, lr, grx_out, gry_out )
+c
+c      P.Le Van .
+c   ***********************************************************
+c                                 lr
+c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      USE write_Field_p
+      USE parallel_lmdz
+      USE times
+      USE mod_hallo
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+c
+c    ......  variables en arguments  .......
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
+      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL,SAVE :: rot(ip1jm,llm)
+      REAL  signe, nugradrs
+      INTEGER l,ij,iter,lr
+      Type(Request) :: Request_dissip
+c    ........................................................
+c
+      INTEGER :: ijb,ije,jjb,jje
+      
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+ 
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+        grx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP BARRIER
+       call Register_Hallo(grx,ip1jmp1,llm,0,1,1,0,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+        gry(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+ 
+c
+      CALL     rotatf_p     ( klevel, grx, gry, rot )
+c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+
+c$OMP BARRIER
+       call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+      
+      CALL laplacien_rot_p ( klevel, rot, rot,grx,gry      )
+c       call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+c$OMP BARRIER
+       call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+	CALL laplacien_rotgam_p ( klevel, rot, rot )
+      ENDDO
+      
+c       call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
+      
+c
+c
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+       
+      CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2,1, .FALSE.,1)
+c$OMP BARRIER
+       call Register_Hallo(rot,ip1jm,llm,1,0,0,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+
+      CALL nxgrad_p ( klevel, rot, grx, gry )
+
+c
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO    l = 1, klevel
+        
+         if(pole_sud) ije=ij_end-iip1
+         DO  ij = ijb, ije
+          gry_out( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+        
+         if(pole_sud) ije=ij_end
+         DO  ij = ijb, ije
+          grx_out( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+     
+      ENDDO
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrarot_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrarot_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/nxgrarot_p.F	(revision 222)
@@ -0,0 +1,101 @@
+      SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out )
+c   ***********************************************************
+c
+c    Auteur :  P.Le Van  
+c
+c                                 lr
+c      calcul de  ( nXgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      USE parallel_lmdz
+      USE times
+      USE write_field_p
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
+      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
+
+c
+      REAL,SAVE :: rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+c      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+      DO l = 1, klevel
+        grx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO 
+c$OMP END DO NOWAIT      
+
+      if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, klevel
+        gry(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      DO 10 iter = 1,lr
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(grx,ip1jmp1,llm,0,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+      CALL  rotat_p (klevel,grx, gry, rot )
+c      call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/)))
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2)
+
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(rot,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL nxgrad_p (klevel,rot, grx, gry )
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5  l = 1, klevel
+      if(pole_sud) ije=ij_end-iip1
+      DO 2 ij = ijb, ije
+      gry_out( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      if(pole_sud) ije=ij_end
+      DO 3 ij = ijb, ije
+      grx_out( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c      call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/)))
+c      call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/)))
+c      stop
+  10  CONTINUE
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/omp_chunk.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/omp_chunk.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/omp_chunk.h	(revision 222)
@@ -0,0 +1,1 @@
+#define OMP_CHUNK 5
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/parallel_lmdz.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/parallel_lmdz.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/parallel_lmdz.F90	(revision 222)
@@ -0,0 +1,626 @@
+! 
+! $Id: parallel.F90 1575 2011-09-21 13:57:48Z jghattas $
+!
+  module parallel_lmdz
+  USE mod_const_mpi
+#ifdef CPP_IOIPSL
+      use IOIPSL, only: getin
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      use ioipsl_getincom, only: getin
+#endif    
+    
+    LOGICAL,SAVE :: using_mpi=.TRUE.
+    LOGICAL,SAVE :: using_omp
+    
+    integer, save :: mpi_size
+    integer, save :: mpi_rank
+    integer, save :: jj_begin
+    integer, save :: jj_end
+    integer, save :: jj_nb
+    integer, save :: ij_begin
+    integer, save :: ij_end
+    logical, save :: pole_nord
+    logical, save :: pole_sud
+    
+    integer, allocatable, save, dimension(:) :: jj_begin_para
+    integer, allocatable, save, dimension(:) :: jj_end_para
+    integer, allocatable, save, dimension(:) :: jj_nb_para
+    integer, save :: OMP_CHUNK
+    integer, save :: omp_rank
+    integer, save :: omp_size  
+!$OMP THREADPRIVATE(omp_rank)
+
+ contains
+ 
+    subroutine init_parallel
+    USE vampir
+    implicit none
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+
+      integer :: ierr
+      integer :: i,j
+      integer :: type_size
+      integer, dimension(3) :: blocklen,type
+      integer :: comp_id
+      character(len=4)  :: num
+      character(len=20) :: filename
+ 
+#ifdef CPP_OMP    
+      INTEGER :: OMP_GET_NUM_THREADS
+      EXTERNAL OMP_GET_NUM_THREADS
+      INTEGER :: OMP_GET_THREAD_NUM
+      EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef CPP_MPI
+       using_mpi=.TRUE.
+#else
+       using_mpi=.FALSE.
+#endif
+      
+
+#ifdef CPP_OMP
+       using_OMP=.TRUE.
+#else
+       using_OMP=.FALSE.
+#endif
+      
+      call InitVampir
+      
+      IF (using_mpi) THEN
+#ifdef CPP_MPI
+        call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
+        call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
+#endif
+      ELSE
+        mpi_size=1
+        mpi_rank=0
+      ENDIF
+
+
+! Open text output file with mpi_rank in suffix of file name 
+      IF (lunout /= 5 .and. lunout /= 6) THEN
+         WRITE(num,'(I4.4)') mpi_rank
+         filename='lmdz.out_'//num
+         IF (mpi_rank .NE. 0) THEN
+            OPEN(UNIT=lunout,FILE=TRIM(filename),ACTION='write', &
+               STATUS='unknown',FORM='formatted',IOSTAT=ierr) 
+         ENDIF
+      ENDIF
+
+      
+      allocate(jj_begin_para(0:mpi_size-1))
+      allocate(jj_end_para(0:mpi_size-1))
+      allocate(jj_nb_para(0:mpi_size-1))
+      
+      do i=0,mpi_size-1
+        jj_nb_para(i)=(jjm+1)/mpi_size
+        if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
+        
+        if (jj_nb_para(i) <= 2 ) then
+          
+         write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
+         write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
+          
+#ifdef CPP_MPI
+          IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
+#endif          
+        endif
+        
+      enddo
+      
+!      jj_nb_para(0)=11
+!      jj_nb_para(1)=25
+!      jj_nb_para(2)=25
+!      jj_nb_para(3)=12      
+
+      j=1
+      
+      do i=0,mpi_size-1 
+        
+        jj_begin_para(i)=j
+        jj_end_para(i)=j+jj_Nb_para(i)-1
+        j=j+jj_Nb_para(i)
+      
+      enddo
+      
+      jj_begin = jj_begin_para(mpi_rank)
+      jj_end   = jj_end_para(mpi_rank)
+      jj_nb    = jj_nb_para(mpi_rank)
+      
+      ij_begin=(jj_begin-1)*iip1+1
+      ij_end=jj_end*iip1
+      
+      if (mpi_rank.eq.0) then
+        pole_nord=.TRUE.
+      else 
+        pole_nord=.FALSE.
+      endif
+      
+      if (mpi_rank.eq.mpi_size-1) then
+        pole_sud=.TRUE.
+      else 
+        pole_sud=.FALSE.
+      endif
+        
+      write(lunout,*)"init_parallel: jj_begin",jj_begin
+      write(lunout,*)"init_parallel: jj_end",jj_end
+      write(lunout,*)"init_parallel: ij_begin",ij_begin
+      write(lunout,*)"init_parallel: ij_end",ij_end
+
+!$OMP PARALLEL
+
+#ifdef CPP_OMP
+!$OMP MASTER
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+!$OMP BARRIER
+        omp_rank=OMP_GET_THREAD_NUM()    
+
+!Config  Key  = omp_chunk
+!Config  Desc = taille des blocs openmp
+!Config  Def  = 1
+!Config  Help = defini la taille des packets d'itÃ¯Â¿Âœration openmp
+!Config         distribue a chaque tache lors de l'entree dans une
+!Config         boucle parallelisee
+
+!$OMP MASTER
+      omp_chunk=(llm+1)/omp_size
+      IF (MOD(llm+1,omp_size)/=0) omp_chunk=omp_chunk+1
+      CALL getin('omp_chunk',omp_chunk)
+!$OMP END MASTER
+!$OMP BARRIER        
+#else    
+        omp_size=1
+        omp_rank=0
+#endif
+!$OMP END PARALLEL         
+    
+    end subroutine init_parallel
+
+    
+    subroutine SetDistrib(jj_Nb_New)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New
+      INTEGER :: i  
+  
+      jj_Nb_Para=jj_Nb_New
+      
+      jj_begin_para(0)=1
+      jj_end_para(0)=jj_Nb_Para(0)
+      
+      do i=1,mpi_size-1 
+        
+        jj_begin_para(i)=jj_end_para(i-1)+1
+        jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1
+      
+      enddo
+      
+      jj_begin = jj_begin_para(mpi_rank)
+      jj_end   = jj_end_para(mpi_rank)
+      jj_nb    = jj_nb_para(mpi_rank)
+      
+      ij_begin=(jj_begin-1)*iip1+1
+      ij_end=jj_end*iip1
+
+    end subroutine SetDistrib
+
+
+
+    
+    subroutine Finalize_parallel
+#ifdef CPP_XIOS
+    ! ug Pour les sorties XIOS
+	USE wxios
+#endif
+#ifdef CPP_COUPLE
+! Use of Oasis-MCT coupler 
+#if defined CPP_OMCT
+    use mod_prism
+#else
+    use mod_prism_proto
+#endif
+! Ehouarn: surface_data module is in 'phylmd' ...
+      use surface_data, only : type_ocean
+      implicit none
+#else
+      implicit none
+! without the surface_data module, we declare (and set) a dummy 'type_ocean'
+      character(len=6),parameter :: type_ocean="dummy"
+#endif
+! #endif of #ifdef CPP_EARTH
+
+      include "dimensions.h"
+      include "paramet.h"
+#ifdef CPP_MPI
+      include 'mpif.h'
+#endif      
+
+      integer :: ierr
+      integer :: i
+
+      if (allocated(jj_begin_para)) deallocate(jj_begin_para)
+      if (allocated(jj_end_para))   deallocate(jj_end_para)
+      if (allocated(jj_nb_para))    deallocate(jj_nb_para)
+
+      if (type_ocean == 'couple') then
+#ifdef CPP_XIOS
+    !Fermeture propre de XIOS
+      CALL wxios_close()
+#else
+#ifdef CPP_COUPLE
+         call prism_terminate_proto(ierr)
+         IF (ierr .ne. PRISM_Ok) THEN
+            call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
+         endif
+#endif 
+#endif
+      else
+#ifdef CPP_XIOS
+    !Fermeture propre de XIOS
+      CALL wxios_close()
+#endif
+#ifdef CPP_MPI
+         IF (using_mpi) call MPI_FINALIZE(ierr)
+#endif
+      end if
+      
+    end subroutine Finalize_parallel
+        
+    subroutine Pack_Data(Field,ij,ll,row,Buffer)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer, intent(in) :: ij,ll,row
+      real,dimension(ij,ll),intent(in) ::Field
+      real,dimension(ll*iip1*row), intent(out) :: Buffer 
+            
+      integer :: Pos
+      integer :: i,l
+      
+      Pos=0
+      do l=1,ll
+        do i=1,row*iip1
+          Pos=Pos+1
+          Buffer(Pos)=Field(i,l)
+        enddo
+      enddo
+      
+    end subroutine Pack_data 
+     
+    subroutine Unpack_Data(Field,ij,ll,row,Buffer)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer, intent(in) :: ij,ll,row
+      real,dimension(ij,ll),intent(out) ::Field
+      real,dimension(ll*iip1*row), intent(in) :: Buffer 
+            
+      integer :: Pos
+      integer :: i,l
+      
+      Pos=0
+      
+      do l=1,ll
+        do i=1,row*iip1
+          Pos=Pos+1
+          Field(i,l)=Buffer(Pos)
+        enddo
+      enddo
+      
+    end subroutine UnPack_data
+
+    
+    SUBROUTINE barrier
+    IMPLICIT NONE
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+    
+!$OMP CRITICAL (MPI)      
+#ifdef CPP_MPI
+      IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+    
+    END SUBROUTINE barrier
+       
+      
+    subroutine exchange_hallo(Field,ij,ll,up,down)
+    USE Vampir
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: up,down
+      
+      INTEGER :: ierr
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+      INTEGER, DIMENSION(4) :: Request
+#ifdef CPP_MPI
+      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
+#else
+      INTEGER, DIMENSION(1,4) :: Status
+#endif
+      INTEGER :: NbRequest
+      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
+      REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
+      INTEGER :: Buffer_size      
+
+      IF (using_mpi) THEN
+
+        CALL barrier
+      
+        call VTb(VThallo)
+      
+        SendUp=.TRUE.
+        SendDown=.TRUE.
+        RecvUp=.TRUE.
+        RecvDown=.TRUE.
+          
+        IF (pole_nord) THEN
+          SendUp=.FALSE.
+          RecvUp=.FALSE.
+        ENDIF
+    
+        IF (pole_sud) THEN
+          SendDown=.FALSE.
+          RecvDown=.FALSE.
+        ENDIF
+        
+        if (up.eq.0) then
+          SendDown=.FALSE.
+          RecvUp=.FALSE.
+        endif
+      
+        if (down.eq.0) then
+          SendUp=.FALSE.
+          RecvDown=.FALSE.
+        endif
+      
+        NbRequest=0
+  
+        IF (SendUp) THEN
+          NbRequest=NbRequest+1
+          buffer_size=down*iip1*ll
+          allocate(Buffer_Send_up(Buffer_size))
+          call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+        ENDIF
+  
+        IF (SendDown) THEN
+          NbRequest=NbRequest+1
+           
+          buffer_size=up*iip1*ll
+          allocate(Buffer_Send_down(Buffer_size))
+          call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
+        
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+        ENDIF
+    
+  
+        IF (RecvUp) THEN
+          NbRequest=NbRequest+1
+          buffer_size=up*iip1*ll
+          allocate(Buffer_recv_up(Buffer_size))
+              
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+     
+       
+        ENDIF
+  
+        IF (RecvDown) THEN
+          NbRequest=NbRequest+1
+          buffer_size=down*iip1*ll
+          allocate(Buffer_recv_down(Buffer_size))
+        
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+          call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
+                          COMM_LMDZ,Request(NbRequest),ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+        
+        ENDIF
+  
+#ifdef CPP_MPI
+        if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
+#endif
+        IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
+        IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)  
+
+        call VTe(VThallo)
+        call barrier
+      
+      ENDIF  ! using_mpi
+      
+      RETURN
+      
+    end subroutine exchange_Hallo
+    
+
+    subroutine Gather_Field(Field,ij,ll,rank)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h" 
+#include "iniprint.h"
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll,rank
+      REAL, dimension(ij,ll) :: Field
+      REAL, dimension(:),allocatable :: Buffer_send   
+      REAL, dimension(:),allocatable :: Buffer_Recv
+      INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
+      INTEGER :: ierr
+      INTEGER ::i
+      
+      IF (using_mpi) THEN
+
+        if (ij==ip1jmp1) then 
+           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
+           call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
+        else if (ij==ip1jm) then
+           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
+           call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
+        else
+           write(lunout,*)ij  
+        stop 'erreur dans Gather_Field'
+        endif
+        
+        if (MPI_Rank==rank) then
+          allocate(Buffer_Recv(ij*ll))
+
+!CDIR NOVECTOR
+          do i=0,MPI_Size-1
+             
+            if (ij==ip1jmp1) then 
+              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
+            else if (ij==ip1jm) then
+              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
+            else
+              stop 'erreur dans Gather_Field'
+            endif
+                   
+            if (i==0) then 
+              displ(i)=0 
+            else
+              displ(i)=displ(i-1)+Recv_count(i-1)
+            endif
+            
+          enddo
+          
+        else
+          ! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
+          !          below) about Buffer_Recv() being not allocated.
+          !          So make a dummy allocation.
+          allocate(Buffer_Recv(1))
+        endif ! of if (MPI_Rank==rank)
+  
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+        call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
+                          Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      
+        if (MPI_Rank==rank) then                  
+      
+          if (ij==ip1jmp1) then 
+            do i=0,MPI_Size-1
+              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
+                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
+            enddo
+          else if (ij==ip1jm) then
+            do i=0,MPI_Size-1
+               call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
+                               min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
+            enddo
+          endif
+        endif 
+      ENDIF ! using_mpi
+      
+    end subroutine Gather_Field
+
+
+    subroutine AllGather_Field(Field,ij,ll)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: ierr
+      
+      IF (using_mpi) THEN
+        call Gather_Field(Field,ij,ll,0)
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      ENDIF
+      
+    end subroutine AllGather_Field
+    
+   subroutine Broadcast_Field(Field,ij,ll,rank)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: rank
+      INTEGER :: ierr
+      
+      IF (using_mpi) THEN
+      
+!$OMP CRITICAL (MPI)
+#ifdef CPP_MPI
+      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
+#endif
+!$OMP END CRITICAL (MPI)
+      
+      ENDIF
+    end subroutine Broadcast_Field
+        
+   
+!  Subroutine verif_hallo(Field,ij,ll,up,down)
+!    implicit none
+!#include "dimensions.h"
+!#include "paramet.h"    
+!    include 'mpif.h'
+!    
+!      INTEGER :: ij,ll
+!      REAL, dimension(ij,ll) :: Field
+!      INTEGER :: up,down 
+!      
+!      REAL,dimension(ij,ll): NewField
+!      
+!      NewField=0
+!      
+!      ijb=ij_begin
+!      ije=ij_end
+!      if (pole_nord) 
+!      NewField(ij_be       
+
+  end module parallel_lmdz
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/pression_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/pression_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/pression_p.F	(revision 222)
@@ -0,0 +1,40 @@
+      SUBROUTINE pression_p( ngrid, ap, bp, ps, p )
+      USE parallel_lmdz
+c
+
+c      Auteurs : P. Le Van , Fr.Hourdin  .
+
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+      INTEGER ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      INTEGER ijb,ije
+
+      
+      ijb=ij_begin-iip1
+      ije=ij_end+2*iip1
+      
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO    l    = 1, llmp1
+        DO  ij   = ijb, ije
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT   
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/qminimum_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/qminimum_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/qminimum_p.F	(revision 222)
@@ -0,0 +1,107 @@
+      SUBROUTINE qminimum_p( q,nq,deltap )
+      USE parallel_lmdz
+      IMPLICIT none
+c
+c  -- Objet : Traiter les valeurs trop petites (meme negatives)
+c             pour l'eau vapeur et l'eau liquide
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+c
+      INTEGER nq
+      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide
+c
+c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+c            parametres seuil_vap, seuil_liq soient pareilles a celles 
+c            qui  sont utilisees dans la routine    ADDFI       )
+c     .................................................................
+c
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+c
+      REAL SSUM
+      EXTERNAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+c$OMP THREADPRIVATE(imprim)
+      INTEGER ijb,ije
+      INTEGER Index_pump(ip1jmp1)
+      INTEGER nb_pump
+c
+c Quand l'eau liquide est trop petite (ou negative), on prend
+c l'eau vapeur de la meme couche et la convertit en eau liquide
+c (sans changer la temperature !)
+c
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO 1000 k = 1, llm
+      DO 1040 i = ijb, ije
+            if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+               q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+               q(i,k,iq_liq) = seuil_liq
+            endif
+ 1040 CONTINUE
+ 1000 CONTINUE
+c$OMP END DO NOWAIT
+c$OMP BARRIER
+c --->  SYNCHRO OPENMP ICI
+
+c
+c Quand l'eau vapeur est trop faible (ou negative), on complete
+c le defaut en prennant de l'eau vapeur de la couche au-dessous.
+c
+      iq = iq_vap
+c
+      DO k = llm, 2, -1
+ccc      zx_abc = dpres(k) / dpres(k-1)
+c$OMP DO SCHEDULE(STATIC)
+      DO i = ijb, ije
+         if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
+            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
+     &           deltap(i,k) / deltap(i,k-1)
+            q(i,k,iq)   =  seuil_vap  
+         endif
+      ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+c$OMP BARRIER
+c
+c Quand il s'agit de la premiere couche au-dessus du sol, on
+c doit imprimer un message d'avertissement (saturation possible).
+c
+      nb_pump=0
+c$OMP DO SCHEDULE(STATIC)
+      DO i = ijb, ije
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+         IF (zx_pump(i) > 0.0) THEN
+            nb_pump = nb_pump+1
+            Index_pump(nb_pump)=i
+         ENDIF
+      ENDDO
+c$OMP END DO  
+!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+
+      IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN
+         PRINT *, 'ATT!:on pompe de l eau au sol'
+         DO i = 1, nb_pump
+               imprim = imprim + 1
+               PRINT*,'  en ',index_pump(i),zx_pump(index_pump(i))
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotat_nfil_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotat_nfil_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotat_nfil_p.F	(revision 222)
@@ -0,0 +1,52 @@
+      SUBROUTINE rotat_nfil_p (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van 
+c**************************************************************
+c.          Calcule le rotationnel  non filtre   ,
+c      a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      USE parallel_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
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotat_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotat_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotat_p.F	(revision 222)
@@ -0,0 +1,63 @@
+      SUBROUTINE rotat_p (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      USE parallel_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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotatf_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotatf_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/rotatf_p.F	(revision 222)
@@ -0,0 +1,67 @@
+      SUBROUTINE rotatf_p (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      USE parallel_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,jjb,jje
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO  10 l = 1,klevel
+c
+        DO   ij = ijb, ije - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = ijb+iip1-1, ije, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2, 2, .FALSE., 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+        DO l = 1, klevel
+          DO ij = ijb, ije
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/sponge_mod_p.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/sponge_mod_p.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/sponge_mod_p.F90	(revision 222)
@@ -0,0 +1,188 @@
+module sponge_mod_p
+
+implicit none
+
+
+! sponge parameters (set/read via conf_gcm.F)
+logical,save :: callsponge  ! do we use a sponge on upper layers
+integer,save :: mode_sponge ! sponge mode
+integer,save :: nsponge ! number of sponge layers 
+real,save :: tetasponge  ! sponge time scale (s) at topmost layer
+
+
+contains
+
+      subroutine sponge_p(ucov,vcov,h,ps,dt,mode)
+
+! Sponge routine: Quench ucov, vcov and potential temperature near the
+!                 top of the model
+! Depending on 'mode' relaxation of variables is towards:
+! mode = 0 : h -> h_mean , ucov -> 0 , vcov -> 0
+! mode = 1 : h -> h_mean , ucov -> ucov_mean , vcov -> 0
+! mode >= 2 : h -> h_mean , ucov -> ucov_mean , vcov -> vcov_mean
+! Number of layer over which sponge is applied is 'nsponge' (read from def file)
+! Time scale for quenching at top level is given by 'tetasponge' (read from
+! def file) and doubles as level indexes decrease.
+! Quenching is modeled as: A(t)=Am+A0exp(-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*dt))
+
+      USE Write_Field_p
+      use parallel_lmdz, only: pole_sud,pole_nord,jj_begin,jj_end
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "iniprint.h"
+
+! Arguments:
+!------------
+      real,intent(inout) :: ucov(iip1,jjp1,llm) ! covariant zonal wind
+      real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind
+      real,intent(inout) :: h(iip1,jjp1,llm) ! potential temperature
+!      real,intent(in) :: pext(iip1,jjp1) ! extensive pressure
+      real,intent(in) :: ps(iip1,jjp1) ! surface pressure (Pa)
+      real,intent(in) :: dt   ! time step
+      integer,intent(in) :: mode  ! sponge mode
+
+!   Local:
+!   ------
+
+      real,save :: sig_s(llm) !sigma au milieu des couches
+      REAL vm,um,hm,ptot(jjp1)
+      real,save :: cst(llm)
+      real :: pext(iip1,jjp1) ! extensive pressure
+
+      INTEGER l,i,j
+      integer :: jjb,jje
+      integer,save :: l0 ! layer down to which sponge is applied
+
+      real ssum
+
+      real zkm
+      logical,save :: firstcall=.true.
+
+
+
+      if (firstcall) then
+!$OMP BARRIER
+!$OMP MASTER
+       ! build approximative sigma levels at midlayer
+        do l=1,llm
+          sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+        enddo
+
+        l0=llm-nsponge+1
+ 
+        write(lunout,*)
+        write(lunout,*)'sponge mode',mode
+        write(lunout,*)'nsponge tetasponge ',nsponge,tetasponge
+        write(lunout,*)'Coeffs for the sponge layer'
+        write(lunout,*)'Z (km)         tau             cst'
+        do l=llm,l0,-1
+          ! double time scale with every level, starting from the top
+          cst(l)=1.-exp(-dt/(tetasponge*2**(llm-l)))
+        enddo
+
+        do l=l0,llm
+           zkm=-scaleheight*log(sig_s(l))
+           print*,zkm,tetasponge*2**(llm-l),cst(l)
+        enddo
+        PRINT*
+
+        firstcall=.false.
+!$OMP END MASTER
+!$OMP BARRIER
+      endif ! of if (firstcall)
+
+!-----------------------------------------------------------------------
+!   compute sponge relaxation:
+!   -------------------------
+      jjb=jj_begin
+      jje=jj_end+1 ! +1 because vcov(j) computations require pext(j+1) & ptot(j+1)
+      IF (pole_sud)  jje=jj_end-1+1
+!$OMP MASTER
+      pext(1:iip1,jjb:jje)=ps(1:iip1,jjb:jje)*aire(1:iip1,jjb:jje)
+      do j=jjb,jje
+         ptot(j)=sum(pext(1:iim,j))
+      enddo
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+!   potential temperature
+      jjb=jj_begin
+      jje=jj_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+      do l=l0,llm
+         do j=jjb,jje
+            ! compute zonal average
+            hm=0.
+            do i=1,iim
+               hm=hm+h(i,j,l)*pext(i,j)
+            enddo
+            hm=hm/ptot(j)
+            ! update h()
+            do i=1,iim
+               h(i,j,l)=h(i,j,l)-cst(l)*(h(i,j,l)-hm)
+            enddo
+            h(iip1,j,l)=h(1,j,l)
+         enddo
+      enddo
+!$OMP END DO NOWAIT
+
+!   zonal wind
+      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=l0,llm
+         do j=jjb,jje
+            um=0.
+            if(mode.ge.1) then ! compute zonal average
+               do i=1,iim
+                  um=um+0.5*ucov(i,j,l)*(pext(i,j)+pext(i+1,j))/cu(i,j)
+               enddo
+               um=um/ptot(j)
+            endif
+            ! update ucov()
+            do i=1,iim
+               ucov(i,j,l)=ucov(i,j,l)-cst(l)*(ucov(i,j,l)-um*cu(i,j))
+            enddo
+            ucov(iip1,j,l)=ucov(1,j,l)
+         enddo
+      enddo
+!$OMP END DO NOWAIT
+
+!  meridional wind
+      jjb=jj_begin
+      jje=jj_end
+      IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+      do l=l0,llm
+         do j=jjb,jje
+            vm=0.
+            if(mode.ge.2) then ! compute zonal average
+               do i=1,iim
+                  vm=vm+vcov(i,j,l)*(pext(i,j)+pext(i,j+1))/cv(i,j)
+               enddo
+               vm=vm/(ptot(j)+ptot(j+1))
+            endif
+            ! update vcov
+            do i=1,iim
+               vcov(i,j,l)=vcov(i,j,l)-cst(l)*(vcov(i,j,l)-vm*cv(i,j))
+            enddo
+            vcov(iip1,j,l)=vcov(1,j,l)
+         enddo
+      enddo
+!$OMP END DO
+
+      end subroutine sponge_p
+      
+end module sponge_mod_p
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/sw_case_williamson91_6.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/sw_case_williamson91_6.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/sw_case_williamson91_6.F	(revision 222)
@@ -0,0 +1,140 @@
+!
+! $Id $
+!
+      SUBROUTINE sw_case_williamson91_6(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=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+c   Arguments:
+c   ----------
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+
+c   Local:
+c   ------
+
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+
+      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)
+ 
+      IF(0==0) THEN
+c Williamson et al. (1991) : onde de Rossby-Haurwitz
+         teta = 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(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(ij,1) = (Ath + Bth*cos(R0*lon))
+            enddo
+         enddo
+         write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
+         ucov(:,1)=ucov(:,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(ij,1) = Ath*sin(R0*lon)
+            enddo
+         enddo
+         write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
+         vcov(:,1)=vcov(:,1)*cv
+         
+c         ucov=0
+c         vcov=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(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2) )
+            enddo
+         enddo
+         
+c     rho = preff/(cpp*teta)
+         teta = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
+         ucov=0.
+         vcov=0.
+      END IF      
+      
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL massdair(p,masse)
+
+      END
+c-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/times.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/times.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/times.F90	(revision 222)
@@ -0,0 +1,248 @@
+module times
+  integer,private,save :: Last_Count=0
+  real, private,save :: Last_cpuCount=0
+  logical, private,save :: AllTimer_IsActive=.false.
+  
+  integer, parameter :: nb_timer = 4
+  integer, parameter :: timer_caldyn  = 1
+  integer, parameter :: timer_vanleer = 2
+  integer, parameter :: timer_dissip = 3
+  integer, parameter :: timer_physic = 4
+  integer, parameter :: stopped = 1
+  integer, parameter :: running = 2
+  integer, parameter :: suspended = 3 
+  
+  integer :: max_size
+  real,    allocatable, dimension(:,:,:) :: timer_table
+  real,    allocatable, dimension(:,:,:) :: timer_table_sqr 
+  integer, allocatable, dimension(:,:,:) :: timer_iteration
+  real,    allocatable, dimension(:,:,:) :: timer_average
+  real,    allocatable, dimension(:,:,:) :: timer_delta
+  real,    allocatable,dimension(:) :: timer_running, last_time
+  integer, allocatable,dimension(:) :: timer_state
+  
+  contains
+  
+  subroutine init_timer
+    use parallel_lmdz
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"
+    
+    max_size=jjm+1
+    allocate(timer_table(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_average(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_delta(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_running(nb_timer))
+    allocate(timer_state(nb_timer))
+    allocate(last_time(nb_timer))
+    
+    timer_table(:,:,:)=0
+    timer_table_sqr(:,:,:)=0
+    timer_iteration(:,:,:)=0
+    timer_average(:,:,:)=0
+    timer_delta(:,:,:)=0
+    timer_state(:)=stopped      
+  end subroutine init_timer
+  
+  subroutine start_timer(no_timer)
+    implicit none
+    integer :: no_timer
+    
+    if (AllTimer_IsActive) then
+    
+      if (timer_state(no_timer)/=stopped) then
+        stop 'start_timer :: timer is already running or suspended'
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      timer_running(no_timer)=0
+      call cpu_time(last_time(no_timer))
+    
+    endif
+    
+  end subroutine start_timer
+  
+  subroutine suspend_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=running) then
+        stop 'suspend_timer :: timer is not running'
+      else
+        timer_state(no_timer)=suspended
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    endif
+  end subroutine suspend_timer
+  
+  subroutine resume_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=suspended) then
+        stop 'resume_timer :: timer is not suspended'
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      call cpu_time(last_time(no_timer))
+    endif
+    
+  end subroutine resume_timer
+
+  subroutine stop_timer(no_timer)
+    use parallel_lmdz
+    implicit none
+    integer :: no_timer
+    integer :: N
+    real :: V,V2
+    
+    if (AllTimer_IsActive) then
+       
+      if (timer_state(no_timer)/=running) then
+        stop 'stop_timer :: timer is not running'
+      else
+        timer_state(no_timer)=stopped
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    
+      timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)
+      timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2
+      timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1
+      timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank)
+      if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then
+        N=timer_iteration(jj_nb,no_timer,mpi_rank)
+	V2=timer_table_sqr(jj_nb,no_timer,mpi_rank)
+	V=timer_table(jj_nb,no_timer,mpi_rank)
+	timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) 
+      else
+        timer_delta(jj_nb,no_timer,mpi_rank)=0
+      endif
+    endif
+    
+  end subroutine stop_timer
+   
+  subroutine allgather_timer
+    use parallel_lmdz
+    implicit none
+#ifdef CPP_MPI    
+    include 'mpif.h'
+#endif
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:) :: tmp_table
+
+    IF (using_mpi) THEN    
+   
+      if (AllTimer_IsActive) then
+    
+    
+      allocate(tmp_table(max_size,nb_timer))
+    
+      data_size=max_size*nb_timer
+    
+      tmp_table(:,:)=timer_table(:,:,mpi_rank)
+#ifdef CPP_MPI 
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif
+      tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif    
+      deallocate(tmp_table)
+    
+      endif
+      
+    ENDIF ! using_mpi
+    
+  end subroutine allgather_timer
+  
+  subroutine allgather_timer_average
+    use parallel_lmdz
+    implicit none
+#ifdef CPP_MPI
+    include 'mpif.h'
+#endif
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:),target :: tmp_table
+    integer, allocatable,dimension(:,:),target :: tmp_iter
+    integer :: istats
+
+    IF (using_mpi) THEN
+        
+      if (AllTimer_IsActive) then
+    
+      allocate(tmp_table(max_size,nb_timer))
+      allocate(tmp_iter(max_size,nb_timer))
+   
+      data_size=max_size*nb_timer
+
+      tmp_table(:,:)=timer_average(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif
+      tmp_table(:,:)=timer_delta(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+#endif
+      tmp_iter(:,:)=timer_iteration(:,:,mpi_rank)
+#ifdef CPP_MPI
+      call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr)
+#endif    
+      deallocate(tmp_table)
+    
+      endif
+      
+    ENDIF  ! using_mpï¿œ
+  end subroutine allgather_timer_average
+  
+  subroutine InitTime
+  implicit none
+    integer :: count,count_rate,count_max
+    
+    AllTimer_IsActive=.TRUE.
+    if (AllTimer_IsActive) then
+      call system_clock(count,count_rate,count_max)
+      call cpu_time(Last_cpuCount)
+      Last_Count=count
+    endif
+  end subroutine InitTime
+  
+  function DiffTime()
+  implicit none
+    double precision :: DiffTime
+    integer :: count,count_rate,count_max
+  
+    call system_clock(count,count_rate,count_max)
+    if (Count>=Last_Count) then
+      DiffTime=(1.*(Count-last_Count))/count_rate
+    else
+      DiffTime=(1.*(Count-last_Count+Count_max))/count_rate
+    endif
+    Last_Count=Count 
+  end function DiffTime
+  
+  function DiffCpuTime()
+  implicit none
+    real :: DiffCpuTime
+    real :: Count
+    
+    call cpu_time(Count)
+    DiffCpuTime=Count-Last_cpuCount
+    Last_cpuCount=Count 
+  end function DiffCpuTime
+
+end module times
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/top_bound_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/top_bound_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/top_bound_p.F	(revision 222)
@@ -0,0 +1,249 @@
+!
+! $Id: top_bound_p.F 1793 2013-07-18 07:13:18Z emillour $
+!
+      SUBROUTINE top_bound_p(vcov,ucov,teta,masse,dt,ducov)
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+
+c ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
+C     F. LOTT DEC. 2006
+c                                 (  10/12/06  )
+
+c=======================================================================
+c
+c   Auteur:  F. LOTT  
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation linéaire (ex top_bound de la physique)
+c
+c=======================================================================
+
+! top_bound sponge layer model:
+! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*dt)
+! 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.h)
+!    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,jjp1,llm) ! covariant zonal wind
+      real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind
+      real,intent(inout) :: teta(iip1,jjp1,llm) ! potential temperature
+      real,intent(in) :: masse(iip1,jjp1,llm) ! mass of atmosphere 
+      real,intent(in) :: dt ! time step (s) of sponge model
+      real,intent(out) :: ducov(iip1,jjp1,llm) ! increment on ucov due to sponge
+
+c   Local:
+c   ------
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm
+      REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm)
+      
+      integer i	
+      REAL,SAVE :: rdamp(llm) ! quenching coefficient
+      real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
+      LOGICAL,SAVE :: first=.true.
+      INTEGER j,l,jjb,jje
+
+
+      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_p(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
+            ducov(i,j,l)=-rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+            ucov(i,j,l)=ucov(i,j,l)
+     &                  +ducov(i,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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/tourpot_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/tourpot_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/tourpot_p.F	(revision 222)
@@ -0,0 +1,93 @@
+      SUBROUTINE tourpot_p ( vcov, ucov, massebxy, vorpot )
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ip1jm,llm )
+      REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm )
+      REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm )
+
+      INTEGER l, ij ,ije,ijb,jje,jjb
+
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      
+      if (pole_nord) ijb=ij_begin
+      
+      
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+
+      if (pole_sud)  ije=ij_end-iip1-1
+      DO 2 ij = ijb, ije 
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      if (pole_sud)  ije=ij_end-iip1
+     
+      DO 3 ij = ijb+iip1-1, ije, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+      jjb=jj_begin-1
+      jje=jj_end
+      
+      if (pole_nord) jjb=jjb+1
+      if (pole_sud)  jje=jje-1
+      CALL  filtreg_p( rot, jjb,jje,jjm, llm, 2, 1, .FALSE., 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO 10 l = 1, llm
+      
+      if (pole_sud)  ije=ij_end-iip1-1  
+      
+      DO 6 ij = ijb, ije
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      if (pole_sud)  ije=ij_end-iip1
+      DO 8 ij = ijb+iip1-1, ije, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vitvert_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vitvert_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vitvert_p.F	(revision 222)
@@ -0,0 +1,56 @@
+      SUBROUTINE vitvert_p ( convm , w )
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ip1jmp1,llm),convm(ip1jmp1,llm)
+      INTEGER   l, ij,ijb,ije
+
+
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_sud) ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = ijb,ije
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+c$OMP END DO
+c$OMP MASTER
+      DO 5 ij  = ijb,ije
+      w(ij,1)  = 0.
+5     CONTINUE
+c$OMP END MASTER
+c$OMP BARRIER
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlsplt_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlsplt_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlsplt_p.F	(revision 222)
@@ -0,0 +1,1138 @@
+      SUBROUTINE vlsplt_p(q,pente_max,masse,w,pbaru,pbarv,pdt)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pente_max facteur de limitation des pentes: 2 en general
+c                                               0 pour un schema amont
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      USE mod_hallo
+      USE Vampir
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+c      REAL masse(iip1,jjp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+c      REAL q(iip1,jjp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      INTEGER ijlqmin,iqmin,jqmin,lqmin
+c
+      REAL zm(ip1jmp1,llm),newmasse
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm),zz
+      REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
+      REAL second,temps0,temps1,temps2,temps3
+      REAL ztemps1,ztemps2,ztemps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+      INTEGER iminn,imaxx
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+      INTEGER ijb,ije
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+      call SetTag(MyRequest1,100)
+      call SetTag(MyRequest2,101)
+      
+      zzpbar = 0.5 * pdt
+      zzw    = pdt
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+      
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+        ENDDO
+      ENDDO
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO l=1,llm
+        DO ij=ijb,ije
+           mv(ij,l)=pbarv(ij,l) * zzpbar
+        ENDDO
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,llm
+        DO ij=ijb,ije
+           mw(ij,l)=w(ij,l) * zzw
+        ENDDO
+      ENDDO
+
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+      
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+       
+       ijb=ij_begin
+       ije=ij_end
+       zq(ijb:ije,:)=q(ijb:ije,:)
+       zm(ijb:ije,:)=masse(ijb:ije,:)
+      
+      
+c	print*,'Entree vlx1'
+c	call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_begin+2*iip1-1)
+      call vlx_p(zq,pente_max,zm,mu,ij_end-2*iip1+1,ij_end)
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1)
+      call SendRequest(MyRequest1)
+      call VTe(VTHallo)
+      call vlx_p(zq,pente_max,zm,mu,ij_begin+2*iip1,ij_end-2*iip1)
+c      call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end)
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest1)
+      call VTe(VTHallo)
+
+      
+c	print*,'Sortie vlx1'
+c	call minmaxq(zq,qmin,qmax,'apres vlx1    ')
+
+c	 print*,'Entree vly1'
+c      call exchange_hallo(zq,ip1jmp1,llm,2,2)
+c      call exchange_hallo(zm,ip1jmp1,llm,1,1)
+      
+      call vly_p(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly1     ')
+c	print*,'Sortie vly1'
+      call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1)
+      call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end)
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2)
+      call SendRequest(MyRequest2)
+      call VTe(VTHallo)
+      call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1)
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest2)
+            
+      call VTe(VTHallo)
+      
+c	call minmaxq(zq,qmin,qmax,'apres vlz     ')
+
+
+      
+      
+      call vly_p(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly     ')
+
+
+      call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end)
+c	call minmaxq(zq,qmin,qmax,'apres vlx2    ')
+
+	
+      ijb=ij_begin
+      ije=ij_end
+       
+      DO l=1,llm
+         DO ij=ijb,ije
+           q(ij,l)=zq(ij,l)
+         ENDDO
+      ENDDO
+      
+      
+      DO l=1,llm
+         DO ij=ijb,ije-iip1+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      call WaitSendRequest(MyRequest1) 
+      call WaitSendRequest(MyRequest2)
+     
+      RETURN
+      END
+      
+      
+      SUBROUTINE vlx_p(q,pente_max,masse,u_m,ijb_x,ije_x)
+
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE Parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical extremum
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      REAL z1,z2,z3
+
+      INTEGER ijb,ije,ijb_x,ije_x
+      
+c   calcul de la pente a droite et a gauche de la maille
+
+      ijb=ijb_x
+      ije=ije_x
+        
+      if (pole_nord.and.ijb==1) ijb=ijb+iip1
+      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+         
+      IF (pente_max.gt.-1.e-5) THEN
+c       IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
+         DO l = 1, llm
+            
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=ijb,ije
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=ijb+1,ije
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=ijb+1,ije
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+c$OMP END DO NOWAIT
+c	print*,'Ok calcul des pentes'
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=ijb+1,ije
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+iip1-1,ije,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+         DO ij=ijb,ije
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+c$OMP END DO NOWAIT
+c	 print*,'Bouclage en iip1'
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+c	print*,'Cumule ....'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+c	print*,'masse(',ij,')=',masse(ij,l)
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
+          ENDIF
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+c	stop
+
+c	go to 9999
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c	print*,'Ok test 1'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb+iip1-1,ije,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c	 print*,'Ok test 2'
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         nl(l)=0
+         DO ij=ijb,ije
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+c$OMP END DO NOWAIT
+cym      IF(n0.gt.1) THEN
+cym      IF(n0.gt.0) THEN
+
+c      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+c     &       ,'contenu de la maille : ',n0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+c$OMP END DO NOWAIT
+cym      ENDIF  ! n0.gt.0 
+9999    continue
+
+
+c   bouclage en latitude
+c	print*,'Avant bouclage en latitude'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        DO ij=ijb+iip1-1,ije,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   calcul des tENDances
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+1,ije
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         ENDDO
+c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         DO ij=ijb+iip1-1,ije,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+
+
+      RETURN
+      END
+
+
+      SUBROUTINE vly_p(q,pente_max,masse,masse_adv_v)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical extremum,first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+      SAVE first,testcpu
+c$OMP THREADPRIVATE(first,testcpu)
+
+      REAL convpn,convps,convmpn,convmps
+      real massepn,masseps,qpn,qps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+      SAVE airej2,airejjm
+c$OMP THREADPRIVATE(airej2,airejjm)
+c
+c
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+      INTEGER ijb,ije
+
+      IF(first) THEN
+c         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+c	PRINT*,'CALCUL EN LATITUDE'
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+      
+      if (pole_nord) then
+        DO i = 1, iim
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+        ENDDO
+        qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      endif
+      
+      if (pole_sud) then
+        DO i = 1, iim
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+        ENDDO
+        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+      endif
+      
+      
+
+c   calcul des pentes aux points v
+
+      ijb=ij_begin-2*iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+      IF (pole_nord) THEN
+        DO ij=1,iip1
+           dyq(ij,l)=qpns-q(ij+iip1,l)
+        ENDDO
+        
+        dyn1=0.
+        dyn2=0.
+        DO ij=1,iim
+          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+        ENDDO
+        DO ij=1,iip1
+          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+        ENDDO
+        
+        DO ij=1,iip1
+         dyq(ij,l)=0.
+        ENDDO
+c ym tout cela ne sert pas a grand chose
+      ENDIF
+      
+      IF (pole_sud) THEN
+
+        DO ij=1,iip1
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+        ENDDO
+
+        dys1=0.
+        dys2=0.
+
+        DO ij=1,iim
+          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+        ENDDO
+
+        DO ij=1,iip1
+          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+        ENDDO
+        
+        DO ij=1,iip1
+         dyq(ip1jm+ij,l)=0.
+        ENDDO
+c ym tout cela ne sert pas a grand chose
+      ENDIF
+
+c   filtrage de la derivee
+
+c   calcul des pentes limites aux poles
+c ym partie inutile
+c      goto 8888
+c      fn=1.
+c      fs=1.
+c      DO ij=1,iim
+c         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+c            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+c         ENDIF
+c      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+c         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+c         ENDIF
+c      ENDDO
+c      DO ij=1,iip1
+c         dyq(ij,l)=fn*dyq(ij,l)
+c         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+c      ENDDO
+c 8888    continue
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     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)=q(ij+iip1,l)+dyq(ij+iip1,l)*
+     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
+          ELSE
+              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+          ENDIF
+          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+         DO ij=ijb,ije
+            newmasse=masse(ij,l)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+     
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+         if (pole_nord) then
+           convpn=SSUM(iim,qbyv(1,l),1)
+           convmpn=ssum(iim,masse_adv_v(1,l),1)
+           massepn=ssum(iim,masse(1,l),1)
+           qpn=0.
+           do ij=1,iim
+              qpn=qpn+masse(ij,l)*q(ij,l)
+           enddo
+           qpn=(qpn+convpn)/(massepn+convmpn)
+           do ij=1,iip1
+              q(ij,l)=qpn
+           enddo
+         endif
+         
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+         
+         if (pole_sud) then
+         
+           convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+           convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+           masseps=ssum(iim, masse(ip1jm+1,l),1)
+           qps=0.
+           do ij = ip1jm+1,ip1jmp1-1
+              qps=qps+masse(ij,l)*q(ij,l)
+           enddo
+           qps=(qps+convps)/(masseps+convmps)
+           do ij=ip1jm+1,ip1jmp1
+              q(ij,l)=qps
+           enddo
+         endif
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
+      
+      
+      
+      SUBROUTINE vlz_p(q,pente_max,masse,w,ijb_x,ije_x)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE Parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL,SAVE :: wq(ip1jmp1,llm+1)
+      REAL newmasse
+
+      REAL,SAVE :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm)
+      REAL dzqmax
+      REAL sigw
+
+      LOGICAL testcpu
+      SAVE testcpu
+c$OMP THREADPRIVATE(testcpu)
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      DATA testcpu/.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+      INTEGER ijb,ije,ijb_x,ije_x
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps0=second(0.)
+      ENDIF
+#endif
+
+      ijb=ijb_x
+      ije=ije_x
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=2,llm
+         DO ij=ijb,ije
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         ENDDO
+      ENDDO
+c$OMP END DO
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=2,llm-1
+         DO ij=ijb,ije
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            ELSE
+                dzq(ij,l)=0.
+            ENDIF
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+      DO ij=ijb,ije
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps1=temps1+second(0.)-temps0
+      ENDIF
+#endif
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l = 1,llm-1
+         do  ij = ijb,ije
+          IF(w(ij,l+1).gt.0.) THEN
+             sigw=w(ij,l+1)/masse(ij,l+1)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
+          ELSE
+             sigw=w(ij,l+1)/masse(ij,l)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+          ENDIF
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+       DO ij=ijb,ije
+          wq(ij,llm+1)=0.
+          wq(ij,1)=0.
+       ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije
+            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+      RETURN
+      END
+c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
+c
+c#include "dimensions.h"
+c#include "paramet.h"
+
+c      CHARACTER*(*) comment
+c      real qmin,qmax
+c      real zq(ip1jmp1,llm)
+
+c      INTEGER jadrs(ip1jmp1), jbad, k, i
+
+
+c      DO k = 1, llm
+c         jbad = 0
+c         DO i = 1, ip1jmp1
+c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+c            jbad = jbad + 1
+c            jadrs(jbad) = i
+c         ENDIF
+c         ENDDO
+c         IF (jbad.GT.0) THEN
+c         PRINT*, comment
+c         DO i = 1, jbad
+cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
+c         ENDDO
+c         ENDIF
+c      ENDDO
+
+c      return
+c      end
+
+
+      subroutine minmaxq_p(zq,qmin,qmax,comment)
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      character*20 comment
+      real qmin,qmax
+      real zq(ip1jmp1,llm)
+      real zzq(iip1,jjp1,llm)
+
+      integer imin,jmin,lmin,ijlmin
+      integer imax,jmax,lmax,ijlmax
+
+      integer ismin,ismax
+
+#ifdef isminismax
+      call scopy (ip1jmp1*llm,zq,1,zzq,1)
+
+      ijlmin=ismin(ijp1llm,zq,1)
+      lmin=(ijlmin-1)/ip1jmp1+1
+      ijlmin=ijlmin-(lmin-1.)*ip1jmp1
+      jmin=(ijlmin-1)/iip1+1
+      imin=ijlmin-(jmin-1.)*iip1
+      zqmin=zq(ijlmin,lmin)
+
+      ijlmax=ismax(ijp1llm,zq,1)
+      lmax=(ijlmax-1)/ip1jmp1+1
+      ijlmax=ijlmax-(lmax-1.)*ip1jmp1
+      jmax=(ijlmax-1)/iip1+1
+      imax=ijlmax-(jmax-1.)*iip1
+      zqmax=zq(ijlmax,lmax)
+
+       if(zqmin.lt.qmin) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
+       if(zqmax.gt.qmax) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
+#endif
+      return
+9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
+      end
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlspltgen_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlspltgen_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlspltgen_p.F	(revision 222)
@@ -0,0 +1,497 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltgen_p( q,iadv,pente_max,masse,w,pbaru,pbarv,pdt,
+     ,                                  p,pk,teta                 )
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
+c
+c    ********************************************************************
+c          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      USE mod_hallo
+      USE Write_Field_p
+      USE VAMPIR
+      USE infotrac, ONLY : nqtot
+      IMPLICIT NONE
+
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      INTEGER iadv(nqtot)
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm,nqtot)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      REAL,SAVE :: qsat(ip1jmp1,llm)
+      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: zm
+      REAL,SAVE :: mu(ip1jmp1,llm)
+      REAL,SAVE :: mv(ip1jm,llm)
+      REAL,SAVE :: mw(ip1jmp1,llm+1)
+      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: zq
+      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(ip1jmp1)
+      INTEGER ijb,ije,iq
+      LOGICAL, SAVE :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c Allocate variables depending on dynamic variable nqtot
+
+         IF (firstcall) THEN
+            firstcall=.FALSE.
+!$OMP MASTER
+            ALLOCATE(zm(ip1jmp1,llm,nqtot))
+            ALLOCATE(zq(ip1jmp1,llm,nqtot))
+!$OMP END MASTER
+!$OMP BARRIER
+         END IF
+c-- Calcul de Qsat en chaque point
+c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+c   pour eviter une exponentielle.
+
+      call SetTag(MyRequest1,100)
+      call SetTag(MyRequest2,101)
+
+        
+	ijb=ij_begin-iip1
+	ije=ij_end+iip1
+	if (pole_nord) ijb=ij_begin
+	if (pole_sud) ije=ij_end
+	
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+	DO l = 1, llm
+         DO ij = ijb, ije
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = ijb, ije
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+         DO ij=ijb,ije
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+c$OMP END MASTER
+
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+       ijb=ij_begin
+       ije=ij_end
+
+      DO iq=1,nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+        DO l=1,llm
+          zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
+          zm(ijb:ije,l,iq)=masse(ijb:ije,l)
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+
+
+c$OMP BARRIER           
+      DO iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+
+#ifdef _ADV_HALO        
+	  call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &	             ij_begin,ij_begin+2*iip1-1)
+          call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &               ij_end-2*iip1+1,ij_end)
+#else
+	  call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &	             ij_begin,ij_end)
+#endif
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+          call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1)
+          call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1)
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER
+	else if (iadv(iq)==14) then
+
+#ifdef _ADV_HALO           
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_begin,ij_begin+2*iip1-1)
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_end-2*iip1+1,ij_end)
+#else
+
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_begin,ij_end)
+#endif
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+
+          call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1)
+          call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1)
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+      
+      
+c$OMP BARRIER      
+c$OMP MASTER      
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call SendRequest(MyRequest1)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER       
+c$OMP BARRIER
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+
+#ifdef _ADV_HALLO
+          call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &               ij_begin+2*iip1,ij_end-2*iip1)
+#endif        
+	else if (iadv(iq)==14) then
+#ifdef _ADV_HALLO
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_begin+2*iip1,ij_end-2*iip1)
+#endif    
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+c$OMP BARRIER      
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+!      call WaitRecvRequest(MyRequest1)
+!      call WaitSendRequest(MyRequest1)
+c$OMP BARRIER
+       call WaitRequest(MyRequest1)
+
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+ 
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+
+c$OMP BARRIER        
+#ifdef _ADV_HALLO
+          call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw,
+     &               ij_begin,ij_begin+2*iip1-1)
+          call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw,
+     &               ij_end-2*iip1+1,ij_end)
+#else
+          call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw,
+     &               ij_begin,ij_end)
+#endif
+c$OMP BARRIER
+
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+
+          call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest2)
+          call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest2)
+
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER	
+c$OMP BARRIER
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+c$OMP BARRIER      
+
+c$OMP MASTER        
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+      call SendRequest(MyRequest2)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER	
+
+c$OMP BARRIER
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+c$OMP BARRIER        
+
+#ifdef _ADV_HALLO
+          call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw,
+     &               ij_begin+2*iip1,ij_end-2*iip1)
+#endif
+
+c$OMP BARRIER        
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+
+c$OMP BARRIER
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+
+!      call WaitRecvRequest(MyRequest2)
+!      call WaitSendRequest(MyRequest2)
+c$OMP BARRIER
+       CALL WaitRequest(MyRequest2)
+
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+
+
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+      do iq=1,nqtot
+
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &               ij_begin,ij_end)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_begin,ij_end)
+ 
+        else
+	
+          stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+     
+      ijb=ij_begin
+      ije=ij_end
+c$OMP BARRIER      
+
+
+      DO iq=1,nqtot
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+        DO l=1,llm
+           DO ij=ijb,ije
+c             print *,'zq-->',ij,l,iq,zq(ij,l,iq)
+c	     print *,'q-->',ij,l,iq,q(ij,l,iq)
+	     q(ij,l,iq)=zq(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT          
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           DO ij=ijb,ije-iip1+1,iip1
+              q(ij+iim,l,iq)=q(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT  
+
+      ENDDO
+        
+      
+c$OMP BARRIER
+
+cc$OMP MASTER      
+c      call WaitSendRequest(MyRequest1) 
+c      call WaitSendRequest(MyRequest2)
+cc$OMP END MASTER
+cc$OMP BARRIER
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlspltqs_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlspltqs_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/vlspltqs_p.F	(revision 222)
@@ -0,0 +1,949 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltqs_p ( 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          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      USE mod_hallo
+      USE VAMPIR
+      use cpdet_mod, only: tpot2t_glo_p
+      IMPLICIT NONE
+
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL qsat(ip1jmp1,llm)
+      REAL zm(ip1jmp1,llm)
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm)
+      REAL temps1,temps2,temps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+!      REAL tempe(ip1jmp1)
+! ADAPTATION GCM POUR CP(T)
+      REAL tempe(ip1jmp1,llm)
+
+      INTEGER ijb,ije
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c-- 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.
+
+! ADAPTATION GCM POUR CP(T)
+! probablement a revoir...
+!      call tpot2t_p(ip1jmp1,llm,teta,tempe,pk)
+      call tpot2t_glo_p(teta,tempe,pk)
+
+      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
+	
+	
+	DO l = 1, llm
+!         DO ij = ijb, ije
+!          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+!         ENDDO
+         DO ij = ijb, ije
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij,l)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij,l),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+
+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
+
+      
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+
+      DO l=1,llm
+         DO ij=ijb,ije
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,llm
+         DO ij=ijb,ije
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+       ijb=ij_begin
+       ije=ij_end
+       zq(ijb:ije,1:llm)=q(ijb:ije,1:llm)
+       zm(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
+
+
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_begin+2*iip1-1)
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_end-2*iip1+1,ij_end)
+ 
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1)
+      call SendRequest(MyRequest1)
+      call VTe(VTHallo)
+
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,
+     .             ij_begin+2*iip1,ij_end-2*iip1)
+
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest1)
+      call VTe(VTHallo)
+
+      call vlyqs_p(zq,pente_max,zm,mv,qsat)
+
+      call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1)
+      call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end)
+
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2)
+      call SendRequest(MyRequest2)
+      call VTe(VTHallo)
+
+      call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1)
+
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest2)
+      call VTe(VTHallo)
+      
+      call vlyqs_p(zq,pente_max,zm,mv,qsat)
+
+
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_end)
+
+
+      ijb=ij_begin
+      ije=ij_end
+
+      DO l=1,llm
+         DO ij=ijb,ije
+           q(ij,l)=zq(ij,l)
+         ENDDO
+      ENDDO
+      
+      DO l=1,llm
+         DO ij=ijb,ije-iip1+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      call WaitSendRequest(MyRequest1) 
+      call WaitSendRequest(MyRequest2)
+
+      RETURN
+      END
+      SUBROUTINE vlxqs_p(q,pente_max,masse,u_m,qsat,ijb_x,ije_x)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm )
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      REAL      SSUM
+
+
+      INTEGER ijb,ije,ijb_x,ije_x
+      
+
+c   calcul de la pente a droite et a gauche de la maille
+
+c      ijb=ij_begin
+c      ije=ij_end
+
+      ijb=ijb_x
+      ije=ije_x
+        
+      if (pole_nord.and.ijb==1) ijb=ijb+iip1
+      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+      
+      IF (pente_max.gt.-1.e-5) THEN
+c     IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=ijb,ije
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=ijb+1,ije
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=ijb+1,ije
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+c$OMP END DO NOWAIT
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=ijb+1,ije
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+iip1-1,ije,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+
+         DO ij=ijb,ije
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      if (pole_nord) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm      
+          iadvplus(1:iip1,l)=0
+        ENDDO
+c$OMP END DO NOWAIT
+      endif
+      
+      if (pole_sud)  THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm 
+	  iadvplus(ip1jm+1:ip1jmp1,l)=0
+        ENDDO
+c$OMP END DO NOWAIT
+      endif
+      	
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c--pas encore modification sur Qsat
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+c   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+          ENDIF
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+
+
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb+iip1-1,ije,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c   pas d'influence de la pression saturante (pour l'instant)
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         nl(l)=0
+         DO ij=ijb,ije
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+cym ATTENTION ICI en OpenMP reduction pas forcement nécessaire
+cym      IF(n0.gt.1) THEN
+cym        IF(n0.gt.0) THEN
+ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+ccc     &       ,'contenu de la maille : ',n0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+c$OMP END DO NOWAIT
+cym      ENDIF  ! n0.gt.0 
+
+
+
+c   bouclage en latitude
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        DO ij=ijb+iip1-1,ije,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   calcul des tendances
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+1,ije
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         ENDDO
+c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         DO ij=ijb+iip1-1,ije,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+
+
+      RETURN
+      END
+      SUBROUTINE vlyqs_p(q,pente_max,masse,masse_adv_v,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     qsat 	       est   un argument de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical first
+      SAVE first
+c$OMP THREADPRIVATE(first)
+      REAL convpn,convps,convmpn,convmps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+c$OMP THREADPRIVATE(airej2,airejjm)
+c
+c
+      REAL      SSUM
+
+      DATA first/.true./
+      INTEGER ijb,ije
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      if (pole_nord) then
+        DO i = 1, iim
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+        ENDDO
+        qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      endif
+      
+      if (pole_sud) then
+        DO i = 1, iim
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+        ENDDO
+        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+      endif
+
+
+c   calcul des pentes aux points v
+
+      ijb=ij_begin-2*iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+
+c   calcul des pentes aux points scalaires
+
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+      
+      IF (pole_nord) THEN
+
+c   calcul des pentes aux poles
+        DO ij=1,iip1
+           dyq(ij,l)=qpns-q(ij+iip1,l)
+        ENDDO
+
+c   filtrage de la derivee        
+        dyn1=0.
+        dyn2=0.
+        DO ij=1,iim
+          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+        ENDDO
+        DO ij=1,iip1
+          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+        ENDDO
+
+c   calcul des pentes limites aux poles
+        fn=1.
+        DO ij=1,iim
+          IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+          ENDIF
+        ENDDO
+      
+        DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+        ENDDO
+	  
+      ENDIF
+      
+      IF (pole_sud) THEN
+
+        DO ij=1,iip1
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+        ENDDO
+
+        dys1=0.
+        dys2=0.
+
+        DO ij=1,iim
+          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+        ENDDO
+
+        DO ij=1,iip1
+          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+        ENDDO
+        
+c   calcul des pentes limites aux poles	
+        fs=1.
+        DO ij=1,iim
+        IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+        ENDIF
+        ENDDO
+    
+        DO ij=1,iip1
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+        ENDDO
+	
+      ENDIF
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     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)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
+         ELSE
+              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
+         ENDIF
+          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+         DO ij=ijb,ije
+            newmasse=masse(ij,l)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+
+         IF (pole_nord) THEN
+
+           convpn=SSUM(iim,qbyv(1,l),1)/apoln
+           convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+           DO ij = 1,iip1
+              newmasse=masse(ij,l)+convmpn*aire(ij)
+              q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
+     &                 newmasse
+              masse(ij,l)=newmasse
+           ENDDO
+	 
+	 ENDIF
+         
+	 IF (pole_sud) THEN
+	 
+	   convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+           convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+           DO ij = ip1jm+1,ip1jmp1
+              newmasse=masse(ij,l)+convmps*aire(ij)
+              q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
+     &                 newmasse
+              masse(ij,l)=newmasse
+           ENDDO
+	 
+	 ENDIF
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/wrgrads.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/wrgrads.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/wrgrads.F	(revision 222)
@@ -0,0 +1,133 @@
+!
+! $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)
+
+      integer, parameter:: wp = selected_real_kind(p=6, r=36)
+      real(wp) field4(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.
+
+c     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)
+
+c     print*,'im,jm,lm,name,firsttime(if)'
+c     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
+c           print*,'initialisation ecriture de ',var(ivar(if),if)
+c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
+      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   ((field4((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: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/write_field_p.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/write_field_p.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/write_field_p.F90	(revision 222)
@@ -0,0 +1,73 @@
+module write_field_p
+implicit none
+  
+  interface WriteField_p
+    module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p
+  end interface WriteField_p
+  
+  contains
+  
+  subroutine write_field1D_p(name,Field)
+    USE parallel_lmdz
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1)))
+    New_Field(:)=Field(:)
+    call Gather_Field(New_Field,dim(1),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+    end subroutine write_field1D_p
+
+  subroutine write_field2D_p(name,Field)
+    USE parallel_lmdz
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2)))
+    New_Field(:,:)=Field(:,:)
+    call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+     
+  end subroutine write_field2D_p
+  
+  subroutine write_field3D_p(name,Field)
+    USE parallel_lmdz
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2),Dim(3)))
+    New_Field(:,:,:)=Field(:,:,:)
+    call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0)
+    
+   if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+  end subroutine write_field3D_p  
+
+end module write_field_p
+  
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/writedynav_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/writedynav_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/writedynav_p.F	(revision 222)
@@ -0,0 +1,169 @@
+!
+! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine writedynav_p( histid, time, vcov, 
+     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+      USE ioipsl
+#endif
+      USE parallel_lmdz
+      USE misc_mod
+      USE infotrac
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      time: temps de l'ecriture
+C      vcov: vents v covariants
+C      ucov: vents u covariants
+C      teta: temperature potentielle
+C      phi : geopotentiel instantane
+C      q   : traceurs
+C      masse: masse
+C      ps   :pression au sol
+C      phis : geopotentiel au sol
+C      
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm),ppk(ip1jmp1,llm)                  
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL phis(ip1jmp1)                  
+      REAL q(ip1jmp1,llm,nqtot)
+      integer time
+
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
+      real us(ip1jmp1,llm), vs(ip1jmp1,llm)
+      real tm(ip1jmp1,llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) 
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+      
+      ndex3d = 0
+      ndex2d = 0
+      ok_sync = .TRUE.
+      us = 999.999
+      vs = 999.999
+      tm = 999.999
+      vnat = 999.999
+      unat = 999.999
+      itau_w = itau_dyn + time
+
+C Passage aux composantes naturelles du vent
+      call covnat_p(llm, ucov, vcov, unat, vnat)
+
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U scalaire
+C
+      call gr_u_scal_p(llm, unat, us)
+      
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+      
+      call histwrite(histid, 'u', itau_w, us(ijb:ije,:), 
+     .               iip1*jjn*llm, ndex3d)
+C
+C  Vents V scalaire
+C
+      
+      call gr_v_scal_p(llm, vnat, vs)
+      call histwrite(histid, 'v', itau_w, vs(ijb:ije,:), 
+     .               iip1*jjn*llm, ndex3d)
+C
+C  Temperature potentielle moyennee
+C
+     
+      call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Temperature moyennee
+C
+      do ll=1,llm
+        do ii = ijb, ije
+          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+        enddo
+      enddo
+      
+      call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), 
+     .                   iip1*jjn*llm, ndex3d)
+        enddo
+C
+C  Masse
+C
+       call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1),
+     .                iip1*jjn, ndex2d)
+C
+C  Pression au sol
+C
+       call histwrite(histid, 'ps', itau_w, ps(ijb:ije), 
+     .                 iip1*jjn, ndex2d)
+C
+C  Geopotentiel au sol
+C
+       call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+     .                 iip1*jjn, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) call histsync(histid)
+#else
+      write(lunout,*)'writedynav_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/writehist_p.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/writehist_p.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/dyn3dpar/writehist_p.F	(revision 222)
@@ -0,0 +1,156 @@
+!
+! $Id: writehist_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine writehist_p( histid, histvid, time, vcov, 
+     ,                          ucov,teta,phi,q,masse,ps,phis)
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+      USE ioipsl
+#endif
+      USE parallel_lmdz
+      USE misc_mod
+      USE infotrac
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      histvid:ID du fichier histoire pour les vents V (appele a disparaitre)
+C      time: temps de l'ecriture
+C      vcov: vents v covariants
+C      ucov: vents u covariants
+C      teta: temperature potentielle
+C      phi : geopotentiel instantane
+C      q   : traceurs
+C      masse: masse
+C      ps   :pression au sol
+C      phis : geopotentiel au sol
+C      
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "iniprint.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, histvid
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL phis(ip1jmp1)                  
+      REAL q(ip1jmp1,llm,nqtot)
+      integer time
+
+#ifdef CPP_IOIPSL
+! This routine needs IOIPSL
+C   Variables locales
+C
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+     
+    
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
+      ok_sync =.TRUE.
+      itau_w = itau_dyn + time
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+          
+      call histwrite(histid, 'ucov', itau_w, ucov(ijb:ije,:), 
+     .               iip1*jjn*llm, ndexu)
+
+C
+C  Vents V
+C
+      if (pole_sud) ije=ij_end-iip1
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histwrite(histvid, 'vcov', itau_w, vcov(ijb:ije,:), 
+     .               iip1*jjn*llm, ndexv)
+
+C
+C  Temperature potentielle
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+
+      call histwrite(histid, 'teta', itau_w, teta(ijb:ije,:), 
+     .                iip1*jjn*llm, ndexu)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
+     .                iip1*jjn*llm, ndexu)
+C
+C  Traceurs
+C
+        DO iq=1,nqtot
+          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), 
+     .                   iip1*jjn*llm, ndexu)
+        enddo
+C
+C  Masse
+C
+      call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1),
+     .               iip1*jjn, ndex2d)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', itau_w, ps(ijb:ije),
+     .               iip1*jjn, ndex2d)
+C
+C  Geopotentiel au sol
+C
+      call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+     .               iip1*jjn, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+      endif
+#else
+      write(lunout,*)'writehist_p: Needs IOIPSL to function'
+#endif
+! #endif of #ifdef CPP_IOIPSL
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/acc.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/acc.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/acc.F	(revision 222)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!
+        subroutine acc(vec,d,im)
+        dimension vec(im,im),d(im)
+        do j=1,im
+          do i=1,im
+            d(i)=vec(i,j)*vec(i,j)
+          enddo
+          sum=ssum(im,d,1)
+          sum=sqrt(sum)
+          do i=1,im
+            vec(i,j)=vec(i,j)/sum
+          enddo
+        enddo
+        return
+        end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/coefils.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/coefils.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/coefils.h	(revision 222)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+      COMMON/coefils/jfiltnu,jfiltsu,jfiltnv,jfiltsv,sddu(iim),sddv(iim)&
+     & ,unsddu(iim),unsddv(iim),coefilu(iim,jjm),coefilv(iim,jjm),      &
+     & modfrstu(jjm),modfrstv(jjm),eignfnu(iim,iim),eignfnv(iim,iim)    &
+     & ,coefilu2(iim,jjm),coefilv2(iim,jjm)
+!c
+      INTEGER jfiltnu,jfiltsu,jfiltnv,jfiltsv,modfrstu,modfrstv
+      REAL    sddu,sddv,unsddu,unsddv,coefilu,coefilv,eignfnu,eignfnv
+      REAL    coefilu2,coefilv2
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/eigen.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/eigen.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/eigen.F	(revision 222)
@@ -0,0 +1,31 @@
+!
+! $Header$
+!
+      SUBROUTINE eigen( e,d)
+#include "dimensions.h"
+      dimension e( iim,iim ), d( iim )
+      dimension asm( iim )
+      im=iim
+c
+      DO 48 i = 1,im
+	 asm( i ) = d( im-i+1 )
+ 48   CONTINUE
+      DO 49 i = 1,iim
+	 d( i ) = asm( i )
+ 49   CONTINUE
+c
+c     PRINT 70,d
+ 70   FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/)
+		print *
+c
+      DO 51 i = 1,im
+	 DO 52 j = 1,im
+            asm( j ) = e( i , im-j+1 )
+ 52      CONTINUE
+	 DO 50 j = 1,im
+	    e( i,j ) = asm( j )
+ 50      CONTINUE
+ 51   CONTINUE
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/eigen_sort.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/eigen_sort.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/eigen_sort.F	(revision 222)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+          SUBROUTINE eigen_sort(d,v,n,np)
+          INTEGER n,np
+          REAL d(np),v(np,np)
+          INTEGER i,j,k
+          REAL p
+
+       DO i=1,n-1
+          k=i
+          p=d(i)
+        DO j=i+1,n
+           IF(d(j).ge.p) THEN
+            k=j
+            p=d(j)
+           ENDIF
+        ENDDO
+          
+        IF(k.ne.i) THEN
+          d(k)=d(i)
+          d(i)=p
+         DO j=1,n
+          p=v(j,i)
+          v(j,i)=v(j,k)
+          v(j,k)=p
+         ENDDO
+        ENDIF
+       ENDDO
+
+        RETURN
+        END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/filtreg.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/filtreg.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/filtreg.F	(revision 222)
@@ -0,0 +1,319 @@
+!
+! $Header$
+!
+      SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire,
+     &     griscal ,iter)
+      
+      USE filtreg_mod
+      
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur: P. Le Van        07/10/97
+c   ------
+c
+c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+c                     pour l'operateur  Filtre    .
+c   ------
+c
+c   Arguments:
+c   ----------
+c
+c      nblat                 nombre de latitudes a filtrer
+c      nbniv                 nombre de niveaux verticaux a filtrer
+c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+c                            en sortie : champ filtre
+c      ifiltre               +1  Transformee directe
+c                            -1  Transformee inverse
+c                            +2  Filtre directe
+c                            -2  Filtre inverse
+c
+c      iaire                 1   si champ intensif
+c                            2   si champ extensif (pondere par les aires)
+c
+c      iter                  1   filtre simple
+c
+c=======================================================================
+c
+c
+c                      Variable Intensive
+c                ifiltre = 1     filtre directe
+c                ifiltre =-1     filtre inverse
+c
+c                      Variable Extensive
+c                ifiltre = 2     filtre directe
+c                ifiltre =-2     filtre inverse
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "coefils.h"
+
+      INTEGER    nlat,nbniv,ifiltre,iter
+      INTEGER    i,j,l,k
+      INTEGER    iim2,immjm
+      INTEGER    jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+      REAL       champ( iip1,nlat,nbniv)
+
+      REAL       eignq(iim,nlat,nbniv), sdd1(iim),sdd2(iim)
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+
+      LOGICAL,SAVE     :: first=.TRUE.
+
+      REAL, SAVE :: sdd12(iim,4)
+
+      INTEGER, PARAMETER :: type_sddu=1
+      INTEGER, PARAMETER :: type_sddv=2
+      INTEGER, PARAMETER :: type_unsddu=3
+      INTEGER, PARAMETER :: type_unsddv=4
+
+      INTEGER :: sdd1_type, sdd2_type
+
+      IF (first) THEN
+         sdd12(1:iim,type_sddu) = sddu(1:iim)
+         sdd12(1:iim,type_sddv) = sddv(1:iim)
+         sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+         sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+
+         first=.FALSE.
+      ENDIF
+
+      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
+     &     STOP'Pas de transformee simple dans cette version'
+      
+      IF( iter.EQ. 2 )  THEN
+         PRINT *,' Pas d iteration du filtre dans cette version !'
+     &        , ' Utiliser old_filtreg et repasser !'
+         STOP
+      ENDIF
+      
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+         PRINT *,' Cette routine ne calcule le filtre inverse que '
+     &        , ' sur la grille des scalaires !'
+         STOP
+      ENDIF
+      
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+         PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     &        , ' corriger et repasser !'
+         STOP
+      ENDIF
+      
+      iim2   = iim * iim
+      immjm  = iim * jjm
+
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+            PRINT  1111
+            STOP
+         ELSE
+            
+            IF( iaire.EQ.1 )  THEN
+               sdd1_type = type_sddv
+               sdd2_type = type_unsddv
+            ELSE
+               sdd1_type = type_unsddv
+               sdd2_type = type_sddv
+            ENDIF
+
+c            IF( iaire.EQ.1 )  THEN
+c               CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 ) 
+c               CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
+c            ELSE
+c               CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
+c               CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
+c            END IF
+            
+            jdfil1 = 2
+            jffil1 = jfiltnu
+            jdfil2 = jfiltsu
+            jffil2 = jjm
+         END IF
+      ELSE
+         IF( nlat.NE.jjm )  THEN
+            PRINT  2222
+            STOP
+         ELSE
+            
+            IF( iaire.EQ.1 )  THEN
+               sdd1_type = type_sddu
+               sdd2_type = type_unsddu
+            ELSE
+               sdd1_type = type_unsddu
+               sdd2_type = type_sddu
+            ENDIF
+
+c            IF( iaire.EQ.1 )  THEN
+c               CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 ) 
+c               CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
+c            ELSE
+c               CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
+c               CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
+c            END IF
+            
+            jdfil1 = 1
+            jffil1 = jfiltnv
+            jdfil2 = jfiltsv
+            jffil2 = jjm
+         END IF
+      END IF
+      
+      DO hemisph = 1, 2
+         
+         IF ( hemisph.EQ.1 )  THEN
+            jdfil = jdfil1
+            jffil = jffil1
+         ELSE
+            jdfil = jdfil2
+            jffil = jffil2
+         END IF
+         
+         DO l = 1, nbniv
+            DO j = jdfil,jffil
+               DO i = 1, iim
+                  champ(i,j,l) = champ(i,j,l) * sdd12(i,sdd1_type) ! sdd1(i)
+               END DO
+            END DO
+         END DO
+         
+         IF( hemisph. EQ. 1 )      THEN
+            
+            IF( ifiltre. EQ. -2 )   THEN
+               
+               DO j = jdfil,jffil
+#ifdef BLAS
+                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
+     &                 matrinvn(1,1,j),
+     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
+     &                 eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+                  eignq(:,j-jdfil+1,:)
+     $                 = matmul(matrinvn(:,:,j), champ(:iim,j,:))
+#endif
+               END DO
+               
+            ELSE IF ( griscal )     THEN
+               
+               DO j = jdfil,jffil
+#ifdef BLAS
+                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
+     &                 matriceun(1,1,j),
+     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
+     &                 eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+                  eignq(:,j-jdfil+1,:)
+     $                 = matmul(matriceun(:,:,j), champ(:iim,j,:))
+#endif
+               END DO
+               
+            ELSE 
+               
+               DO j = jdfil,jffil
+#ifdef BLAS
+                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
+     &                 matricevn(1,1,j),
+     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
+     &                 eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+                  eignq(:,j-jdfil+1,:)
+     $                 = matmul(matricevn(:,:,j), champ(:iim,j,:))
+#endif
+               END DO
+               
+            ENDIF
+            
+         ELSE
+            
+            IF( ifiltre. EQ. -2 )   THEN
+               
+               DO j = jdfil,jffil
+#ifdef BLAS
+                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
+     &                 matrinvs(1,1,j-jfiltsu+1),
+     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
+     &                 eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+                  eignq(:,j-jdfil+1,:)
+     $                 = matmul(matrinvs(:,:,j-jfiltsu+1),
+     $                 champ(:iim,j,:))
+#endif
+               END DO
+               
+               
+            ELSE IF ( griscal )     THEN
+               
+               DO j = jdfil,jffil
+#ifdef BLAS
+                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
+     &                 matriceus(1,1,j-jfiltsu+1),
+     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
+     &                 eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+                  eignq(:,j-jdfil+1,:)
+     $                 = matmul(matriceus(:,:,j-jfiltsu+1),
+     $                 champ(:iim,j,:))
+#endif
+               END DO
+                              
+            ELSE 
+               
+               DO j = jdfil,jffil
+#ifdef BLAS
+                  CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, 
+     &                 matricevs(1,1,j-jfiltsv+1),
+     &                 iim, champ(1,j,1), iip1*nlat, 0.0,
+     &                 eignq(1,j-jdfil+1,1), iim*nlat)
+#else
+                  eignq(:,j-jdfil+1,:)
+     $                 = matmul(matricevs(:,:,j-jfiltsv+1),
+     $                 champ(:iim,j,:))
+#endif
+               END DO
+                              
+            ENDIF
+            
+         ENDIF
+         
+         IF( ifiltre.EQ. 2 )  THEN
+            
+            DO l = 1, nbniv
+               DO j = jdfil,jffil
+                  DO i = 1, iim
+                     champ( i,j,l ) = 
+     &                    (champ(i,j,l) + eignq(i,j-jdfil+1,l))
+     &                    * sdd12(i,sdd2_type) ! sdd2(i)
+                  END DO
+               END DO
+            END DO
+
+         ELSE
+
+            DO l = 1, nbniv
+               DO j = jdfil,jffil
+                  DO i = 1, iim
+                     champ( i,j,l ) = 
+     &                    (champ(i,j,l) - eignq(i,j-jdfil+1,l))
+     &                    * sdd12(i,sdd2_type) ! sdd2(i)
+                  END DO
+               END DO
+            END DO
+
+         ENDIF
+
+         DO l = 1, nbniv
+            DO j = jdfil,jffil
+               champ( iip1,j,l ) = champ( 1,j,l )
+            END DO
+         END DO
+
+     
+      ENDDO
+
+1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
+     &     filtrer, sur la grille des scalaires'/)
+2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
+     &     ltrer, sur la grille de V ou de Z'/)
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/filtreg_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/filtreg_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/filtreg_mod.F90	(revision 222)
@@ -0,0 +1,559 @@
+!
+! $Id $
+!
+MODULE filtreg_mod
+
+  REAL, DIMENSION(:,:,:), ALLOCATABLE :: matriceun,matriceus,matricevn
+  REAL, DIMENSION(:,:,:), ALLOCATABLE :: matricevs,matrinvn,matrinvs
+
+CONTAINS
+
+  SUBROUTINE inifilr
+#ifdef CPP_PARA
+  USE mod_filtre_fft, ONLY : use_filtre_fft,Init_filtre_fft
+  USE mod_filtre_fft_loc, ONLY : Init_filtre_fft_loc=>Init_filtre_fft    !
+#endif
+    !    ... H. Upadhyaya, O.Sharma   ...
+    !
+    IMPLICIT NONE
+    !
+    !     version 3 .....
+
+    !     Correction  le 28/10/97    P. Le Van .
+    !  -------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+    !  -------------------------------------------------------------------
+#include "comgeom.h"
+#include "coefils.h"
+#include "logic.h"
+#include "serre.h"
+
+    REAL  dlonu(iim),dlatu(jjm)
+    REAL  rlamda( iim ),  eignvl( iim )
+    !
+
+    REAL    lamdamax,pi,cof
+    INTEGER i,j,modemax,imx,k,kf,ii
+    REAL dymin,dxmin,colat0
+    REAL eignft(iim,iim), coff
+
+    LOGICAL, SAVE :: first_call_inifilr = .TRUE.
+
+#ifdef CRAY
+    INTEGER   ISMIN
+    EXTERNAL  ISMIN
+    INTEGER iymin 
+    INTEGER ixmineq
+#endif
+    !
+    ! ------------------------------------------------------------
+    !   This routine computes the eigenfunctions of the laplacien
+    !   on the stretched grid, and the filtering coefficients
+    !      
+    !  We designate:
+    !   eignfn   eigenfunctions of the discrete laplacien
+    !   eigenvl  eigenvalues
+    !   jfiltn   indexof the last scalar line filtered in NH
+    !   jfilts   index of the first line filtered in SH
+    !   modfrst  index of the mode from WHERE modes are filtered
+    !   modemax  maximum number of modes ( im )
+    !   coefil   filtering coefficients ( lamda_max*COS(rlat)/lamda )
+    !   sdd      SQRT( dx )
+    !      
+    !     the modes are filtered from modfrst to modemax
+    !      
+    !-----------------------------------------------------------
+    !
+
+    pi       = 2. * ASIN( 1. )
+
+    DO i = 1,iim
+       dlonu(i) = xprimu( i )
+    ENDDO
+    !
+    CALL inifgn(eignvl)
+    !
+    PRINT *,'inifilr: EIGNVL '
+    PRINT 250,eignvl
+250 FORMAT( 1x,5e14.6)
+    !
+    ! compute eigenvalues and eigenfunctions
+    !
+    !
+    !.................................................................
+    !
+    !  compute the filtering coefficients for scalar lines and 
+    !  meridional wind v-lines
+    !
+    !  we filter all those latitude lines WHERE coefil < 1
+    !  NO FILTERING AT POLES
+    !
+    !  colat0 is to be used  when alpha (stretching coefficient)
+    !  is set equal to zero for the regular grid CASE 
+    !
+    !    .......   Calcul  de  colat0   .........
+    !     .....  colat0 = minimum de ( 0.5, min dy/ min dx )   ...
+    !
+    !
+    DO j = 1,jjm
+       dlatu( j ) = rlatu( j ) - rlatu( j+1 )
+    ENDDO
+    !
+#ifdef CRAY
+    iymin   = ISMIN( jjm, dlatu, 1 )
+    ixmineq = ISMIN( iim, dlonu, 1 )
+    dymin   = dlatu( iymin )
+    dxmin   = dlonu( ixmineq )
+#else
+    dxmin   =  dlonu(1)
+    DO  i  = 2, iim
+       dxmin = MIN( dxmin,dlonu(i) )
+    ENDDO
+    dymin  = dlatu(1)
+    DO j  = 2, jjm
+       dymin = MIN( dymin,dlatu(j) )
+    ENDDO
+#endif
+    !
+    ! For a regular grid, we want the filter to start at latitudes
+    ! corresponding to lengths dx of the same size as dy (in terms
+    ! of angles: dx=2*dy) => at colat0=0.5 (i.e. colatitude=30 degrees
+    !  <=> latitude=60 degrees).
+    ! Same idea for the zoomed grid: start filtering polewards as soon
+    ! as length dx becomes of the same size as dy 
+    !
+    colat0  =  MIN( 0.5, dymin/dxmin )
+    !
+    IF( .NOT.fxyhypb.AND.ysinus )  THEN
+       colat0 = 0.6
+       !         ...... a revoir  pour  ysinus !   .......
+       alphax = 0.
+    ENDIF
+    !
+    PRINT 50, colat0,alphax
+50  FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7)
+    !
+    IF(alphax.EQ.1. )  THEN
+       PRINT *,' Inifilr  alphax doit etre  <  a 1.  Corriger '
+       STOP
+    ENDIF
+    !
+    lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) )
+
+    !                        ... Correction  le 28/10/97  ( P.Le Van ) ..
+    !
+    DO i = 2,iim
+       rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) )
+    ENDDO
+    !
+
+    DO j = 1,jjm
+       DO i = 1,iim
+          coefilu( i,j )  = 0.0
+          coefilv( i,j )  = 0.0
+          coefilu2( i,j ) = 0.0
+          coefilv2( i,j ) = 0.0
+       ENDDO
+    ENDDO
+
+    !
+    !    ... Determination de jfiltnu,jfiltnv,jfiltsu,jfiltsv ....
+    !    .........................................................
+    !
+    modemax = iim
+
+!!!!    imx = modemax - 4 * (modemax/iim)
+
+    imx  = iim
+    !
+    PRINT *,'inifilr: TRUNCATION AT ',imx
+    !
+! Ehouarn: set up some defaults
+    jfiltnu=2 ! avoid north pole
+    jfiltsu=jjm ! avoid south pole (which is at jjm+1)
+    jfiltnv=1 ! NB: no poles on the V grid
+    jfiltsv=jjm
+
+    DO j = 2, jjm/2+1
+       cof = COS( rlatu(j) )/ colat0
+       IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatu(j) ).LT.1. ) THEN
+            jfiltnu= j
+          ENDIF
+       ENDIF
+
+       cof = COS( rlatu(jjp1-j+1) )/ colat0
+       IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatu(jjp1-j+1) ).LT.1. ) THEN
+               jfiltsu= jjp1-j+1
+          ENDIF
+       ENDIF
+    ENDDO
+    !
+    DO j = 1, jjm/2
+       cof = COS( rlatv(j) )/ colat0
+       IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatv(j) ).LT.1. ) THEN
+            jfiltnv= j
+          ENDIF
+       ENDIF
+
+       cof = COS( rlatv(jjm-j+1) )/ colat0
+       IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatv(jjm-j+1) ).LT.1. ) THEN
+               jfiltsv= jjm-j+1
+          ENDIF
+       ENDIF
+    ENDDO
+    !                                 
+
+    IF( jfiltnu.GT. jjm/2 +1 )  THEN
+       PRINT *,' jfiltnu en dehors des valeurs acceptables ' ,jfiltnu
+       STOP
+    ENDIF
+
+    IF( jfiltsu.GT.  jjm  +1 )  THEN
+       PRINT *,' jfiltsu en dehors des valeurs acceptables ' ,jfiltsu
+       STOP
+    ENDIF
+
+    IF( jfiltnv.GT. jjm/2    )  THEN
+       PRINT *,' jfiltnv en dehors des valeurs acceptables ' ,jfiltnv
+       STOP
+    ENDIF
+
+    IF( jfiltsv.GT.     jjm  )  THEN
+       PRINT *,' jfiltsv en dehors des valeurs acceptables ' ,jfiltsv
+       STOP
+    ENDIF
+
+    PRINT *,'inifilr: jfiltnv jfiltsv jfiltnu jfiltsu ' , &
+         jfiltnv,jfiltsv,jfiltnu,jfiltsu
+
+    IF(first_call_inifilr) THEN
+       ALLOCATE(matriceun(iim,iim,jfiltnu))
+       ALLOCATE(matriceus(iim,iim,jjm-jfiltsu+1))
+       ALLOCATE(matricevn(iim,iim,jfiltnv))
+       ALLOCATE(matricevs(iim,iim,jjm-jfiltsv+1))
+       ALLOCATE( matrinvn(iim,iim,jfiltnu))
+       ALLOCATE( matrinvs(iim,iim,jjm-jfiltsu+1))
+       first_call_inifilr = .FALSE.
+    ENDIF
+
+    !                                 
+    !   ... Determination de coefilu,coefilv,n=modfrstu,modfrstv ....
+    !................................................................
+    !
+    !
+    DO j = 1,jjm
+    !default initialization: all modes are retained (i.e. no filtering)
+       modfrstu( j ) = iim
+       modfrstv( j ) = iim
+    ENDDO
+    !
+    DO j = 2,jfiltnu
+       DO k = 2,modemax
+          cof = rlamda(k) * COS( rlatu(j) )
+          IF ( cof .LT. 1. ) GOTO 82
+       ENDDO
+       GOTO 84
+82     modfrstu( j ) = k
+       !
+       kf = modfrstu( j )
+       DO k = kf , modemax
+          cof = rlamda(k) * COS( rlatu(j) )
+          coefilu(k,j) = cof - 1.
+          coefilu2(k,j) = cof*cof - 1.
+       ENDDO
+84     CONTINUE
+    ENDDO
+    !                                 
+    !
+    DO j = 1,jfiltnv
+       !
+       DO k = 2,modemax
+          cof = rlamda(k) * COS( rlatv(j) )
+          IF ( cof .LT. 1. ) GOTO 87
+       ENDDO
+       GOTO 89
+87     modfrstv( j ) = k
+       !
+       kf = modfrstv( j )
+       DO k = kf , modemax
+          cof = rlamda(k) * COS( rlatv(j) )
+          coefilv(k,j) = cof - 1.
+          coefilv2(k,j) = cof*cof - 1.
+       ENDDO
+89     CONTINUE
+    ENDDO
+    !
+    DO j = jfiltsu,jjm
+       DO k = 2,modemax
+          cof = rlamda(k) * COS( rlatu(j) )
+          IF ( cof .LT. 1. ) GOTO 92
+       ENDDO
+       GOTO 94
+92     modfrstu( j ) = k
+       !
+       kf = modfrstu( j )
+       DO k = kf , modemax
+          cof = rlamda(k) * COS( rlatu(j) )
+          coefilu(k,j) = cof - 1.
+          coefilu2(k,j) = cof*cof - 1.
+       ENDDO
+94     CONTINUE
+    ENDDO
+    !                                 
+    DO j = jfiltsv,jjm
+       DO k = 2,modemax
+          cof = rlamda(k) * COS( rlatv(j) )
+          IF ( cof .LT. 1. ) GOTO 97
+       ENDDO
+       GOTO 99
+97     modfrstv( j ) = k
+       !
+       kf = modfrstv( j )
+       DO k = kf , modemax
+          cof = rlamda(k) * COS( rlatv(j) )
+          coefilv(k,j) = cof - 1.
+          coefilv2(k,j) = cof*cof - 1.
+       ENDDO
+99     CONTINUE
+    ENDDO
+    !
+
+    IF(jfiltnv.GE.jjm/2 .OR. jfiltnu.GE.jjm/2)THEN
+! Ehouarn: and what are these for??? Trying to handle a limit case
+!          where filters extend to and meet at the equator?
+       IF(jfiltnv.EQ.jfiltsv)jfiltsv=1+jfiltnv
+       IF(jfiltnu.EQ.jfiltsu)jfiltsu=1+jfiltnu
+
+       PRINT *,'jfiltnv jfiltsv jfiltnu jfiltsu' , &
+            jfiltnv,jfiltsv,jfiltnu,jfiltsu
+    ENDIF
+
+    PRINT *,'   Modes premiers  v  '
+    PRINT 334,modfrstv
+    PRINT *,'   Modes premiers  u  '
+    PRINT 334,modfrstu
+
+    !  
+    !   ...................................................................
+    !
+    !   ... Calcul de la matrice filtre 'matriceu'  pour les champs situes
+    !                       sur la grille scalaire                 ........
+    !   ...................................................................
+    !
+    DO j = 2, jfiltnu
+
+       DO i=1,iim
+          coff = coefilu(i,j)
+          IF( i.LT.modfrstu(j) ) coff = 0.
+          DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+          ENDDO
+       ENDDO ! of DO i=1,iim
+#ifdef CRAY
+       CALL MXM( eignfnv,iim,eignft,iim,matriceun(1,1,j),iim )
+#else
+#ifdef BLAS
+       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
+            eignfnv, iim, eignft, iim, 0.0, matriceun(1,1,j), iim)
+#else
+       DO k = 1, iim
+          DO i = 1, iim
+             matriceun(i,k,j) = 0.0
+             DO ii = 1, iim
+                matriceun(i,k,j) = matriceun(i,k,j) &
+                     + eignfnv(i,ii)*eignft(ii,k)
+             ENDDO
+          ENDDO
+       ENDDO ! of DO k = 1, iim
+#endif
+#endif
+
+    ENDDO ! of DO j = 2, jfiltnu
+
+    DO j = jfiltsu, jjm
+
+       DO i=1,iim
+          coff = coefilu(i,j)
+          IF( i.LT.modfrstu(j) ) coff = 0.
+          DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+          ENDDO
+       ENDDO ! of DO i=1,iim
+#ifdef CRAY
+       CALL MXM(eignfnv,iim,eignft,iim,matriceus(1,1,j-jfiltsu+1),iim)
+#else
+#ifdef BLAS
+       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
+            eignfnv, iim, eignft, iim, 0.0, &
+            matriceus(1,1,j-jfiltsu+1), iim)
+#else
+       DO k = 1, iim
+          DO i = 1, iim
+             matriceus(i,k,j-jfiltsu+1) = 0.0
+             DO ii = 1, iim
+                matriceus(i,k,j-jfiltsu+1) = matriceus(i,k,j-jfiltsu+1) &
+                     + eignfnv(i,ii)*eignft(ii,k)
+             ENDDO
+          ENDDO
+       ENDDO ! of DO k = 1, iim
+#endif
+#endif
+
+    ENDDO ! of DO j = jfiltsu, jjm
+
+    !   ...................................................................
+    !
+    !   ... Calcul de la matrice filtre 'matricev'  pour les champs situes
+    !                       sur la grille   de V ou de Z           ........
+    !   ...................................................................
+    !
+    DO j = 1, jfiltnv
+
+       DO i = 1, iim
+          coff = coefilv(i,j)
+          IF( i.LT.modfrstv(j) ) coff = 0.
+          DO k = 1, iim
+             eignft(i,k) = eignfnu(k,i) * coff
+          ENDDO
+       ENDDO
+#ifdef CRAY
+       CALL MXM( eignfnu,iim,eignft,iim,matricevn(1,1,j),iim )
+#else
+#ifdef BLAS
+       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
+            eignfnu, iim, eignft, iim, 0.0, matricevn(1,1,j), iim)
+#else
+       DO k = 1, iim
+          DO i = 1, iim
+             matricevn(i,k,j) = 0.0
+             DO ii = 1, iim
+                matricevn(i,k,j) = matricevn(i,k,j) &
+                     + eignfnu(i,ii)*eignft(ii,k)
+             ENDDO
+          ENDDO
+       ENDDO
+#endif
+#endif
+
+    ENDDO ! of DO j = 1, jfiltnv
+
+    DO j = jfiltsv, jjm
+
+       DO i = 1, iim
+          coff = coefilv(i,j)
+          IF( i.LT.modfrstv(j) ) coff = 0.
+          DO k = 1, iim
+             eignft(i,k) = eignfnu(k,i) * coff
+          ENDDO
+       ENDDO
+#ifdef CRAY
+       CALL MXM(eignfnu,iim,eignft,iim,matricevs(1,1,j-jfiltsv+1),iim)
+#else
+#ifdef BLAS
+       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
+            eignfnu, iim, eignft, iim, 0.0, & 
+            matricevs(1,1,j-jfiltsv+1), iim)
+#else
+       DO k = 1, iim
+          DO i = 1, iim
+             matricevs(i,k,j-jfiltsv+1) = 0.0
+             DO ii = 1, iim
+                matricevs(i,k,j-jfiltsv+1) = matricevs(i,k,j-jfiltsv+1) &
+                     + eignfnu(i,ii)*eignft(ii,k)
+             ENDDO
+          ENDDO
+       ENDDO
+#endif
+#endif
+
+    ENDDO ! of DO j = jfiltsv, jjm
+
+    !   ...................................................................
+    !
+    !   ... Calcul de la matrice filtre 'matrinv'  pour les champs situes
+    !              sur la grille scalaire , pour le filtre inverse ........
+    !   ...................................................................
+    !
+    DO j = 2, jfiltnu
+
+       DO i = 1,iim
+          coff = coefilu(i,j)/ ( 1. + coefilu(i,j) )
+          IF( i.LT.modfrstu(j) ) coff = 0.
+          DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+          ENDDO
+       ENDDO
+#ifdef CRAY
+       CALL MXM( eignfnv,iim,eignft,iim,matrinvn(1,1,j),iim )
+#else
+#ifdef BLAS
+       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
+            eignfnv, iim, eignft, iim, 0.0, matrinvn(1,1,j), iim)
+#else
+       DO k = 1, iim
+          DO i = 1, iim
+             matrinvn(i,k,j) = 0.0
+             DO ii = 1, iim
+                matrinvn(i,k,j) = matrinvn(i,k,j) &
+                     + eignfnv(i,ii)*eignft(ii,k)
+             ENDDO
+          ENDDO
+       ENDDO
+#endif
+#endif
+
+    ENDDO ! of DO j = 2, jfiltnu
+
+    DO j = jfiltsu, jjm
+
+       DO i = 1,iim
+          coff = coefilu(i,j) / ( 1. + coefilu(i,j) )
+          IF( i.LT.modfrstu(j) ) coff = 0.
+          DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+          ENDDO
+       ENDDO
+#ifdef CRAY
+       CALL MXM(eignfnv,iim,eignft,iim,matrinvs(1,1,j-jfiltsu+1),iim)
+#else
+#ifdef BLAS
+       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
+            eignfnv, iim, eignft, iim, 0.0, matrinvs(1,1,j-jfiltsu+1), iim)
+#else
+       DO k = 1, iim
+          DO i = 1, iim
+             matrinvs(i,k,j-jfiltsu+1) = 0.0
+             DO ii = 1, iim
+                matrinvs(i,k,j-jfiltsu+1) = matrinvs(i,k,j-jfiltsu+1) &
+                     + eignfnv(i,ii)*eignft(ii,k)
+             ENDDO
+          ENDDO
+       ENDDO
+#endif
+#endif
+
+    ENDDO ! of DO j = jfiltsu, jjm
+
+#ifdef CPP_PARA
+    IF (use_filtre_fft) THEN
+       CALL Init_filtre_fft(coefilu,modfrstu,jfiltnu,jfiltsu,  &
+                           coefilv,modfrstv,jfiltnv,jfiltsv)
+       CALL Init_filtre_fft_loc(coefilu,modfrstu,jfiltnu,jfiltsu,  &
+                           coefilv,modfrstv,jfiltnv,jfiltsv)
+    ENDIF
+#endif
+    !   ...................................................................
+
+    !
+334 FORMAT(1x,24i3)
+755 FORMAT(1x,6f10.3,i3)
+
+    RETURN
+  END SUBROUTINE inifilr
+
+END MODULE filtreg_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/inifgn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/inifgn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/inifgn.F	(revision 222)
@@ -0,0 +1,106 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/filtrez/inifgn.F,v 1.1.1.1 2004-05-19 12:53:09 lmdzadmin Exp $
+!
+      SUBROUTINE inifgn(dv)
+c  
+c    ...  H.Upadyaya , O.Sharma  ... 
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "serre.h"
+
+c
+      REAL vec(iim,iim),vec1(iim,iim)
+      REAL dlonu(iim),dlonv(iim)
+      REAL du(iim),dv(iim),d(iim)
+      REAL pi
+      INTEGER i,j,k,imm1,nrot
+C
+#include "coefils.h"
+c
+      EXTERNAL SSUM, acc,eigen,jacobi
+      REAL SSUM
+c
+
+      imm1  = iim -1
+      pi = 2.* ASIN(1.)
+C
+      DO 5 i=1,iim
+       dlonu(i)=  xprimu( i )
+       dlonv(i)=  xprimv( i )
+   5  CONTINUE
+
+      DO 12 i=1,iim
+      sddv(i)   = SQRT(dlonv(i))
+      sddu(i)   = SQRT(dlonu(i))
+      unsddu(i) = 1./sddu(i)
+      unsddv(i) = 1./sddv(i)
+  12  CONTINUE
+C
+      DO 17 j=1,iim
+      DO 17 i=1,iim
+      vec(i,j)     = 0.
+      vec1(i,j)    = 0.
+      eignfnv(i,j) = 0.
+      eignfnu(i,j) = 0.
+  17  CONTINUE
+c
+c
+      eignfnv(1,1)    = -1.
+      eignfnv(iim,1)  =  1.
+      DO 20 i=1,imm1
+      eignfnv(i+1,i+1)= -1.
+      eignfnv(i,i+1)  =  1.
+  20  CONTINUE
+      DO 25 j=1,iim
+      DO 25 i=1,iim
+      eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j))
+  25  CONTINUE
+      DO 30 j=1,iim
+      DO 30 i=1,iim
+      eignfnu(i,j) = -eignfnv(j,i)
+  30  CONTINUE
+c
+#ifdef CRAY
+      CALL MXM(eignfnu,iim,eignfnv,iim,vec ,iim)
+      CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+#else
+      DO j = 1, iim
+      DO i = 1, iim
+        vec (i,j) = 0.0
+        vec1(i,j) = 0.0
+       DO k = 1, iim
+        vec (i,j) = vec(i,j)  + eignfnu(i,k) * eignfnv(k,j)
+        vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j)
+       ENDDO
+      ENDDO
+      ENDDO
+#endif
+
+c
+      CALL jacobi(vec,iim,iim,dv,eignfnv,nrot)
+      CALL acc(eignfnv,d,iim)
+      CALL eigen_sort(dv,eignfnv,iim,iim)
+c
+      CALL jacobi(vec1,iim,iim,du,eignfnu,nrot)
+      CALL acc(eignfnu,d,iim)
+      CALL eigen_sort(du,eignfnu,iim,iim)
+
+cc   ancienne version avec appels IMSL
+c
+c     CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim)
+c     CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+c     CALL EVCSF(iim,vec,iim,dv,eignfnv,iim)
+c     CALL acc(eignfnv,d,iim)
+c     CALL eigen(eignfnv,dv)
+c
+c     CALL EVCSF(iim,vec1,iim,du,eignfnu,iim)
+c     CALL acc(eignfnu,d,iim)
+c     CALL eigen(eignfnu,du)
+
+      RETURN
+      END
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/jacobi.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/jacobi.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/jacobi.F90	(revision 222)
@@ -0,0 +1,106 @@
+!
+! $Id: jacobi.F90 1289 2009-12-18 14:51:22Z emillour $
+!
+      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
+      implicit none
+! Arguments:
+      integer,intent(in) :: N
+      integer,intent(in) :: NP
+      integer,intent(out) :: NROT
+      real,intent(inout) :: A(NP,NP)
+      real,intent(out) :: D(NP)
+      real,intent(out) :: V(NP,NP)
+
+! local variables:
+      integer :: IP,IQ,I,J
+      real :: SM,TRESH,G,H,T,THETA,C,S,TAU
+      real :: B(N)
+      real :: Z(N)
+      
+      DO IP=1,N
+        DO IQ=1,N
+          V(IP,IQ)=0.
+        ENDDO
+        V(IP,IP)=1.
+      ENDDO
+      DO IP=1,N
+        B(IP)=A(IP,IP)
+        D(IP)=B(IP)
+        Z(IP)=0.
+      ENDDO
+      NROT=0
+      DO I=1,50 ! 50? I suspect this should be NP
+                !     but convergence is fast enough anyway
+        SM=0.
+        DO IP=1,N-1
+          DO IQ=IP+1,N
+            SM=SM+ABS(A(IP,IQ))
+          ENDDO
+        ENDDO
+        IF(SM.EQ.0.)RETURN
+        IF(I.LT.4)THEN
+          TRESH=0.2*SM/N**2
+        ELSE
+          TRESH=0.
+        ENDIF
+        DO IP=1,N-1
+          DO IQ=IP+1,N
+            G=100.*ABS(A(IP,IQ))
+            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP))) &
+               .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
+              A(IP,IQ)=0.
+            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
+              H=D(IQ)-D(IP)
+              IF(ABS(H)+G.EQ.ABS(H))THEN
+                T=A(IP,IQ)/H
+              ELSE
+                THETA=0.5*H/A(IP,IQ)
+                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
+                IF(THETA.LT.0.)T=-T
+              ENDIF
+              C=1./SQRT(1+T**2)
+              S=T*C
+              TAU=S/(1.+C)
+              H=T*A(IP,IQ)
+              Z(IP)=Z(IP)-H
+              Z(IQ)=Z(IQ)+H
+              D(IP)=D(IP)-H
+              D(IQ)=D(IQ)+H
+              A(IP,IQ)=0.
+              DO J=1,IP-1
+                G=A(J,IP)
+                H=A(J,IQ)
+                A(J,IP)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+             ENDDO
+              DO J=IP+1,IQ-1
+                G=A(IP,J)
+                H=A(J,IQ)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+              ENDDO
+              DO J=IQ+1,N
+                G=A(IP,J)
+                H=A(IQ,J)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(IQ,J)=H+S*(G-H*TAU)
+              ENDDO
+              DO J=1,N
+                G=V(J,IP)
+                H=V(J,IQ)
+                V(J,IP)=G-S*(H+G*TAU)
+                V(J,IQ)=H+S*(G-H*TAU)
+              ENDDO
+              NROT=NROT+1
+            ENDIF
+          ENDDO
+        ENDDO
+        DO IP=1,N
+          B(IP)=B(IP)+Z(IP)
+          D(IP)=B(IP)
+          Z(IP)=0.
+        ENDDO
+      ENDDO ! of DO I=1,50
+      STOP 'Jacobi: 50 iterations should never happen'
+      RETURN
+      END SUBROUTINE JACOBI
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mkl_dft_type.f90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mkl_dft_type.f90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mkl_dft_type.f90	(revision 222)
@@ -0,0 +1,228 @@
+!*****************************************************************************
+! Copyright(C) 2002-2011 Intel Corporation. All Rights Reserved.
+!
+! The source code, information  and  material ("Material") contained herein is
+! owned  by Intel Corporation or its suppliers or licensors, and title to such
+! Material remains  with Intel Corporation  or its suppliers or licensors. The
+! Material  contains proprietary information  of  Intel or  its  suppliers and
+! licensors. The  Material is protected by worldwide copyright laws and treaty
+! provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
+! modified, published, uploaded, posted, transmitted, distributed or disclosed
+! in any way  without Intel's  prior  express written  permission. No  license
+! under  any patent, copyright  or  other intellectual property rights  in the
+! Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
+! implication, inducement,  estoppel or  otherwise.  Any  license  under  such
+! intellectual  property  rights must  be express  and  approved  by  Intel in
+! writing.
+!
+! *Third Party trademarks are the property of their respective owners.
+!
+! Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
+! this  notice or  any other notice embedded  in Materials by Intel or Intel's
+! suppliers or licensors in any way.
+!
+!*****************************************************************************
+! Content:
+!    Intel(R) Math Kernel Library (MKL)
+!    Discrete Fourier Transform Interface (DFTI)
+!*****************************************************************************
+
+MODULE MKL_DFT_TYPE
+
+  TYPE, PUBLIC :: DFTI_DESCRIPTOR
+     PRIVATE
+     INTEGER :: dontuse
+     ! Structure of this type is not used in Fortran code
+     ! the pointer to this type is used only
+  END TYPE DFTI_DESCRIPTOR
+
+  !======================================================================
+  ! These real type kind parameters are not for direct use
+  !======================================================================
+
+  INTEGER, PARAMETER :: DFTI_SPKP = SELECTED_REAL_KIND(6,37)
+  INTEGER, PARAMETER :: DFTI_DPKP = SELECTED_REAL_KIND(15,307)
+
+  !======================================================================
+  ! Descriptor configuration parameters [default values in brackets]
+  !======================================================================
+
+  ! Domain for forward transform. No default value
+  INTEGER, PARAMETER :: DFTI_FORWARD_DOMAIN = 0
+
+  ! Dimensionality, or rank. No default value
+  INTEGER, PARAMETER :: DFTI_DIMENSION = 1
+
+  ! Length(s) of transform. No default value
+  INTEGER, PARAMETER :: DFTI_LENGTHS = 2
+
+  ! Floating point precision. No default value
+  INTEGER, PARAMETER :: DFTI_PRECISION = 3
+
+  ! Scale factor for forward transform [1.0]
+  INTEGER, PARAMETER :: DFTI_FORWARD_SCALE = 4
+
+  ! Scale factor for backward transform [1.0]
+  INTEGER, PARAMETER :: DFTI_BACKWARD_SCALE = 5
+
+  ! Exponent sign for forward transform [DFTI_NEGATIVE]
+  ! INTEGER, PARAMETER :: DFTI_FORWARD_SIGN = 6 ! NOT IMPLEMENTED
+
+  ! Number of data sets to be transformed [1]
+  INTEGER, PARAMETER :: DFTI_NUMBER_OF_TRANSFORMS = 7
+
+  ! Storage of finite complex-valued sequences in complex domain
+  ! [DFTI_COMPLEX_COMPLEX]
+  INTEGER, PARAMETER :: DFTI_COMPLEX_STORAGE = 8
+
+  ! Storage of finite real-valued sequences in real domain
+  ! [DFTI_REAL_REAL]
+  INTEGER, PARAMETER :: DFTI_REAL_STORAGE = 9
+
+  ! Storage of finite complex-valued sequences in conjugate-even
+  ! domain [DFTI_COMPLEX_REAL]
+  INTEGER, PARAMETER :: DFTI_CONJUGATE_EVEN_STORAGE = 10
+
+  ! Placement of result [DFTI_INPLACE]
+  INTEGER, PARAMETER :: DFTI_PLACEMENT = 11
+
+  ! Generalized strides for input data layout
+  ! [tigth, col-major for Fortran]
+  INTEGER, PARAMETER :: DFTI_INPUT_STRIDES = 12
+
+  ! Generalized strides for output data layout
+  ! [tigth, col-major for Fortran]
+  INTEGER, PARAMETER :: DFTI_OUTPUT_STRIDES = 13
+
+  ! Distance between first input elements for multiple transforms [0]
+  INTEGER, PARAMETER :: DFTI_INPUT_DISTANCE = 14
+
+  ! Distance between first output elements for multiple transforms [0]
+  INTEGER, PARAMETER :: DFTI_OUTPUT_DISTANCE = 15
+
+  ! Effort spent in initialization [DFTI_MEDIUM]
+  ! INTEGER, PARAMETER :: DFTI_INITIALIZATION_EFFORT = 16 ! NOT IMPLEMENTED
+
+  ! Use of workspace during computation [DFTI_ALLOW]
+  INTEGER, PARAMETER :: DFTI_WORKSPACE = 17
+
+  ! Ordering of the result [DFTI_ORDERED]
+  INTEGER, PARAMETER :: DFTI_ORDERING = 18
+
+  ! Possible transposition of result [DFTI_NONE]
+  INTEGER, PARAMETER :: DFTI_TRANSPOSE = 19
+
+  ! User-settable descriptor name [""]
+  INTEGER, PARAMETER :: DFTI_DESCRIPTOR_NAME = 20
+
+  ! Packing format for DFTI_COMPLEX_REAL storage of finite
+  ! conjugate-even sequences [DFTI_CCS_FORMAT]
+  INTEGER, PARAMETER :: DFTI_PACKED_FORMAT = 21
+
+  ! Commit status of the descriptor. Read-only parameter
+  INTEGER, PARAMETER :: DFTI_COMMIT_STATUS = 22
+
+  ! Version string for this DFTI implementation. Read-only parameter
+  INTEGER, PARAMETER :: DFTI_VERSION = 23
+
+  ! Ordering of the forward transform. Read-only parameter
+  ! INTEGER, PARAMETER :: DFTI_FORWARD_ORDERING = 24 ! NOT IMPLEMENTED
+
+  ! Ordering of the backward transform. Read-only parameter
+  ! INTEGER, PARAMETER :: DFTI_BACKWARD_ORDERING = 25 ! NOT IMPLEMENTED
+
+  ! Number of user threads that share the descriptor [1]
+  INTEGER, PARAMETER :: DFTI_NUMBER_OF_USER_THREADS = 26
+
+  !======================================================================
+  ! Values of the descriptor configuration parameters
+  !======================================================================
+
+  ! DFTI_COMMIT_STATUS
+  INTEGER, PARAMETER :: DFTI_COMMITTED = 30
+  INTEGER, PARAMETER :: DFTI_UNCOMMITTED = 31
+
+  ! DFTI_FORWARD_DOMAIN
+  INTEGER, PARAMETER :: DFTI_COMPLEX = 32
+  INTEGER, PARAMETER :: DFTI_REAL = 33
+  ! INTEGER, PARAMETER :: DFTI_CONJUGATE_EVEN = 34 ! NOT IMPLEMENTED
+
+  ! DFTI_PRECISION
+  INTEGER, PARAMETER :: DFTI_SINGLE = 35
+  INTEGER, PARAMETER :: DFTI_DOUBLE = 36
+
+  ! DFTI_PRECISION for reduced size of statically linked application.
+  ! Recommended use: modify statement 'USE MKL_DFTI' in your program,
+  ! so that it reads as either of:
+  ! USE MKL_DFTI, FORGET=>DFTI_SINGLE, DFTI_SINGLE=>DFTI_SINGLE_R
+  ! USE MKL_DFTI, FORGET=>DFTI_DOUBLE, DFTI_DOUBLE=>DFTI_DOUBLE_R
+  ! where word 'FORGET' can be any name not used in the program.
+  REAL(DFTI_SPKP), PARAMETER :: DFTI_SINGLE_R = 35
+  REAL(DFTI_DPKP), PARAMETER :: DFTI_DOUBLE_R = 36
+
+  ! DFTI_FORWARD_SIGN
+  ! INTEGER, PARAMETER :: DFTI_NEGATIVE = 37 ! NOT IMPLEMENTED
+  ! INTEGER, PARAMETER :: DFTI_POSITIVE = 38 ! NOT IMPLEMENTED
+
+  ! DFTI_COMPLEX_STORAGE and DFTI_CONJUGATE_EVEN_STORAGE
+  INTEGER, PARAMETER :: DFTI_COMPLEX_COMPLEX = 39
+  INTEGER, PARAMETER :: DFTI_COMPLEX_REAL = 40
+
+  ! DFTI_REAL_STORAGE
+  INTEGER, PARAMETER :: DFTI_REAL_COMPLEX = 41
+  INTEGER, PARAMETER :: DFTI_REAL_REAL = 42
+
+  ! DFTI_PLACEMENT
+  INTEGER, PARAMETER :: DFTI_INPLACE = 43 ! Result overwrites input
+  INTEGER, PARAMETER :: DFTI_NOT_INPLACE  = 44 ! Have another place for result
+
+  ! DFTI_INITIALIZATION_EFFORT
+  ! INTEGER, PARAMETER :: DFTI_LOW = 45 ! NOT IMPLEMENTED
+  ! INTEGER, PARAMETER :: DFTI_MEDIUM = 46 ! NOT IMPLEMENTED
+  ! INTEGER, PARAMETER :: DFTI_HIGH = 47 ! NOT IMPLEMENTED
+
+  ! DFTI_ORDERING
+  INTEGER, PARAMETER :: DFTI_ORDERED = 48
+  INTEGER, PARAMETER :: DFTI_BACKWARD_SCRAMBLED = 49
+  ! INTEGER, PARAMETER :: DFTI_FORWARD_SCRAMBLED  = 50 ! NOT IMPLEMENTED
+
+  ! Allow/avoid certain usages
+  INTEGER, PARAMETER :: DFTI_ALLOW = 51 ! Allow transposition or workspace
+  INTEGER, PARAMETER :: DFTI_AVOID = 52 ! Avoid auxiliary storage
+  INTEGER, PARAMETER :: DFTI_NONE = 53
+
+  ! DFTI_PACKED_FORMAT
+  ! (for storing congugate-even finite sequence in real array)
+  INTEGER, PARAMETER :: DFTI_CCS_FORMAT = 54  ! Complex conjugate-symmetric
+  INTEGER, PARAMETER :: DFTI_PACK_FORMAT = 55 ! Pack format for real DFT
+  INTEGER, PARAMETER :: DFTI_PERM_FORMAT = 56 ! Perm format for real DFT
+  INTEGER, PARAMETER :: DFTI_CCE_FORMAT = 57  ! Complex conjugate-even
+
+  !======================================================================
+  ! Error classes
+  !======================================================================
+  INTEGER, PARAMETER :: DFTI_NO_ERROR = 0
+  INTEGER, PARAMETER :: DFTI_MEMORY_ERROR = 1
+  INTEGER, PARAMETER :: DFTI_INVALID_CONFIGURATION = 2
+  INTEGER, PARAMETER :: DFTI_INCONSISTENT_CONFIGURATION = 3
+  INTEGER, PARAMETER :: DFTI_MULTITHREADED_ERROR = 4
+  INTEGER, PARAMETER :: DFTI_BAD_DESCRIPTOR = 5
+  INTEGER, PARAMETER :: DFTI_UNIMPLEMENTED = 6
+  INTEGER, PARAMETER :: DFTI_MKL_INTERNAL_ERROR = 7
+  INTEGER, PARAMETER :: DFTI_NUMBER_OF_THREADS_ERROR = 8
+  INTEGER, PARAMETER :: DFTI_1D_LENGTH_EXCEEDS_INT32 = 9
+
+  ! Maximum length of error string
+  INTEGER, PARAMETER :: DFTI_MAX_MESSAGE_LENGTH = 80
+
+  ! Maximum length of user-settable descriptor name
+  INTEGER, PARAMETER :: DFTI_MAX_NAME_LENGTH = 10
+
+  ! Maximum length of MKL version string
+  INTEGER, PARAMETER :: DFTI_VERSION_LENGTH = 198
+
+  ! (deprecated parameter)
+  INTEGER, PARAMETER :: DFTI_ERROR_CLASS = 60
+
+END MODULE MKL_DFT_TYPE
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mkl_dfti.f90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mkl_dfti.f90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mkl_dfti.f90	(revision 222)
@@ -0,0 +1,529 @@
+!*****************************************************************************
+! Copyright(C) 2002-2011 Intel Corporation. All Rights Reserved.
+!
+! The source code, information  and  material ("Material") contained herein is
+! owned  by Intel Corporation or its suppliers or licensors, and title to such
+! Material remains  with Intel Corporation  or its suppliers or licensors. The
+! Material  contains proprietary information  of  Intel or  its  suppliers and
+! licensors. The  Material is protected by worldwide copyright laws and treaty
+! provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
+! modified, published, uploaded, posted, transmitted, distributed or disclosed
+! in any way  without Intel's  prior  express written  permission. No  license
+! under  any patent, copyright  or  other intellectual property rights  in the
+! Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
+! implication, inducement,  estoppel or  otherwise.  Any  license  under  such
+! intellectual  property  rights must  be express  and  approved  by  Intel in
+! writing.
+!
+! *Third Party trademarks are the property of their respective owners.
+!
+! Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
+! this  notice or  any other notice embedded  in Materials by Intel or Intel's
+! suppliers or licensors in any way.
+!
+!*****************************************************************************
+! Content:
+!    Intel(R) Math Kernel Library (MKL)
+!    Discrete Fourier Transform Interface (DFTI)
+!*****************************************************************************
+
+
+MODULE MKL_DFTI
+
+  USE MKL_DFT_TYPE
+
+  INTERFACE DftiCreateDescriptor
+
+     FUNCTION dfti_create_descriptor_1d(desc, precision, domain, dim, length)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_create_descriptor_1d
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_create_descriptor_1d
+       INTEGER dfti_create_descriptor_1d
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       INTEGER, INTENT(IN) :: precision
+       INTEGER, INTENT(IN) :: domain
+       INTEGER, INTENT(IN) :: dim, length
+     END FUNCTION dfti_create_descriptor_1d
+
+     FUNCTION dfti_create_descriptor_highd(desc, precision, domain, dim,length)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_create_descriptor_highd
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_create_descriptor_highd
+       INTEGER dfti_create_descriptor_highd
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       INTEGER, INTENT(IN) :: precision
+       INTEGER, INTENT(IN) :: domain
+       INTEGER, INTENT(IN) :: dim
+       INTEGER, INTENT(IN), DIMENSION(*) :: length
+     END FUNCTION dfti_create_descriptor_highd
+
+     FUNCTION dfti_create_descriptor_s_1d(desc, s, dom, one, dim)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_create_descriptor_s_1d
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_create_descriptor_s_1d
+       INTEGER dfti_create_descriptor_s_1d
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(IN) :: s
+       INTEGER, INTENT(IN) :: dom
+       INTEGER, INTENT(IN) :: one
+       INTEGER, INTENT(IN) :: dim
+     END FUNCTION dfti_create_descriptor_s_1d
+
+     FUNCTION dfti_create_descriptor_s_md(desc, s, dom, many, dims)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_create_descriptor_s_md
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_create_descriptor_s_md
+       INTEGER dfti_create_descriptor_s_md
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(IN) :: s
+       INTEGER, INTENT(IN) :: dom
+       INTEGER, INTENT(IN) :: many
+       INTEGER, INTENT(IN), DIMENSION(*) :: dims
+     END FUNCTION dfti_create_descriptor_s_md
+
+     FUNCTION dfti_create_descriptor_d_1d(desc, d, dom, one, dim)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_create_descriptor_d_1d
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_create_descriptor_d_1d
+       INTEGER dfti_create_descriptor_d_1d
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(IN) :: d
+       INTEGER, INTENT(IN) :: dom
+       INTEGER, INTENT(IN) :: one
+       INTEGER, INTENT(IN) :: dim
+     END FUNCTION dfti_create_descriptor_d_1d
+
+     FUNCTION dfti_create_descriptor_d_md(desc, d, dom, many, dims)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_create_descriptor_d_md
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_create_descriptor_d_md
+       INTEGER dfti_create_descriptor_d_md
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(IN) :: d
+       INTEGER, INTENT(IN) :: dom
+       INTEGER, INTENT(IN) :: many
+       INTEGER, INTENT(IN), DIMENSION(*) :: dims
+     END FUNCTION dfti_create_descriptor_d_md
+
+  END INTERFACE
+
+  INTERFACE DftiCopyDescriptor
+
+     FUNCTION dfti_copy_descriptor_external(desc, new_desc)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_copy_descriptor_external
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_copy_descriptor_external
+       INTEGER dfti_copy_descriptor_external
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       TYPE(DFTI_DESCRIPTOR), POINTER :: new_desc
+     END FUNCTION dfti_copy_descriptor_external
+
+  END INTERFACE
+
+  INTERFACE DftiCommitDescriptor
+
+     FUNCTION dfti_commit_descriptor_external(desc)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_commit_descriptor_external
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_commit_descriptor_external
+       INTEGER dfti_commit_descriptor_external
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_commit_descriptor_external
+
+  END INTERFACE
+
+  INTERFACE DftiSetValue
+
+     FUNCTION dfti_set_value_intval(desc, OptName, IntVal)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_set_value_intval
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_set_value_intval
+       INTEGER dfti_set_value_intval
+       INTEGER, INTENT(IN) :: OptName
+       INTEGER, INTENT(IN) :: IntVal
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_set_value_intval
+
+     FUNCTION dfti_set_value_sglval(desc, OptName, sglval)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_set_value_sglval
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_set_value_sglval
+       INTEGER dfti_set_value_sglval
+       INTEGER, INTENT(IN) :: OptName
+       REAL(DFTI_SPKP), INTENT(IN) :: sglval
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_set_value_sglval
+
+     FUNCTION dfti_set_value_dblval(desc, OptName, DblVal)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_set_value_dblval
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_set_value_dblval
+       INTEGER dfti_set_value_dblval
+       INTEGER, INTENT(IN) :: OptName
+       REAL(DFTI_DPKP), INTENT(IN) :: DblVal
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_set_value_dblval
+
+     FUNCTION dfti_set_value_intvec(desc, OptName, IntVec)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_set_value_intvec
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_set_value_intvec
+       INTEGER dfti_set_value_intvec
+       INTEGER, INTENT(IN) :: OptName
+       INTEGER, INTENT(IN), DIMENSION(*) :: IntVec
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_set_value_intvec
+
+     FUNCTION dfti_set_value_chars(desc, OptName, Chars)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_set_value_chars
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_set_value_chars
+       INTEGER dfti_set_value_chars
+       INTEGER, INTENT(IN) :: OptName
+       CHARACTER(*), INTENT(IN) :: Chars
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_set_value_chars
+
+  END INTERFACE
+
+  INTERFACE DftiGetValue
+
+     FUNCTION dfti_get_value_intval(desc, OptName, IntVal)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_get_value_intval
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_get_value_intval
+       INTEGER dfti_get_value_intval
+       INTEGER, INTENT(IN) :: OptName
+       INTEGER, INTENT(OUT) :: IntVal
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_get_value_intval
+
+     FUNCTION dfti_get_value_sglval(desc, OptName, sglval)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_get_value_sglval
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_get_value_sglval
+       INTEGER dfti_get_value_sglval
+       INTEGER, INTENT(IN) :: OptName
+       REAL(DFTI_SPKP), INTENT(OUT) :: sglval
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_get_value_sglval
+
+     FUNCTION dfti_get_value_dblval(desc, OptName, DblVal)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_get_value_dblval
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_get_value_dblval
+       INTEGER dfti_get_value_dblval
+       INTEGER, INTENT(IN) :: OptName
+       REAL(DFTI_DPKP), INTENT(OUT) :: DblVal
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_get_value_dblval
+
+     FUNCTION dfti_get_value_intvec(desc, OptName, IntVec)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_get_value_intvec
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_get_value_intvec
+       INTEGER dfti_get_value_intvec
+       INTEGER, INTENT(IN) :: OptName
+       INTEGER, INTENT(OUT), DIMENSION(*) :: IntVec
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_get_value_intvec
+
+     FUNCTION dfti_get_value_chars(desc, OptName, Chars)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_get_value_chars
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_get_value_chars
+       INTEGER dfti_get_value_chars
+       INTEGER, INTENT(IN) :: OptName
+       CHARACTER(*), INTENT(OUT) :: Chars
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_get_value_chars
+
+  END INTERFACE
+
+  INTERFACE DftiComputeForward
+
+     FUNCTION dfti_compute_forward_s(desc,sSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_s
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_s
+       INTEGER dfti_compute_forward_s
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: sSrcDst
+     END FUNCTION dfti_compute_forward_s
+
+     FUNCTION dfti_compute_forward_c(desc,cSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_c
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_c
+       INTEGER dfti_compute_forward_c
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: cSrcDst
+     END FUNCTION dfti_compute_forward_c
+
+     FUNCTION dfti_compute_forward_ss(desc,sSrcDstRe,sSrcDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_ss
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_ss
+       INTEGER dfti_compute_forward_ss
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstRe
+       REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstIm
+     END FUNCTION dfti_compute_forward_ss
+
+     FUNCTION dfti_compute_forward_sc(desc,sSrc,cDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_sc
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_sc
+       INTEGER dfti_compute_forward_sc
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrc
+       COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+     END FUNCTION dfti_compute_forward_sc
+
+     FUNCTION dfti_compute_forward_cc(desc,cSrc,cDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_cc
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_cc
+       INTEGER dfti_compute_forward_cc
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+       COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+     END FUNCTION dfti_compute_forward_cc
+
+     FUNCTION dfti_compute_forward_ssss(desc,sSrcRe,sSrcIm,sDstRe,sDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_ssss
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_ssss
+       INTEGER dfti_compute_forward_ssss
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcRe
+       REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcIm
+       REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstRe
+       REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstIm
+     END FUNCTION dfti_compute_forward_ssss
+
+     FUNCTION dfti_compute_forward_d(desc,dSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_d
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_d
+       INTEGER dfti_compute_forward_d
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: dSrcDst
+     END FUNCTION dfti_compute_forward_d
+
+     FUNCTION dfti_compute_forward_z(desc,zSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_z
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_z
+       INTEGER dfti_compute_forward_z
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: zSrcDst
+     END FUNCTION dfti_compute_forward_z
+
+     FUNCTION dfti_compute_forward_dd(desc,dSrcDstRe,dSrcDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_dd
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_dd
+       INTEGER dfti_compute_forward_dd
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstRe
+       REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstIm
+     END FUNCTION dfti_compute_forward_dd
+
+     FUNCTION dfti_compute_forward_dz(desc,dSrc,zDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_dz
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_dz
+       INTEGER dfti_compute_forward_dz
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrc
+       COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+     END FUNCTION dfti_compute_forward_dz
+
+     FUNCTION dfti_compute_forward_zz(desc,zSrc,zDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_zz
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_zz
+       INTEGER dfti_compute_forward_zz
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+       COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+     END FUNCTION dfti_compute_forward_zz
+
+     FUNCTION dfti_compute_forward_dddd(desc,dSrcRe,dSrcIm,dDstRe,dDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_forward_dddd
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_forward_dddd
+       INTEGER dfti_compute_forward_dddd
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcRe
+       REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcIm
+       REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstRe
+       REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstIm
+     END FUNCTION dfti_compute_forward_dddd
+
+  END INTERFACE DftiComputeForward
+
+  INTERFACE DftiComputeBackward
+
+     FUNCTION dfti_compute_backward_s(desc,sSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_s
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_s
+       INTEGER dfti_compute_backward_s
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: sSrcDst
+     END FUNCTION dfti_compute_backward_s
+
+     FUNCTION dfti_compute_backward_c(desc,cSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_c
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_c
+       INTEGER dfti_compute_backward_c
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: cSrcDst
+     END FUNCTION dfti_compute_backward_c
+
+     FUNCTION dfti_compute_backward_ss(desc,sSrcDstRe,sSrcDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_ss
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_ss
+       INTEGER dfti_compute_backward_ss
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstRe
+       REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstIm
+     END FUNCTION dfti_compute_backward_ss
+
+     FUNCTION dfti_compute_backward_cs(desc,cSrc,sDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_cs
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_cs
+       INTEGER dfti_compute_backward_cs
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+       REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDst
+     END FUNCTION dfti_compute_backward_cs
+
+     FUNCTION dfti_compute_backward_cc(desc,cSrc,cDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_cc
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_cc
+       INTEGER dfti_compute_backward_cc
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+       COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+     END FUNCTION dfti_compute_backward_cc
+
+     FUNCTION dfti_compute_backward_ssss(desc,sSrcRe,sSrcIm,sDstRe,sDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_ssss
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_ssss
+       INTEGER dfti_compute_backward_ssss
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcRe
+       REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcIm
+       REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstRe
+       REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstIm
+     END FUNCTION dfti_compute_backward_ssss
+
+     FUNCTION dfti_compute_backward_d(desc,dSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_d
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_d
+       INTEGER dfti_compute_backward_d
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: dSrcDst
+     END FUNCTION dfti_compute_backward_d
+
+     FUNCTION dfti_compute_backward_z(desc,zSrcDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_z
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_z
+       INTEGER dfti_compute_backward_z
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: zSrcDst
+     END FUNCTION dfti_compute_backward_z
+
+     FUNCTION dfti_compute_backward_dd(desc,dSrcDstRe,dSrcDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_dd
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_dd
+       INTEGER dfti_compute_backward_dd
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstRe
+       REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstIm
+     END FUNCTION dfti_compute_backward_dd
+
+     FUNCTION dfti_compute_backward_zd(desc,zSrc,dDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_zd
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_zd
+       INTEGER dfti_compute_backward_zd
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+       REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDst
+     END FUNCTION dfti_compute_backward_zd
+
+     FUNCTION dfti_compute_backward_zz(desc,zSrc,zDst)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_zz
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_zz
+       INTEGER dfti_compute_backward_zz
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+       COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+     END FUNCTION dfti_compute_backward_zz
+
+     FUNCTION dfti_compute_backward_dddd(desc,dSrcRe,dSrcIm,dDstRe,dDstIm)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_compute_backward_dddd
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_compute_backward_dddd
+       INTEGER dfti_compute_backward_dddd
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+       REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcRe
+       REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcIm
+       REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstRe
+       REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstIm
+     END FUNCTION dfti_compute_backward_dddd
+
+  END INTERFACE DftiComputeBackward
+
+  INTERFACE DftiFreeDescriptor
+
+     FUNCTION dfti_free_descriptor_external(desc)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_free_descriptor_external
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_free_descriptor_external
+       INTEGER dfti_free_descriptor_external
+       TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+     END FUNCTION dfti_free_descriptor_external
+
+  END INTERFACE
+
+  INTERFACE DftiErrorClass
+
+     FUNCTION dfti_error_class_external(Status, ErrorClass)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_error_class_external
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_error_class_external
+       LOGICAL dfti_error_class_external
+       INTEGER, INTENT(IN) :: Status
+       INTEGER, INTENT(IN) :: ErrorClass
+     END FUNCTION dfti_error_class_external
+
+  END INTERFACE
+
+  INTERFACE DftiErrorMessage
+
+     FUNCTION dfti_error_message_external(Status)
+       USE MKL_DFT_TYPE
+       !DEC$ ATTRIBUTES C :: dfti_error_message_external
+       !DEC$ ATTRIBUTES REFERENCE :: dfti_error_message_external
+       CHARACTER(LEN=DFTI_MAX_MESSAGE_LENGTH) :: dfti_error_message_external
+       INTEGER, INTENT(IN) :: Status
+     END FUNCTION dfti_error_message_external
+
+  END INTERFACE
+
+END MODULE MKL_DFTI
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft.F90	(revision 222)
@@ -0,0 +1,17 @@
+MODULE mod_fft
+
+#ifdef FFT_MATHKEISAN
+  USE mod_fft_mathkeisan
+#else
+#ifdef FFT_FFTW
+  USE mod_fft_fftw
+#else
+#ifdef FFT_MKL
+  USE mod_fft_mkl
+#else
+  USE mod_fft_wrapper
+#endif
+#endif
+#endif
+
+END MODULE mod_fft
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_fftw.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_fftw.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_fftw.F90	(revision 222)
@@ -0,0 +1,114 @@
+!
+! $Id: mod_fft_fftw.F90 1403 2010-07-01 09:02:53Z fairhead $
+!
+
+MODULE mod_fft_fftw
+
+#ifdef FFT_FFTW
+
+  REAL, SAVE                   :: scale_factor
+  INTEGER, SAVE                :: vsize
+  INTEGER, PARAMETER           :: inc=1
+  
+  INTEGER*8, ALLOCATABLE, DIMENSION(:), SAVE :: plan_forward
+  INTEGER*8, ALLOCATABLE, DIMENSION(:), SAVE :: plan_backward
+  
+CONTAINS
+  
+  SUBROUTINE Init_fft(iim,nvectmax)
+  IMPLICIT NONE
+#include <fftw3.f>
+    INTEGER :: iim
+    INTEGER :: nvectmax
+
+    INTEGER :: itmp
+
+    INTEGER               :: rank
+    INTEGER               :: howmany
+    INTEGER               :: istride, idist
+    INTEGER               :: ostride, odist
+    INTEGER, DIMENSION(1) :: n_array, inembed, onembed
+
+    REAL,    DIMENSION(iim+1,nvectmax) :: dbidon
+    COMPLEX, DIMENSION(iim/2+1,nvectmax) :: cbidon
+
+    vsize = iim
+    scale_factor = 1./SQRT(1.*vsize)
+
+    dbidon = 0
+    cbidon = 0
+
+    ALLOCATE(plan_forward(nvectmax))
+    ALLOCATE(plan_backward(nvectmax))
+    
+    WRITE(*,*)"!---------------------!"
+    WRITE(*,*)"!                     !"
+    WRITE(*,*)"! INITIALISATION FFTW !"
+    WRITE(*,*)"!                     !"
+    WRITE(*,*)"!---------------------!"
+    
+! On initialise tous les plans 
+    DO itmp = 1, nvectmax
+       rank       = 1
+       n_array(1) = iim
+       howmany    = itmp
+       inembed(1) = iim + 1 ; onembed(1) = iim/2 + 1
+       istride    = 1       ; ostride    = 1
+       idist      = iim + 1 ; odist      = iim/2 + 1
+
+       CALL dfftw_plan_many_dft_r2c(plan_forward(itmp), rank, n_array, howmany, &
+            & dbidon, inembed, istride, idist, &
+            & cbidon, onembed, ostride, odist, &
+            & FFTW_ESTIMATE)
+
+       rank       = 1
+       n_array(1) = iim
+       howmany    = itmp
+       inembed(1) = iim/2 + 1 ; onembed(1) = iim + 1
+       istride    = 1         ; ostride    = 1
+       idist      = iim/2 + 1 ; odist      = iim + 1
+       CALL dfftw_plan_many_dft_c2r(plan_backward(itmp), rank, n_array, howmany, &
+            & cbidon, inembed, istride, idist, &
+            & dbidon, onembed, ostride, odist, &
+            & FFTW_ESTIMATE)
+
+    ENDDO
+
+    WRITE(*,*)"!-------------------------!"
+    WRITE(*,*)"!                         !"
+    WRITE(*,*)"! FIN INITIALISATION FFTW !"
+    WRITE(*,*)"!                         !"
+    WRITE(*,*)"!-------------------------!"
+
+  END SUBROUTINE Init_fft
+  
+  
+  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
+    IMPLICIT NONE
+#include <fftw3.f>
+    INTEGER,INTENT(IN)     :: nb_vect
+    REAL,INTENT(IN)        :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect)
+
+    CALL dfftw_execute_dft_r2c(plan_forward(nb_vect),vect,TF_vect)
+
+    TF_vect = scale_factor * TF_vect
+
+  END SUBROUTINE fft_forward
+  
+  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
+    IMPLICIT NONE
+#include <fftw3.f>
+    INTEGER,INTENT(IN)     :: nb_vect
+    REAL,INTENT(OUT)       :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
+
+    CALL dfftw_execute_dft_c2r(plan_backward(nb_vect),TF_vect,vect)
+
+    vect = scale_factor * vect
+
+  END SUBROUTINE fft_backward
+
+#endif
+  
+END MODULE mod_fft_fftw
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_mathkeisan.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_mathkeisan.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_mathkeisan.F90	(revision 222)
@@ -0,0 +1,67 @@
+MODULE mod_fft_mathkeisan
+#ifdef FFT_MATHKEISAN
+
+  REAL,SAVE,ALLOCATABLE    :: Table_forward(:)
+  REAL,SAVE,ALLOCATABLE    :: Table_backward(:)
+  REAL,SAVE                :: scale_factor
+  INTEGER,SAVE             :: vsize
+  INTEGER,PARAMETER        :: inc=2
+
+CONTAINS
+  
+  SUBROUTINE Init_fft(iim,nb_vect_max)
+  IMPLICIT NONE
+    INTEGER :: iim
+    INTEGER :: nb_vect_max
+    REAL    :: rtmp=1.
+    COMPLEX :: ctmp
+    INTEGER :: itmp=1
+    INTEGER :: isign=0
+    INTEGER :: ierr
+    
+    vsize=iim
+    scale_factor=1./SQRT(1.*vsize)
+    ALLOCATE(Table_forward(2*vsize+64))
+    ALLOCATE(Table_backward(2*vsize+64))
+    
+    CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr)
+    
+    CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr)
+
+    
+  END SUBROUTINE Init_fft
+  
+  
+  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect)
+    REAL                :: work(4*vsize*nb_vect)
+    INTEGER             :: ierr
+    INTEGER, PARAMETER :: isign=-1
+    
+    work=0
+    CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr)
+  
+  END SUBROUTINE fft_forward
+  
+  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(OUT)    :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
+    REAL                :: work(4*vsize*nb_vect)
+    INTEGER             :: ierr
+    INTEGER, PARAMETER :: isign=1
+    
+    work(:)=0
+    CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr)
+  
+  END SUBROUTINE fft_backward
+
+#endif
+  
+END MODULE mod_fft_mathkeisan
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_mkl.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_mkl.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_mkl.F90	(revision 222)
@@ -0,0 +1,128 @@
+MODULE mod_fft_mkl
+#ifdef FFT_MKL
+
+  USE MKL_DFTI
+  
+  REAL,SAVE                :: scale_factor
+  INTEGER,SAVE             :: vsize
+  INTEGER,PARAMETER        :: inc=1
+ 
+!  TYPE FFT_HANDLE
+!    TYPE(DFTI_DESCRIPTOR), POINTER :: Pt
+!    LOGICAL :: IsAllocated
+!  END TYPE FFT_HANDLE
+  
+!  TYPE(FFT_HANDLE),SAVE,ALLOCATABLE :: Forward_Handle(:)
+!  TYPE(FFT_HANDLE),SAVE,ALLOCATABLE :: Backward_Handle(:)
+!!$OMP THREADPRIVATE(Forward_Handle,Backward_Handle)  
+  
+CONTAINS
+  
+  SUBROUTINE Init_fft(iim,nb_vect_max)
+    IMPLICIT NONE
+    INTEGER :: iim
+    INTEGER :: nb_vect_max
+    REAL    :: rtmp=1.
+    COMPLEX :: ctmp
+    INTEGER :: itmp=1
+    INTEGER :: isign=0
+    INTEGER :: ierr
+    
+    vsize=iim
+    scale_factor=1./SQRT(1.*vsize)
+!    ALLOCATE(Forward_Handle(nb_vect_max))
+!    ALLOCATE(Backward_Handle(nb_vect_max))
+    
+!    Forward_Handle(:)%IsAllocated=.FALSE.
+!    Backward_Handle(:)%IsAllocated=.FALSE.
+    
+!    ALLOCATE(Table_forward(2*vsize+64))
+!    ALLOCATE(Table_backward(2*vsize+64))
+!    
+!    CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr)
+!    
+!    CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr)
+
+!    ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize )
+!    ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect)
+!    ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor)
+!    ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor)
+!    ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE)
+!    ierr = DftiSetValue(Desc_Handle, DFTI_INPUT_DISTANCE, vsize+inc)
+!    ierr = DftiSetValue(Desc_Handle, DFTI_OUTPUT_DISTANCE, vsize)
+!    ierr = DftiCommitDescriptor( FFT_HANDLE )
+
+  END SUBROUTINE Init_fft
+  
+  
+  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(IN)     :: vect((vsize+inc)*nb_vect)
+    COMPLEX,INTENT(OUT) :: TF_vect((vsize/2+1)*nb_vect)
+    REAL                :: work(4*vsize*nb_vect)
+    INTEGER             :: ierr
+    INTEGER, PARAMETER :: isign=-1
+    REAL               :: vect_out((vsize+inc)*nb_vect)
+    TYPE(DFTI_DESCRIPTOR), POINTER :: FFT_Handle
+    
+!    IF ( .NOT. Forward_handle(nb_vect)%IsAllocated) THEN
+      ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize )
+      ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect)
+      ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor)
+      ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor)
+      ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE)
+      ierr = DftiSetValue(FFT_Handle, DFTI_INPUT_DISTANCE, vsize+inc)
+      ierr = DftiSetValue(FFT_Handle, DFTI_OUTPUT_DISTANCE, (vsize/2+1)*2)
+      ierr = DftiCommitDescriptor( FFT_Handle )
+!      Forward_handle(nb_vect)%IsAllocated=.TRUE.
+!    ENDIF
+    
+    ierr = DftiComputeForward( FFT_Handle, vect, TF_vect )
+
+    ierr = DftiFreeDescriptor( FFT_Handle )
+
+!    ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize )
+!    ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect)
+!    ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor)
+!    ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor)
+!    ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE)
+!    ierr = DftiSetValue(FFT_HANDLE, DFTI_INPUT_DISTANCE, vsize/2+1)
+!    ierr = DftiSetValue(FFT_HANDLE, DFTI_OUTPUT_DISTANCE, vsize+inc)
+!    ierr = DftiCommitDescriptor( FFT_HANDLE )
+!    ierr = DftiComputeBackward( FFT_HANDLE, TF_vect, vect_out )
+!    ierr = DftiFreeDescriptor( FFT_HANDLE )
+
+!    CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr)
+  
+  END SUBROUTINE fft_forward
+  
+  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(OUT)    :: vect((vsize+inc)*nb_vect)
+    COMPLEX,INTENT(IN ) :: TF_vect((vsize/2+1)*nb_vect)
+    REAL                :: work(4*vsize*nb_vect)
+    INTEGER             :: ierr
+    INTEGER, PARAMETER :: isign=1
+    TYPE(DFTI_DESCRIPTOR),POINTER :: FFT_Handle
+!    CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr)
+!    IF ( .NOT. Backward_handle(nb_vect)%IsAllocated) THEN
+      ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize )
+      ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect)
+      ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor)
+      ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor)
+      ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE)
+      ierr = DftiSetValue(FFT_Handle, DFTI_INPUT_DISTANCE,  (vsize/2+1)*2)
+      ierr = DftiSetValue(FFT_Handle, DFTI_OUTPUT_DISTANCE, vsize+inc)
+      ierr = DftiCommitDescriptor( FFT_Handle )
+!      Backward_handle(nb_vect)%IsAllocated=.TRUE.
+!    ENDIF
+    ierr = DftiComputeBackward( FFT_Handle, TF_vect, vect )
+    ierr = DftiFreeDescriptor( FFT_Handle)
+  
+  END SUBROUTINE fft_backward
+
+#endif
+  
+END MODULE mod_fft_mkl
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_wrapper.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_wrapper.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_fft_wrapper.F90	(revision 222)
@@ -0,0 +1,37 @@
+MODULE mod_fft_wrapper
+
+  INTEGER,SAVE             :: vsize
+  INTEGER,PARAMETER        :: inc=1
+
+CONTAINS
+  
+  SUBROUTINE Init_fft(iim,nb)
+  IMPLICIT NONE
+    INTEGER :: iim
+    INTEGER :: nb
+    
+    STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
+  END SUBROUTINE Init_fft
+  
+  
+  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect)
+    
+    STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
+    
+  END SUBROUTINE fft_forward
+  
+  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(INOUT)    :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
+  
+    STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
+    
+  END SUBROUTINE fft_backward
+  
+END MODULE mod_fft_wrapper
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_filtre_fft.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_filtre_fft.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_filtre_fft.F90	(revision 222)
@@ -0,0 +1,300 @@
+!
+! $Id: mod_filtre_fft.F90 1403 2010-07-01 09:02:53Z fairhead $
+!
+
+MODULE mod_filtre_fft
+
+  LOGICAL,SAVE :: use_filtre_fft
+  REAL,SAVE,ALLOCATABLE :: Filtre_u(:,:)
+  REAL,SAVE,ALLOCATABLE :: Filtre_v(:,:)
+  REAL,SAVE,ALLOCATABLE :: Filtre_inv(:,:)
+
+CONTAINS
+  
+  SUBROUTINE Init_filtre_fft(coeffu,modfrstu,jfiltnu,jfiltsu,coeffv,modfrstv,jfiltnv,jfiltsv)
+    USE mod_fft
+    IMPLICIT NONE
+    include 'dimensions.h'
+    REAL,   INTENT(IN) :: coeffu(iim,jjm)
+    INTEGER,INTENT(IN) :: modfrstu(jjm)
+    INTEGER,INTENT(IN) :: jfiltnu
+    INTEGER,INTENT(IN) :: jfiltsu
+    REAL,   INTENT(IN) :: coeffv(iim,jjm)
+    INTEGER,INTENT(IN) :: modfrstv(jjm)
+    INTEGER,INTENT(IN) :: jfiltnv
+    INTEGER,INTENT(IN) :: jfiltsv
+    
+    INTEGER            :: index_vp(iim)
+    INTEGER            :: i,j
+    INTEGER            :: l,ll_nb
+
+    index_vp(1)=1
+    DO i=1,iim/2
+      index_vp(i+1)=i*2
+    ENDDO
+    
+    DO i=1,iim/2-1
+      index_vp(iim/2+i+1)=iim-2*i+1
+    ENDDO
+    
+    ALLOCATE(Filtre_u(iim,jjm))
+    ALLOCATE(Filtre_v(iim,jjm))
+    ALLOCATE(Filtre_inv(iim,jjm))
+  
+    
+    DO j=2,jfiltnu
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_u(i,j)=0
+        ELSE
+          Filtre_u(i,j)=coeffu(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+    
+    DO j=jfiltsu,jjm
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_u(i,j)=0
+        ELSE
+          Filtre_u(i,j)=coeffu(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+ 
+    DO j=1,jfiltnv
+      DO i=1,iim
+        IF (index_vp(i) < modfrstv(j)) THEN
+          Filtre_v(i,j)=0
+        ELSE
+          Filtre_v(i,j)=coeffv(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+   
+    DO j=jfiltsv,jjm
+      DO i=1,iim
+        IF (index_vp(i) < modfrstv(j)) THEN
+          Filtre_v(i,j)=0
+        ELSE
+          Filtre_v(i,j)=coeffv(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+         
+    DO j=2,jfiltnu
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_inv(i,j)=0
+        ELSE
+          Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j))
+        ENDIF
+      ENDDO
+    ENDDO
+
+    DO j=jfiltsu,jjm
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_inv(i,j)=0
+        ELSE
+          Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j))
+        ENDIF
+      ENDDO
+    ENDDO
+    
+#ifdef FFT_FFTW
+
+    WRITE (*,*)"COTH jfiltnu,jfiltsu,jfiltnv,jjm-jfiltsv"
+    WRITE (*,*)jfiltnu,jfiltsu,jfiltnv,jjm-jfiltsv
+    WRITE (*,*)MAX(jfiltnu-2,jjm-jfiltsu,jfiltnv-2,jjm-jfiltsv)+1
+    CALL Init_FFT(iim,(llm+1)*(MAX(jfiltnu-2,jjm-jfiltsu,jfiltnv-2,jjm-jfiltsv)+1))
+#else    
+    CALL Init_FFT(iim,(jjm+1)*(llm+1))
+#endif        
+    
+  END SUBROUTINE Init_filtre_fft
+  
+  SUBROUTINE Filtre_u_fft(vect_inout,nlat,jj_begin,jj_end,nbniv)
+    USE mod_fft
+#ifdef CPP_PARA
+    USE parallel_lmdz,ONLY : OMP_CHUNK
+#endif
+    IMPLICIT NONE
+    include 'dimensions.h'
+    INTEGER,INTENT(IN) :: nlat
+    INTEGER,INTENT(IN) :: jj_begin
+    INTEGER,INTENT(IN) :: jj_end
+    INTEGER,INTENT(IN) :: nbniv
+    REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv)
+
+    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
+    COMPLEX         :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
+    INTEGER            :: nb_vect
+    INTEGER :: i,j,l
+    INTEGER :: ll_nb
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+    nb_vect=(jj_end-jj_begin+1)*ll_nb
+
+    CALL FFT_forward(vect,TF_vect,nb_vect)
+
+    DO l=1,ll_nb
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim/2+1
+          TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_u(i,jj_begin+j-1)
+        ENDDO
+      ENDDO
+    ENDDO
+  
+    CALL FFT_backward(TF_vect,vect,nb_vect)
+      
+      
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+  END SUBROUTINE Filtre_u_fft
+  
+
+  SUBROUTINE Filtre_v_fft(vect_inout,nlat,jj_begin,jj_end,nbniv)
+    USE mod_fft
+#ifdef CPP_PARA
+    USE parallel_lmdz,ONLY : OMP_CHUNK
+#endif
+    IMPLICIT NONE
+    INCLUDE 'dimensions.h'
+    INTEGER,INTENT(IN) :: nlat
+    INTEGER,INTENT(IN) :: jj_begin
+    INTEGER,INTENT(IN) :: jj_end
+    INTEGER,INTENT(IN) :: nbniv
+    REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv)
+
+    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
+    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
+    INTEGER            :: nb_vect
+    INTEGER :: i,j,l
+    INTEGER :: ll_nb
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+    
+    nb_vect=(jj_end-jj_begin+1)*ll_nb
+
+    CALL FFT_forward(vect,TF_vect,nb_vect)
+  
+    DO l=1,ll_nb
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim/2+1
+          TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_v(i,jj_begin+j-1)
+        ENDDO
+      ENDDO
+    ENDDO
+  
+    CALL FFT_backward(TF_vect,vect,nb_vect)
+    
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  
+  END SUBROUTINE Filtre_v_fft
+
+
+  SUBROUTINE Filtre_inv_fft(vect_inout,nlat,jj_begin,jj_end,nbniv)
+    USE mod_fft
+#ifdef CPP_PARA
+    USE parallel_lmdz,ONLY : OMP_CHUNK
+#endif
+    IMPLICIT NONE
+    INCLUDE 'dimensions.h'
+    INTEGER,INTENT(IN) :: nlat
+    INTEGER,INTENT(IN) :: jj_begin
+    INTEGER,INTENT(IN) :: jj_end
+    INTEGER,INTENT(IN) :: nbniv
+    REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv)
+
+     REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
+    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
+    INTEGER            :: nb_vect
+    INTEGER :: i,j,l
+    INTEGER :: ll_nb
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+    nb_vect=(jj_end-jj_begin+1)*ll_nb
+
+    CALL FFT_forward(vect,TF_vect,nb_vect)
+  
+    DO l=1,ll_nb
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim/2+1
+          TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_inv(i,jj_begin+j-1)
+        ENDDO
+      ENDDO
+    ENDDO
+  
+    CALL FFT_backward(TF_vect,vect,nb_vect)
+
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+  END SUBROUTINE Filtre_inv_fft  
+   
+END MODULE mod_filtre_fft
+ 
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_filtre_fft_loc.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_filtre_fft_loc.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/mod_filtre_fft_loc.F90	(revision 222)
@@ -0,0 +1,343 @@
+MODULE mod_filtre_fft_loc
+
+  LOGICAL,SAVE :: use_filtre_fft
+  REAL,SAVE,ALLOCATABLE :: Filtre_u(:,:)
+  REAL,SAVE,ALLOCATABLE :: Filtre_v(:,:)
+  REAL,SAVE,ALLOCATABLE :: Filtre_inv(:,:)
+
+CONTAINS
+  
+  SUBROUTINE Init_filtre_fft(coeffu,modfrstu,jfiltnu,jfiltsu,coeffv,modfrstv,jfiltnv,jfiltsv)
+    USE mod_fft
+    IMPLICIT NONE
+    include 'dimensions.h'
+    REAL,   INTENT(IN) :: coeffu(iim,jjm)
+    INTEGER,INTENT(IN) :: modfrstu(jjm)
+    INTEGER,INTENT(IN) :: jfiltnu
+    INTEGER,INTENT(IN) :: jfiltsu
+    REAL,   INTENT(IN) :: coeffv(iim,jjm)
+    INTEGER,INTENT(IN) :: modfrstv(jjm)
+    INTEGER,INTENT(IN) :: jfiltnv
+    INTEGER,INTENT(IN) :: jfiltsv
+    
+    INTEGER            :: index_vp(iim)
+    INTEGER            :: i,j
+    
+    index_vp(1)=1
+    DO i=1,iim/2
+      index_vp(i+1)=i*2
+    ENDDO
+    
+    DO i=1,iim/2-1
+      index_vp(iim/2+i+1)=iim-2*i+1
+    ENDDO
+    
+    ALLOCATE(Filtre_u(iim,jjm))
+    ALLOCATE(Filtre_v(iim,jjm))
+    ALLOCATE(Filtre_inv(iim,jjm))
+  
+    
+    DO j=2,jfiltnu
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_u(i,j)=0
+        ELSE
+          Filtre_u(i,j)=coeffu(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+    
+    DO j=jfiltsu,jjm
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_u(i,j)=0
+        ELSE
+          Filtre_u(i,j)=coeffu(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+ 
+    DO j=1,jfiltnv
+      DO i=1,iim
+        IF (index_vp(i) < modfrstv(j)) THEN
+          Filtre_v(i,j)=0
+        ELSE
+          Filtre_v(i,j)=coeffv(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+   
+    DO j=jfiltsv,jjm
+      DO i=1,iim
+        IF (index_vp(i) < modfrstv(j)) THEN
+          Filtre_v(i,j)=0
+        ELSE
+          Filtre_v(i,j)=coeffv(index_vp(i),j)
+        ENDIF
+      ENDDO
+    ENDDO
+         
+    DO j=2,jfiltnu
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_inv(i,j)=0
+        ELSE
+          Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j))
+        ENDIF
+      ENDDO
+    ENDDO
+
+    DO j=jfiltsu,jjm
+      DO i=1,iim
+        IF (index_vp(i) < modfrstu(j)) THEN
+          Filtre_inv(i,j)=0
+        ELSE
+          Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j))
+        ENDIF
+      ENDDO
+    ENDDO
+    
+    
+!    CALL Init_FFT(iim,(jjm+1)*(llm+1))
+        
+    
+  END SUBROUTINE Init_filtre_fft
+  
+  SUBROUTINE Filtre_u_fft(vect_inout,jjb,jje,jj_begin,jj_end,nbniv)
+    USE mod_fft
+#ifdef CPP_PARA
+    USE parallel_lmdz,ONLY : OMP_CHUNK
+#endif
+    IMPLICIT NONE
+    include 'dimensions.h'
+    INTEGER,INTENT(IN) :: jjb
+    INTEGER,INTENT(IN) :: jje
+    INTEGER,INTENT(IN) :: jj_begin
+    INTEGER,INTENT(IN) :: jj_end
+    INTEGER,INTENT(IN) :: nbniv
+    REAL,INTENT(INOUT) :: vect_inout(iim+1,jjb:jje,nbniv)
+
+    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
+    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
+    INTEGER            :: nb_vect
+    INTEGER :: i,j,l
+    INTEGER :: ll_nb
+!    REAL               :: vect_tmp(iim+inc,jj_end-jj_begin+1,nbniv)
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+    nb_vect=(jj_end-jj_begin+1)*ll_nb
+
+!    vect_tmp=vect
+
+    CALL FFT_forward(vect,TF_vect,nb_vect)
+
+!    CALL FFT_forward(vect,TF_vect_test,nb_vect)
+!      PRINT *,"XXXXXXXXXXXXX Filtre_u_FFT xxxxxxxxxxxx"
+!      DO j=1,jj_end-jj_begin+1
+!      DO i=1,iim/2+1
+!         PRINT *,"====",i,j,"----->",TF_vect_test(i,j,1)
+!       ENDDO
+!      ENDDO
+
+    DO l=1,ll_nb
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim/2+1
+          TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_u(i,jj_begin+j-1)
+        ENDDO
+      ENDDO
+    ENDDO
+       
+    CALL FFT_backward(TF_vect,vect,nb_vect)
+!    CALL FFT_backward(TF_vect_test,vect_test,nb_vect)
+          
+!      PRINT *,"XXXXXXXXXXXXX Filtre_u_FFT xxxxxxxxxxxx"
+!      DO j=1,jj_end-jj_begin+1
+!         DO i=1,iim
+!           PRINT *,"====",i,j,"----->",vect_test(i,j,1)
+!         ENDDO
+!      ENDDO
+
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+  END SUBROUTINE Filtre_u_fft
+  
+
+  SUBROUTINE Filtre_v_fft(vect_inout,jjb,jje,jj_begin,jj_end,nbniv)
+    USE mod_fft
+#ifdef CPP_PARA
+    USE parallel_lmdz,ONLY : OMP_CHUNK
+#endif
+    IMPLICIT NONE
+    INCLUDE 'dimensions.h'
+    INTEGER,INTENT(IN) :: jjb
+    INTEGER,INTENT(IN) :: jje
+    INTEGER,INTENT(IN) :: jj_begin
+    INTEGER,INTENT(IN) :: jj_end
+    INTEGER,INTENT(IN) :: nbniv
+    REAL,INTENT(INOUT) :: vect_inout(iim+1,jjb:jje,nbniv)
+
+    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
+    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
+    INTEGER            :: nb_vect
+    INTEGER :: i,j,l
+    INTEGER :: ll_nb
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+    
+    nb_vect=(jj_end-jj_begin+1)*ll_nb
+
+    CALL FFT_forward(vect,TF_vect,nb_vect)
+  
+    DO l=1,ll_nb
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim/2+1
+          TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_v(i,jj_begin+j-1)
+        ENDDO
+      ENDDO
+    ENDDO
+  
+    CALL FFT_backward(TF_vect,vect,nb_vect)
+    
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  
+  END SUBROUTINE Filtre_v_fft
+
+
+  SUBROUTINE Filtre_inv_fft(vect_inout,jjb,jje,jj_begin,jj_end,nbniv)
+    USE mod_fft
+#ifdef CPP_PARA
+    USE parallel_lmdz,ONLY : OMP_CHUNK
+#endif
+    IMPLICIT NONE
+    INCLUDE 'dimensions.h'
+    INTEGER,INTENT(IN) :: jjb
+    INTEGER,INTENT(IN) :: jje
+    INTEGER,INTENT(IN) :: jj_begin
+    INTEGER,INTENT(IN) :: jj_end
+    INTEGER,INTENT(IN) :: nbniv
+    REAL,INTENT(INOUT) :: vect_inout(iim+1,jjb:jje,nbniv)
+
+    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
+    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
+    INTEGER            :: nb_vect
+    INTEGER :: i,j,l
+    INTEGER :: ll_nb
+    
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+    nb_vect=(jj_end-jj_begin+1)*ll_nb
+
+    CALL FFT_forward(vect,TF_vect,nb_vect)
+  
+    DO l=1,ll_nb
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim/2+1
+          TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_inv(i,jj_begin+j-1)
+        ENDDO
+      ENDDO
+    ENDDO
+  
+    CALL FFT_backward(TF_vect,vect,nb_vect)
+
+    ll_nb=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nbniv
+      ll_nb=ll_nb+1
+      DO j=1,jj_end-jj_begin+1
+        DO i=1,iim+1
+          vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb)
+        ENDDO
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+
+  END SUBROUTINE Filtre_inv_fft  
+  
+  
+!  SUBROUTINE get_ll_index(nbniv,ll_index,ll_nb)
+!  IMPLICIT NONE
+!    INTEGER,INTENT(IN)  :: nbniv
+!    INTEGER,INTENT(OUT) :: ll_index(nbniv)
+!    INTEGER,INTENT(OUT) :: ll_nb
+!
+!    INTEGER :: l,ll_begin, ll_end
+!   INTEGER :: omp_rank,omp_size
+!   INTEGER :: OMP_GET_NUM_THREADS
+!   INTEGER :: omp_chunk
+!   EXTERNAL OMP_GET_NUM_THREADS
+!   INTEGER :: OMP_GET_THREAD_NUM
+!   EXTERNAL OMP_GET_THREAD_NUM
+!
+!   
+!   omp_size=OMP_GET_NUM_THREADS()
+!   omp_rank=OMP_GET_THREAD_NUM()    
+!   omp_chunk=nbniv/omp_size+min(1,MOD(nbniv,omp_size))
+!   
+!   ll_begin=omp_rank*OMP_CHUNK+1
+!   ll_nb=0
+!   DO WHILE (ll_begin<=nbniv)
+!     ll_end=min(ll_begin+OMP_CHUNK-1,nbniv)
+!     DO l=ll_begin,ll_end
+!       ll_nb=ll_nb+1
+!       ll_index(ll_nb)=l
+!     ENDDO
+!     ll_begin=ll_begin+omp_size*OMP_CHUNK
+!   ENDDO
+!  
+!  END SUBROUTINE get_ll_index
+   
+END MODULE mod_filtre_fft_loc
+ 
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h	(revision 222)
@@ -0,0 +1,4 @@
+!
+! $Header$
+!
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h_192x142x29
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h_192x142x29	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h_192x142x29	(revision 222)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c        PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+c      PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+
+c 96 72 19 non-zoom:
+c     PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
+c 192 142 29 non-zoom:
+      PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+c
+c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
+c        PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 )
+c
+c
+c      Ici , on a exagere  les nombres de lignes de latitudes a filtrer .
+c
+c      La premiere fois que  le Gcm  rentrera  dans le Filtre ,
+c
+c      il indiquera  les bonnes valeurs  de  nfilun , nflius, nfilvn  et 
+c
+c      nfilvs  a  mettre .  Il suffira alors de changer ces valeurs dans
+c
+c      Parameter  ci-dessus  et de relancer  le  run .  
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h_96x71x19
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h_96x71x19	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/parafilt.h_96x71x19	(revision 222)
@@ -0,0 +1,46 @@
+!
+! $Header$
+!
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c        PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+c      PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+
+cIM 96 72 19 non-zoom:
+c 96 71 19 non-zoom:
+      PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
+c 192 142 29 non-zoom:
+c     PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+c
+c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
+c        PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 )
+c
+c
+c      Ici , on a exagere  les nombres de lignes de latitudes a filtrer .
+c
+c      La premiere fois que  le Gcm  rentrera  dans le Filtre ,
+c
+c      il indiquera  les bonnes valeurs  de  nfilun , nflius, nfilvn  et 
+c
+c      nfilvs  a  mettre .  Il suffira alors de changer ces valeurs dans
+c
+c      Parameter  ci-dessus  et de relancer  le  run .  
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/timer_filtre.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/timer_filtre.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/filtrez/timer_filtre.F90	(revision 222)
@@ -0,0 +1,33 @@
+MODULE timer_filtre
+IMPLICIT NONE
+  PRIVATE
+  REAL :: time
+  REAL :: Last_time
+  PUBLIC :: Init_timer, start_timer, stop_timer, Print_filtre_timer
+CONTAINS
+
+ SUBROUTINE Init_timer
+   time=0
+   Last_time=0
+ END SUBROUTINE Init_timer
+ 
+ SUBROUTINE Start_timer
+  
+   CALL cpu_time(last_time)
+
+ END SUBROUTINE start_timer
+ 
+ 
+ SUBROUTINE stop_timer
+   REAL :: T 
+   
+   CALL cpu_time(t)
+   Time=Time+t-last_time
+ 
+  END SUBROUTINE stop_timer
+  
+  SUBROUTINE Print_filtre_timer
+  PRINT *,"Temps CPU passe dans le filtre :",Time
+  END SUBROUTINE  Print_filtre_timer
+
+END MODULE timer_filtre
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_new.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_new.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_new.h	(revision 222)
@@ -0,0 +1,27 @@
+!
+! $Header$
+!
+c--------------------------------------------------------------
+         REAL ripx
+         REAL fx,fxprim,fy,fyprim,ri,rj,bigy
+c
+c....stretching in x...
+c
+        ripx(  ri )= (ri-1.0) *2.*pi/REAL(iim) 
+        fx  (  ri )= ripx(ri) + transx  +
+     *         alphax * SIN( ripx(ri)+transx-pxo ) - pi
+        fxprim(ri) = 2.*pi/REAL(iim)  *
+     *        ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) )
+
+c....stretching in y...
+c
+        bigy(rj)   = 2.* (REAL(jjp1)-rj ) *pi/jjm
+        fy(rj)     =  ( bigy(rj) + transy  +
+     *        alphay * SIN( bigy(rj)+transy-pyo ) ) /2.  - pi/2.
+        fyprim(rj) = ( pi/jjm ) * ( 1.+
+     *           alphay * COS( bigy(rj)+transy-pyo ) )
+
+c       fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj-
+c     *  transy ))
+c       fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy)) 
+c--------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_reg.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_reg.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_reg.h	(revision 222)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
+      fyprim( rj ) =    pi/REAL(jjm)
+
+c     fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
+c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/REAL(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_sin.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_sin.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxy_sin.h	(revision 222)
@@ -0,0 +1,42 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
+      fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/REAL(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxyprim.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxyprim.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/grid/fxyprim.h	(revision 222)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
+      fyprim( rj ) =    pi/REAL(jjm)
+
+c     fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
+c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/REAL(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerave.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerave.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerave.F	(revision 222)
@@ -0,0 +1,182 @@
+      subroutine aerave( ndata,
+     &     longdata,epdata,omegdata,gdata,          
+     &     longref,epref,temp,nir,longir
+     &     ,epir,omegir,gir,qref )
+
+
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculate mean values of aerosol quantities in each band.
+!     
+!     Authors
+!     ------- 
+!     R. Fournier (1996) 
+!     F. Forget (1996)
+!     
+!     Called by
+!     ---------
+!     suaer_corrk.F90
+!     
+!     Calls
+!     -----
+!     blackl.F
+!     
+!==================================================================
+
+!     
+!     R.Fournier 02/1996 
+!     (modif F.Forget 02/1996)
+!     le spectre est decoupe en "nir" bandes et cette routine calcule
+!     les donnees radiatives moyenne sur chaque bande : l'optimisation
+!     est faite pour une temperature au sol "temp" et une epaisseur
+!     optique de l'atmosphere "epref" a la longueur d'onde "longref"
+!     
+!     dans la version actuelle, les ponderations sont independantes de
+!     l'epaisseur optique : c'est a dire que "omegir", "gir"
+!     et "epir/epre" sont independants de "epref".
+!     en effet les ponderations sont choisies pour une solution exacte
+!     en couche mince et milieu isotherme. 
+!     
+!     entree
+!     
+!     ndata : taille des champs data
+!     longdata,epdata,omegdata,gdata : proprietes radiative de l'aerosol
+!     (longdata longueur d'onde en METRES)
+!     * longref : longueur d'onde a laquelle l'epaisseur optique
+!     est connue
+!     * epref : epaisseur optique a longref
+!     * temp : temperature choisie pour la ponderation (Planck)
+!     * nir : nombre d'intervals dans la discretisation spectrale
+!     du GCM
+!     * longir : longueurs d'onde definissant ces intervals
+!     
+!     sortie
+!     
+!     * epir : epaisseur optique moyenne pour chaque interval
+!     * omegir : "scattering albedo" moyen pour chaque interval
+!     * gir : "assymetry factor" moyen pour chaque interval
+!     * qref : extinction coefficient at reference wavelength
+
+!=======================================================================
+! output
+
+      REAL longref
+      REAL epref
+      REAL temp
+      INTEGER nir
+      REAL*8 longir(nir+1)
+      REAL epir(nir)
+      REAL omegir(nir)
+      REAL gir(nir)
+
+!=======================================================================
+
+      INTEGER iir,nirmx
+      PARAMETER (nirmx=100)
+      INTEGER idata,ndata
+
+      DOUBLE PRECISION tmp1
+      REAL tmp2,tmp3
+
+!=======================================================================
+! input
+
+      REAL emit
+      REAL totalemit(nirmx)
+      REAL longdata(ndata),epdata(ndata)
+     &     ,omegdata(ndata),gdata(ndata)
+      REAL qextcorrdata(ndata)
+      INTEGER ibande,nbande
+      PARAMETER (nbande=1000)
+
+      REAL long,deltalong
+      INTEGER ilong
+      INTEGER i1,i2
+      REAL c1,c2
+      REAL factep,qextcorr,omeg,g,qref
+
+      long=longref
+
+
+!=======================================================================
+!     pre-interpolation
+      ilong=1
+      DO idata=2,ndata
+         IF (long.gt.longdata(idata)) ilong=idata
+      ENDDO
+      i1=ilong
+      i2=ilong+1
+      IF (i2.gt.ndata) i2=ndata
+      IF (long.lt.longdata(1)) i2=1
+      IF (i1.eq.i2) THEN
+         c1=1.E+0
+         c2=0.E+0
+      ELSE
+         c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1))
+         c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2))
+      ENDIF
+
+      qref=c1*epdata(i1)+c2*epdata(i2)
+      factep=qref/epref
+      DO idata=1,ndata
+         qextcorrdata(idata)=epdata(idata)/factep
+      ENDDO
+!=======================================================================
+
+      DO iir=1,nir
+
+         deltalong=(longir(iir+1)-longir(iir)) / nbande
+         totalemit(iir)=0.E+0
+         epir(iir)=0.E+0
+         omegir(iir)=0.E+0
+         gir(iir)=0.E+0
+
+         DO ibande=1,nbande
+
+            long=longir(iir) + (ibande-0.5E+0) * deltalong
+            CALL blackl(DBLE(long),DBLE(temp),tmp1)
+            emit=REAL(tmp1)
+
+!=======================================================================
+!     interpolation
+            ilong=1
+            DO idata=2,ndata
+               IF (long.gt.longdata(idata)) ilong=idata
+            ENDDO
+            i1=ilong
+            i2=ilong+1
+
+            IF (i2.gt.ndata) i2=ndata
+            IF (long.lt.longdata(1)) i2=1
+            IF (i1.eq.i2) THEN
+               c1=1.E+0
+               c2=0.E+0
+            ELSE
+               c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1))
+               c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2))
+            ENDIF
+!=======================================================================
+
+            qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2)
+            omeg=c1*omegdata(i1)+c2*omegdata(i2)
+            g=c1*gdata(i1)+c2*gdata(i2)
+
+            totalemit(iir)=totalemit(iir)+deltalong*emit
+            epir(iir)=epir(iir)+deltalong*emit*qextcorr
+            omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr
+            gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g
+
+         ENDDO
+
+         gir(iir)=gir(iir)/omegir(iir)
+         omegir(iir)=omegir(iir)/epir(iir)
+         epir(iir)=epir(iir)/totalemit(iir)
+
+      ENDDO
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerave_new.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerave_new.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerave_new.F	(revision 222)
@@ -0,0 +1,223 @@
+      SUBROUTINE aerave_new ( ndata,
+     & longdata,epdata,omegdata,gdata,          
+     &            longref,epref,temp,nir,longir
+     &            ,epir,omegir,gir,qref,omegaref        )
+
+
+      IMPLICIT NONE
+c.......................................................................
+c
+c R.Fournier 02/1996 
+c (modif F.Forget 02/1996)
+c le spectre est decoupe en "nir" bandes et cette routine calcule
+c les donnees radiatives moyenne sur chaque bande : l'optimisation
+c est faite pour une temperature au sol "temp" et une epaisseur
+c optique de l'atmosphere "epref" a la longueur d'onde "longref"
+c
+c dans la version actuelle, les ponderations sont independantes de
+c l'epaisseur optique : c'est a dire que "omegir", "gir"
+c et "epir/epre" sont independants de "epref".
+c en effet les ponderations sont choisies pour une solution exacte
+c en couche mince et milieu isotherme. 
+c
+c entree
+c
+c    ndata : taille des champs data
+c    longdata,epdata,omegdata,gdata : proprietes radiative de l'aerosol
+c                  (longdata longueur d'onde en METRES)
+c  * longref : longueur d'onde a laquelle l'epaisseur optique
+c              est connue
+c  * epref : epaisseur optique a longref
+c  * temp : temperature choisie pour la ponderation (Planck)
+c  * nir : nombre d'intervals dans la discretisation spectrale
+c           du GCM
+c  * longir : longueurs d'onde definissant ces intervals
+c
+c sortie
+c
+c  * epir : epaisseur optique moyenne pour chaque interval
+c  * omegir : "scattering albedo" moyen pour chaque interval
+c  * gir : "assymetry factor" moyen pour chaque interval
+c  * qref : extinction coefficient at reference wavelength
+c  * omegaref : single scat. albedo at reference wavelength
+c
+c.......................................................................
+c
+      REAL longref
+      REAL epref
+      REAL temp
+      INTEGER nir
+      REAL*8 longir(nir+1)
+      REAL epir(nir)
+      REAL omegir(nir)
+      REAL gir(nir)
+c
+c.......................................................................
+c
+      INTEGER iir,nirmx
+      PARAMETER (nirmx=100)
+      INTEGER idata,ndata
+c
+c.......................................................................
+c
+      REAL emit
+      REAL totalemit(nirmx)
+      REAL longdata(ndata),epdata(ndata)
+     &    ,omegdata(ndata),gdata(ndata)
+      REAL qextcorrdata(ndata)
+      INTEGER ibande,nbande
+      PARAMETER (nbande=1000)
+      REAL long,deltalong
+      INTEGER ilong
+      INTEGER i1,i2
+      REAL c1,c2
+      REAL factep,qextcorr,omeg,g
+      REAL qref,omegaref
+c
+c.......................................................................
+c
+      DOUBLE PRECISION tmp1
+      REAL tmp2,tmp3
+c
+c
+      long=longref
+
+
+      !if(nir.eq.27)then
+      !print*,'long',long
+      !print*,'longdata',longdata
+      !print*,'epdata',epdata
+      !print*,'omegdata',omegdata
+      !print*,'gdata',gdata
+      !print*,'data looks aok!'
+
+      !print*,'ndata=',ndata
+      !print*,'longdata',shape(longdata)
+      !print*,'epdata',shape(epdata)
+      !print*,'omegdata',shape(omegdata)
+      !print*,'gdata',shape(gdata)
+      ! print*,'longref',longref
+      !print*,'epref',epref
+      !print*,'temp',temp
+      !print*,'nir',nir
+      !print*,'longir',longir
+      !print*,'epir',epir
+      !print*,'omegir',gir
+      !print*,'qref',qref
+      !print*,'longir=',longir
+      !stop
+      !endif
+
+
+c********************************************************
+c interpolation
+      ilong=1
+      DO idata=2,ndata
+        IF (long.gt.longdata(idata)) ilong=idata
+      ENDDO
+      i1=ilong
+      i2=ilong+1
+      IF (i2.gt.ndata) i2=ndata
+      IF (long.lt.longdata(1)) i2=1
+      IF (i1.eq.i2) THEN
+        c1=1.E+0
+        c2=0.E+0
+      ELSE
+        c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1))
+        c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2))
+      ENDIF
+c********************************************************
+c
+      qref=c1*epdata(i1)+c2*epdata(i2)
+      omegaref=c1*omegdata(i1)+c2*omegdata(i2)
+      factep=qref/epref
+      DO idata=1,ndata
+        qextcorrdata(idata)=epdata(idata)/factep
+      ENDDO
+c
+c.......................................................................
+c
+      DO iir=1,nir
+c
+c.......................................................................
+c
+        deltalong=(longir(iir+1)-longir(iir)) / nbande
+        totalemit(iir)=0.E+0
+        epir(iir)=0.E+0
+        omegir(iir)=0.E+0
+        gir(iir)=0.E+0
+c
+c.......................................................................
+c
+        DO ibande=1,nbande
+c
+c.......................................................................
+c
+          long=longir(iir) + (ibande-0.5E+0) * deltalong
+          CALL blackl(DBLE(long),DBLE(temp),tmp1)
+          emit=REAL(tmp1)
+c
+c.......................................................................
+c
+c********************************************************
+c interpolation
+      ilong=1
+      DO idata=2,ndata
+        IF (long.gt.longdata(idata)) ilong=idata
+      ENDDO
+      i1=ilong
+      i2=ilong+1
+      IF (i2.gt.ndata) i2=ndata
+      IF (long.lt.longdata(1)) i2=1
+      IF (i1.eq.i2) THEN
+        c1=1.E+0
+        c2=0.E+0
+      ELSE
+        c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1))
+        c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2))
+      ENDIF
+c********************************************************
+c
+          qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2)
+          omeg=c1*omegdata(i1)+c2*omegdata(i2)
+          g=c1*gdata(i1)+c2*gdata(i2)
+c
+c.......................................................................
+c
+          totalemit(iir)=totalemit(iir)+deltalong*emit
+          epir(iir)=epir(iir)+deltalong*emit*qextcorr
+          omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr
+          gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g
+c
+c.......................................................................
+c
+        ENDDO
+c
+c.......................................................................
+c
+        gir(iir)=gir(iir)/omegir(iir)
+        omegir(iir)=omegir(iir)/epir(iir)
+        epir(iir)=epir(iir)/totalemit(iir)
+c
+c.......................................................................
+c
+      ENDDO
+c
+c......................................................................
+c
+c     Diagnostic de controle si on moyenne sur tout le spectre vis ou IR :
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     tmp2=0.E+0
+c     DO iir=1,nir
+c       tmp2=tmp2+totalemit(iir)
+c     ENDDO
+c     tmp3=5.67E-8 * temp**4
+c     IF (abs((tmp2-tmp3)/tmp3).gt.0.05E+0) THEN
+c       PRINT *,'!!!! <---> il manque du Planck (voir moyenne.F)'
+c       PRINT *,'somme des bandes :',tmp2,'--- Planck:',tmp3
+c     ENDIF
+c
+c......................................................................
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aeropacity.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aeropacity.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aeropacity.F90	(revision 222)
@@ -0,0 +1,449 @@
+      Subroutine aeropacity(ngrid,nlayer,nq,pplay,pplev,pq, &
+         aerosol,reffrad,QREFvis3d,QREFir3d,tau_col,cloudfrac,totcloudfrac,clearsky)
+
+       use radinc_h, only : L_TAUMAX,naerkind
+       use aerosol_mod
+       USE comgeomfi_h
+       USE tracer_h, only: noms,rho_co2,rho_ice
+                  
+       implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Compute aerosol optical depth in each gridbox.
+!     
+!     Authors
+!     ------- 
+!     F. Forget
+!     F. Montmessin (water ice scheme) 
+!     update J.-B. Madeleine (2008)
+!     dust removal, simplification by Robin Wordsworth (2009)
+!
+!     Input
+!     ----- 
+!     ngrid             Number of horizontal gridpoints
+!     nlayer            Number of layers
+!     nq                Number of tracers
+!     pplev             Pressure (Pa) at each layer boundary
+!     pq                Aerosol mixing ratio
+!     reffrad(ngrid,nlayer,naerkind)         Aerosol effective radius
+!     QREFvis3d(ngrid,nlayermx,naerkind) \ 3d extinction coefficients
+!     QREFir3d(ngrid,nlayermx,naerkind)  / at reference wavelengths
+!
+!     Output
+!     ------
+!     aerosol            Aerosol optical depth in layer l, grid point ig
+!     tau_col            Total column optical depth at grid point ig
+!
+!=======================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "comvert.h"
+
+      INTEGER,INTENT(IN) :: ngrid  ! number of atmospheric columns
+      INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers
+      INTEGER,INTENT(IN) :: nq     ! number of tracers
+      REAL,INTENT(IN) :: pplay(ngrid,nlayer) ! mid-layer pressure (Pa)
+      REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa)
+      REAL,INTENT(IN) :: pq(ngrid,nlayer,nq) ! tracers (.../kg_of_air)
+      REAL,INTENT(OUT) :: aerosol(ngrid,nlayer,naerkind) ! aerosol optical depth
+      REAL,INTENT(IN) :: reffrad(ngrid,nlayer,naerkind) ! aerosol effective radius
+      REAL,INTENT(IN) :: QREFvis3d(ngrid,nlayermx,naerkind) ! extinction coefficient in the visible
+      REAL,INTENT(IN) :: QREFir3d(ngrid,nlayermx,naerkind)
+      REAL,INTENT(OUT):: tau_col(ngrid) !column integrated visible optical depth
+      ! BENJAMIN MODIFS
+      real,intent(in) :: cloudfrac(ngrid,nlayermx) ! cloud fraction
+      real,intent(out) :: totcloudfrac(ngrid) ! total cloud fraction
+      logical,intent(in) :: clearsky
+
+      real aerosol0
+
+      INTEGER l,ig,iq,iaer
+
+      LOGICAL,SAVE :: firstcall=.true.
+      REAL CBRT
+      EXTERNAL CBRT
+
+      INTEGER,SAVE :: i_co2ice=0      ! co2 ice
+      INTEGER,SAVE :: i_h2oice=0      ! water ice
+      CHARACTER(LEN=20) :: tracername ! to temporarily store text
+
+      ! for fixed dust profiles
+      real topdust, expfactor, zp
+      REAL taudusttmp(ngrid) ! Temporary dust opacity used before scaling
+      REAL tauh2so4tmp(ngrid) ! Temporary h2so4 opacity used before scaling
+
+      real CLFtot
+
+      ! identify tracers
+      IF (firstcall) THEN
+
+        write(*,*) "Tracers found in aeropacity:"
+        do iq=1,nq
+          tracername=noms(iq)
+          if (tracername.eq."co2_ice") then
+            i_co2ice=iq
+          write(*,*) "i_co2ice=",i_co2ice
+
+          endif
+          if (tracername.eq."h2o_ice") then
+            i_h2oice=iq
+            write(*,*) "i_h2oice=",i_h2oice
+          endif
+        enddo
+
+        if (noaero) then
+          print*, "No active aerosols found in aeropacity"
+        else
+          print*, "If you would like to use aerosols, make sure any old"
+          print*, "start files are updated in newstart using the option"
+          print*, "q=0"
+          write(*,*) "Active aerosols found in aeropacity:"
+        endif
+
+        if ((iaero_co2.ne.0).and.(.not.noaero)) then
+          print*, 'iaero_co2=  ',iaero_co2
+        endif
+        if (iaero_h2o.ne.0) then
+          print*,'iaero_h2o=  ',iaero_h2o    
+        endif
+        if (iaero_dust.ne.0) then
+          print*,'iaero_dust= ',iaero_dust
+        endif
+        if (iaero_h2so4.ne.0) then
+          print*,'iaero_h2so4= ',iaero_h2so4
+        endif
+        if (iaero_back2lay.ne.0) then
+          print*,'iaero_back2lay= ',iaero_back2lay
+        endif
+
+        firstcall=.false.
+      ENDIF ! of IF (firstcall)
+
+
+!     ---------------------------------------------------------
+!==================================================================
+!    CO2 ice aerosols
+!==================================================================
+
+      if (iaero_co2.ne.0) then
+           iaer=iaero_co2
+!       1. Initialization
+            aerosol(1:ngrid,1:nlayermx,iaer)=0.0
+!       2. Opacity calculation
+            if (noaero) then ! aerosol set to zero
+             aerosol(1:ngrid,1:nlayermx,iaer)=0.0
+            elseif (aerofixco2.or.(i_co2ice.eq.0)) then !  CO2 ice cloud prescribed
+               aerosol(1:ngrid,1:nlayermx,iaer)=1.e-9
+               !aerosol(1:ngrid,12,iaer)=4.0 ! single cloud layer option
+            else
+               DO ig=1, ngrid
+                  DO l=1,nlayer-1 ! to stop the rad tran bug
+
+                     aerosol0 =                         &
+                          (  0.75 * QREFvis3d(ig,l,iaer) /        &
+                          ( rho_co2 * reffrad(ig,l,iaer) )  ) *   &
+                          ( pq(ig,l,i_co2ice) + 1.E-9 ) *         &
+                          ( pplev(ig,l) - pplev(ig,l+1) ) / g
+                     aerosol0           = max(aerosol0,1.e-9)
+                     aerosol0           = min(aerosol0,L_TAUMAX)
+                     aerosol(ig,l,iaer) = aerosol0
+!                     aerosol(ig,l,iaer) = 0.0
+!                     print*, aerosol(ig,l,iaer)
+!        using cloud fraction
+!                     aerosol(ig,l,iaer) = -log(1 - CLF + CLF*exp(-aerosol0/CLF))
+!                     aerosol(ig,l,iaer) = min(aerosol(ig,l,iaer),L_TAUMAX)
+
+
+                  ENDDO
+               ENDDO
+            end if ! if fixed or varying
+      end if ! if CO2 aerosols   
+!==================================================================
+!     Water ice / liquid 
+!==================================================================
+
+      if (iaero_h2o.ne.0) then 
+           iaer=iaero_h2o
+!       1. Initialization
+            aerosol(1:ngrid,1:nlayermx,iaer)=0.0
+!       2. Opacity calculation
+            if (aerofixh2o.or.(i_h2oice.eq.0).or.clearsky) then
+               aerosol(1:ngrid,1:nlayermx,iaer) =1.e-9
+
+               ! put cloud at cloudlvl
+               if(kastprof.and.(cloudlvl.ne.0.0))then
+                  ig=1
+                  do l=1,nlayer
+                     if(int(cloudlvl).eq.l)then
+                     !if(cloudlvl.gt.(pplay(ig,l)/pplev(ig,1)))then
+                        print*,'Inserting cloud at level ',l
+                        !aerosol(ig,l,iaer)=10.0
+
+                        rho_ice=920.0
+
+                        ! the Kasting approximation
+                        aerosol(ig,l,iaer) =                      &
+                          (  0.75 * QREFvis3d(ig,l,iaer) /        &
+                          ( rho_ice * reffrad(ig,l,iaer) )  ) *   &
+                          !( pq(ig,l,i_h2oice) + 1.E-9 ) *         &
+                          ( 4.0e-4 + 1.E-9 ) *         &
+                          ( pplev(ig,l) - pplev(ig,l+1) ) / g
+
+
+                        open(115,file='clouds.out',form='formatted')
+                        write(115,*) l,aerosol(ig,l,iaer)
+                        close(115)
+
+                        return
+                     endif
+                  end do
+
+                  call abort
+               endif
+
+            else
+
+               do ig=1, ngrid
+                  do l=1,nlayer-1 ! to stop the rad tran bug
+
+                     aerosol(ig,l,iaer) =                                    & !modification by BC
+                          (  0.75 * QREFvis3d(ig,l,iaer) /        &
+                          ( rho_ice * reffrad(ig,l,iaer) )  ) *   &
+                          !  pq(ig,l,i_h2oice) *                   & !JL I dropped the +1e-9 here to have the same
+                          !( pplev(ig,l) - pplev(ig,l+1) ) / g       !   opacity in the clearsky=true and the 
+                                                                     !   clear=false/pq=0 case
+                          ( pq(ig,l,i_h2oice) + 1.E-9 ) *         & ! Doing this makes the code unstable, so I have restored it (RW)
+                          ( pplev(ig,l) - pplev(ig,l+1) ) / g 
+
+                  enddo
+               enddo
+
+               if(CLFvarying)then
+                  call totalcloudfrac(ngrid,nq,cloudfrac,totcloudfrac,pplev,pq,aerosol(1:ngrid,1:nlayermx,iaer))
+                  do ig=1, ngrid
+                     do l=1,nlayer-1 ! to stop the rad tran bug
+                        CLFtot  = max(totcloudfrac(ig),0.01)
+                        aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/CLFtot
+                        aerosol(ig,l,iaer) = max(aerosol(ig,l,iaer),1.e-9)
+                     enddo
+                  enddo
+               else
+                  do ig=1, ngrid
+                     do l=1,nlayer-1 ! to stop the rad tran bug
+                        CLFtot  = CLFfixval
+                        aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/CLFtot
+                        aerosol(ig,l,iaer) = max(aerosol(ig,l,iaer),1.e-9)
+                     enddo
+                  enddo
+              end if!(CLFvarying)
+            endif !(aerofixed.or.(i_h2oice.eq.0).or.clearsky)
+	      
+      end if ! End if h2o aerosol
+
+!==================================================================
+!             Dust 
+!==================================================================
+      if (iaero_dust.ne.0) then
+          iaer=iaero_dust
+!         1. Initialization 
+          aerosol(1:ngrid,1:nlayermx,iaer)=0.0
+          
+          topdust=30.0 ! km  (used to be 10.0 km) LK
+
+!       2. Opacity calculation
+
+!           expfactor=0.
+           DO l=1,nlayer-1
+             DO ig=1,ngrid
+!             Typical mixing ratio profile
+
+                 zp=(preff/pplay(ig,l))**(70./topdust)
+                 expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3)
+
+!             Vertical scaling function
+              aerosol(ig,l,iaer)= (pplev(ig,l)-pplev(ig,l+1)) &
+               *expfactor
+
+
+             ENDDO
+           ENDDO
+
+!          Rescaling each layer to reproduce the choosen (or assimilated)
+!          dust extinction opacity at visible reference wavelength, which
+!          is scaled to the "preff" reference surface pressure available in comvert.h
+!          and stored in startfi.nc
+
+            taudusttmp(1:ngrid)=0.
+              DO l=1,nlayer
+                DO ig=1,ngrid
+                   taudusttmp(ig) = taudusttmp(ig) &
+                          +  aerosol(ig,l,iaer)
+                ENDDO
+              ENDDO
+            DO l=1,nlayer-1
+               DO ig=1,ngrid
+                  aerosol(ig,l,iaer) = max(1E-20, &
+                          dusttau &
+                       *  pplev(ig,1) / preff &
+                       *  aerosol(ig,l,iaer) &
+                       /  taudusttmp(ig))
+
+              ENDDO
+            ENDDO
+      end if ! If dust aerosol   
+
+!==================================================================
+!           H2SO4 
+!==================================================================
+! added by LK
+      if (iaero_h2so4.ne.0) then
+         iaer=iaero_h2so4
+
+!       1. Initialization
+         aerosol(1:ngrid,1:nlayermx,iaer)=0.0
+
+
+!       2. Opacity calculation
+
+!           expfactor=0.
+         DO l=1,nlayer-1
+            DO ig=1,ngrid
+!              Typical mixing ratio profile
+
+               zp=(preff/pplay(ig,l))**(70./30) !emulating topdust
+               expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3)
+
+!             Vertical scaling function
+               aerosol(ig,l,iaer)= (pplev(ig,l)-pplev(ig,l+1))*expfactor
+
+            ENDDO
+         ENDDO
+         tauh2so4tmp(1:ngrid)=0.
+         DO l=1,nlayer
+            DO ig=1,ngrid
+               tauh2so4tmp(ig) = tauh2so4tmp(ig) + aerosol(ig,l,iaer)
+            ENDDO
+         ENDDO
+         DO l=1,nlayer-1
+            DO ig=1,ngrid
+               aerosol(ig,l,iaer) = max(1E-20, &
+                          1 &
+                       *  pplev(ig,1) / preff &
+                       *  aerosol(ig,l,iaer) &
+                       /  tauh2so4tmp(ig))
+
+            ENDDO
+         ENDDO
+
+! 1/700. is assuming a "sulfurtau" of 1
+! Sulfur aerosol routine to be improved.
+!                     aerosol0 =                         &
+!                          (  0.75 * QREFvis3d(ig,l,iaer) /        &
+!                          ( rho_h2so4 * reffrad(ig,l,iaer) )  ) *   &
+!                          ( pq(ig,l,i_h2so4) + 1.E-9 ) *         &
+!                          ( pplev(ig,l) - pplev(ig,l+1) ) / g
+!                     aerosol0           = max(aerosol0,1.e-9)
+!                     aerosol0           = min(aerosol0,L_TAUMAX)
+!                     aerosol(ig,l,iaer) = aerosol0
+
+!                  ENDDO
+!               ENDDO
+      end if
+ 
+           
+!     ---------------------------------------------------------
+!==================================================================
+!    Two-layer aerosols (unknown composition)
+!    S. Guerlet (2013)
+!==================================================================
+
+      if (iaero_back2lay .ne.0) then
+           iaer=iaero_back2lay
+!       1. Initialization
+            aerosol(1:ngrid,1:nlayermx,iaer)=0.0
+!       2. Opacity calculation
+          DO ig=1,ngrid
+           DO l=1,nlayer-1
+             aerosol(ig,l,iaer) = ( pplev(ig,l) - pplev(ig,l+1) )
+             !! 1. below tropospheric layer: no aerosols
+             IF (pplev(ig,l) .gt. pres_bottom_tropo) THEN
+               aerosol(ig,l,iaer) = 0.*aerosol(ig,l,iaer)
+             !! 2. tropo layer
+             ELSEIF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN
+               aerosol(ig,l,iaer) = obs_tau_col_tropo*aerosol(ig,l,iaer)
+             !! 3. linear transition
+             ELSEIF (pplev(ig,l) .lt. pres_top_tropo .and. pplev(ig,l) .gt. pres_bottom_strato) THEN
+               expfactor=log(obs_tau_col_strato/obs_tau_col_tropo)/log(pres_bottom_strato/pres_top_tropo)
+               aerosol(ig,l,iaer)= obs_tau_col_tropo*((pplev(ig,l)/pres_top_tropo)**expfactor)*aerosol(ig,l,iaer)/1.5
+             !! 4. strato layer
+             ELSEIF (pplev(ig,l) .le. pres_bottom_strato .and. pplev(ig,l) .gt. pres_top_strato) THEN
+               aerosol(ig,l,iaer)= obs_tau_col_strato*aerosol(ig,l,iaer)
+             !! 5. above strato layer: no aerosols
+             ELSEIF (pplev(ig,l) .lt. pres_top_strato) THEN
+               aerosol(ig,l,iaer) = 0.*aerosol(ig,l,iaer)
+             ENDIF
+	   ENDDO
+          ENDDO
+
+ !       3. Re-normalize to observed total column
+         tau_col(:)=0.0
+         DO l=1,nlayer
+          DO ig=1,ngrid
+               tau_col(ig) = tau_col(ig) &
+                     + aerosol(ig,l,iaer)/(obs_tau_col_tropo+obs_tau_col_strato)
+            ENDDO
+         ENDDO
+
+         DO ig=1,ngrid
+           DO l=1,nlayer-1
+                aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/tau_col(ig)
+           ENDDO
+         ENDDO
+
+
+      end if ! if Two-layer aerosols  
+
+
+! --------------------------------------------------------------------------
+! Column integrated visible optical depth in each point (used for diagnostic)
+
+      tau_col(:)=0.0
+      do iaer = 1, naerkind
+         do l=1,nlayer
+            do ig=1,ngrid
+               tau_col(ig) = tau_col(ig) + aerosol(ig,l,iaer)
+            end do
+         end do
+      end do
+
+      do ig=1,ngrid
+         do l=1,nlayer
+            do iaer = 1, naerkind
+               if(aerosol(ig,l,iaer).gt.1.e3)then
+                  print*,'WARNING: aerosol=',aerosol(ig,l,iaer)
+                  print*,'at ig=',ig,',  l=',l,', iaer=',iaer
+                  print*,'QREFvis3d=',QREFvis3d(ig,l,iaer)
+                  print*,'reffrad=',reffrad(ig,l,iaer)
+               endif
+            end do
+         end do
+      end do
+
+      do ig=1,ngrid
+         if(tau_col(ig).gt.1.e3)then
+            print*,'WARNING: tau_col=',tau_col(ig)
+            print*,'at ig=',ig
+            print*,'aerosol=',aerosol(ig,:,:)
+            print*,'QREFvis3d=',QREFvis3d(ig,:,:)
+            print*,'reffrad=',reffrad(ig,:,:)
+         endif
+      end do
+      return
+    end subroutine aeropacity
+      
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aeroptproperties.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aeroptproperties.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aeroptproperties.F90	(revision 222)
@@ -0,0 +1,744 @@
+      SUBROUTINE aeroptproperties(ngrid,nlayer,reffrad,nueffrad,   &
+                                  QVISsQREF3d,omegaVIS3d,gVIS3d,   &
+                                  QIRsQREF3d,omegaIR3d,gIR3d,      &
+                                  QREFvis3d,QREFir3d)!,		   &
+!                                  omegaREFvis3d,omegaREFir3d)
+
+      use radinc_h,    only: L_NSPECTI,L_NSPECTV,nsizemax,naerkind
+      use radcommon_h, only: QVISsQREF,omegavis,gvis,QIRsQREF,omegair,gir
+      use radcommon_h, only: qrefvis,qrefir,omegarefvis,omegarefir
+      use radcommon_h, only: radiustab,nsize
+
+      implicit none
+
+!     =============================================================
+!     Aerosol Optical Properties
+!
+!     Description:
+!       Compute the scattering parameters in each grid
+!       box, depending on aerosol grain sizes. Log-normal size
+!       distribution and Gauss-Legendre integration are used.
+
+!     Parameters:
+!       Don't forget to set the value of varyingnueff below; If
+!       the effective variance of the distribution for the given
+!       aerosol is considered homogeneous in the atmosphere, please
+!       set varyingnueff(iaer) to .false. Resulting computational
+!       time will be much better.
+
+!     Authors: J.-B. Madeleine, F. Forget, F. Montmessin
+!     Slightly modified and converted to F90 by R. Wordsworth (2009)
+!     Varying nueff section removed by R. Wordsworth for simplicity
+!     ==============================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+
+!     Local variables 
+!     ---------------
+
+
+
+!     =============================================================
+      LOGICAL, PARAMETER :: varyingnueff(naerkind) = .false.
+!     =============================================================
+
+!     Min. and max radius of the interpolation grid (in METERS)
+      REAL, PARAMETER :: refftabmin = 2e-8 !2e-8
+!      REAL, PARAMETER :: refftabmax = 35e-6
+      REAL, PARAMETER :: refftabmax = 1e-3
+!     Log of the min and max variance of the interpolation grid
+      REAL, PARAMETER :: nuefftabmin = -4.6
+      REAL, PARAMETER :: nuefftabmax = 0.
+!     Number of effective radius of the interpolation grid
+      INTEGER, PARAMETER :: refftabsize = 200
+!     Number of effective variances of the interpolation grid
+!      INTEGER, PARAMETER :: nuefftabsize = 100
+      INTEGER, PARAMETER :: nuefftabsize = 1
+!     Interpolation grid indices (reff,nueff)
+      INTEGER :: grid_i,grid_j
+!     Intermediate variable
+      REAL :: var_tmp,var3d_tmp(ngrid,nlayermx)
+!     Bilinear interpolation factors
+      REAL :: kx,ky,k1,k2,k3,k4
+!     Size distribution parameters
+      REAL :: sizedistk1,sizedistk2
+!     Pi!
+      REAL,SAVE :: pi
+!     Variables used by the Gauss-Legendre integration:
+      INTEGER radius_id,gausind
+      REAL kint
+      REAL drad
+      INTEGER, PARAMETER :: ngau = 10
+      REAL weightgaus(ngau),radgaus(ngau)
+      SAVE weightgaus,radgaus
+!      DATA weightgaus/.2955242247,.2692667193,.2190863625,.1494513491,.0666713443/
+!      DATA radgaus/.1488743389,.4333953941,.6794095682,.8650633666,.9739065285/
+      DATA    radgaus/0.07652652113350,0.22778585114165, &
+                      0.37370608871528,0.51086700195146, &
+                      0.63605368072468,0.74633190646476, &
+                      0.83911697181213,0.91223442826796, &
+                      0.96397192726078,0.99312859919241/
+
+      DATA weightgaus/0.15275338723120,0.14917298659407, &
+                      0.14209610937519,0.13168863843930, &
+                      0.11819453196154,0.10193011980823, &
+                      0.08327674160932,0.06267204829828, &
+                      0.04060142982019,0.01761400714091/
+!     Indices
+      INTEGER :: i,j,k,l,m,iaer,idomain
+      INTEGER :: ig,lg,chg
+
+!     Local saved variables
+!     ---------------------
+
+!     Radius axis of the interpolation grid
+      REAL,SAVE :: refftab(refftabsize)
+!     Variance axis of the interpolation grid
+      REAL,SAVE :: nuefftab(nuefftabsize)
+!     Volume ratio of the grid
+      REAL,SAVE :: logvratgrid,vratgrid
+!     Grid used to remember which calculation is done
+      LOGICAL,SAVE :: checkgrid(refftabsize,nuefftabsize,naerkind,2) = .false.
+!     Optical properties of the grid (VISIBLE)
+      REAL,SAVE :: qsqrefVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)
+      REAL,SAVE :: qextVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)
+      REAL,SAVE :: qscatVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)
+      REAL,SAVE :: omegVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)
+      REAL,SAVE :: gVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)
+!     Optical properties of the grid (INFRARED)
+      REAL,SAVE :: qsqrefIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)
+      REAL,SAVE :: qextIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)
+      REAL,SAVE :: qscatIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)
+      REAL,SAVE :: omegIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)
+      REAL,SAVE :: gIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)
+!     Optical properties of the grid (REFERENCE WAVELENGTHS)
+      REAL,SAVE :: qrefVISgrid(refftabsize,nuefftabsize,naerkind)
+      REAL,SAVE :: qscatrefVISgrid(refftabsize,nuefftabsize,naerkind)
+      REAL,SAVE :: qrefIRgrid(refftabsize,nuefftabsize,naerkind)
+      REAL,SAVE :: qscatrefIRgrid(refftabsize,nuefftabsize,naerkind)
+      REAL,SAVE :: omegrefVISgrid(refftabsize,nuefftabsize,naerkind)
+      REAL,SAVE :: omegrefIRgrid(refftabsize,nuefftabsize,naerkind)
+!     Firstcall
+      LOGICAL,SAVE :: firstcall = .true.
+!     Variables used by the Gauss-Legendre integration:
+      REAL,SAVE :: normd(refftabsize,nuefftabsize,naerkind,2)
+      REAL,SAVE :: dista(refftabsize,nuefftabsize,naerkind,2,ngau)
+      REAL,SAVE :: distb(refftabsize,nuefftabsize,naerkind,2,ngau)
+
+      REAL,SAVE :: radGAUSa(ngau,naerkind,2)
+      REAL,SAVE :: radGAUSb(ngau,naerkind,2)
+
+      REAL,SAVE :: qsqrefVISa(L_NSPECTV,ngau,naerkind)
+      REAL,SAVE :: qrefVISa(ngau,naerkind)
+      REAL,SAVE :: qsqrefVISb(L_NSPECTV,ngau,naerkind)
+      REAL,SAVE :: qrefVISb(ngau,naerkind)
+      REAL,SAVE :: omegVISa(L_NSPECTV,ngau,naerkind)
+      REAL,SAVE :: omegrefVISa(ngau,naerkind)
+      REAL,SAVE :: omegVISb(L_NSPECTV,ngau,naerkind)
+      REAL,SAVE :: omegrefVISb(ngau,naerkind)
+      REAL,SAVE :: gVISa(L_NSPECTV,ngau,naerkind)
+      REAL,SAVE :: gVISb(L_NSPECTV,ngau,naerkind)
+
+      REAL,SAVE :: qsqrefIRa(L_NSPECTI,ngau,naerkind)
+      REAL,SAVE :: qrefIRa(ngau,naerkind)
+      REAL,SAVE :: qsqrefIRb(L_NSPECTI,ngau,naerkind)
+      REAL,SAVE :: qrefIRb(ngau,naerkind)
+      REAL,SAVE :: omegIRa(L_NSPECTI,ngau,naerkind)
+      REAL,SAVE :: omegrefIRa(ngau,naerkind)
+      REAL,SAVE :: omegIRb(L_NSPECTI,ngau,naerkind)
+      REAL,SAVE :: omegrefIRb(ngau,naerkind)
+      REAL,SAVE :: gIRa(L_NSPECTI,ngau,naerkind)
+      REAL,SAVE :: gIRb(L_NSPECTI,ngau,naerkind)
+
+      REAL :: radiusm
+      REAL :: radiusr
+
+!     Inputs
+!     ------
+
+      INTEGER :: ngrid,nlayer
+!     Aerosol effective radius used for radiative transfer (meter)
+      REAL :: reffrad(ngrid,nlayermx,naerkind)
+!     Aerosol effective variance used for radiative transfer (n.u.)
+      REAL :: nueffrad(ngrid,nlayermx,naerkind)
+
+!     Outputs
+!     -------
+
+      REAL :: QVISsQREF3d(ngrid,nlayermx,L_NSPECTV,naerkind)
+      REAL :: omegaVIS3d(ngrid,nlayermx,L_NSPECTV,naerkind)
+      REAL :: gVIS3d(ngrid,nlayermx,L_NSPECTV,naerkind)
+
+      REAL :: QIRsQREF3d(ngrid,nlayermx,L_NSPECTI,naerkind)
+      REAL :: omegaIR3d(ngrid,nlayermx,L_NSPECTI,naerkind)
+      REAL :: gIR3d(ngrid,nlayermx,L_NSPECTI,naerkind)
+
+      REAL :: QREFvis3d(ngrid,nlayermx,naerkind)
+      REAL :: QREFir3d(ngrid,nlayermx,naerkind)
+
+      REAL :: omegaREFvis3d(ngrid,nlayermx,naerkind)
+      REAL :: omegaREFir3d(ngrid,nlayermx,naerkind)
+
+      DO iaer = 1, naerkind ! Loop on aerosol kind
+        IF ( (nsize(iaer,1).EQ.1).AND.(nsize(iaer,2).EQ.1) ) THEN
+!==================================================================
+!       If there is one single particle size, optical
+!         properties of the considered aerosol are homogeneous
+          DO lg = 1, nlayer
+            DO ig = 1, ngrid
+              DO chg = 1, L_NSPECTV
+                QVISsQREF3d(ig,lg,chg,iaer)=QVISsQREF(chg,iaer,1)
+                omegaVIS3d(ig,lg,chg,iaer)=omegaVIS(chg,iaer,1)
+                gVIS3d(ig,lg,chg,iaer)=gVIS(chg,iaer,1)
+              ENDDO
+              DO chg = 1, L_NSPECTI
+                QIRsQREF3d(ig,lg,chg,iaer)=QIRsQREF(chg,iaer,1)
+                omegaIR3d(ig,lg,chg,iaer)=omegaIR(chg,iaer,1)
+                gIR3d(ig,lg,chg,iaer)=gIR(chg,iaer,1)
+              ENDDO
+              QREFvis3d(ig,lg,iaer)=QREFvis(iaer,1)
+              QREFir3d(ig,lg,iaer)=QREFir(iaer,1)
+              omegaREFvis3d(ig,lg,iaer)=omegaREFvis(iaer,1)
+              omegaREFir3d(ig,lg,iaer)=omegaREFir(iaer,1)
+            ENDDO
+          ENDDO
+
+
+          if (firstcall) then
+             print*,'Optical prop. of the aerosol are homogenous for:'
+             print*,'iaer = ',iaer
+          endif
+
+        ELSE ! Varying effective radius and variance
+      DO idomain = 1, 2 ! Loop on visible or infrared channel
+!==================================================================
+!     1. Creating the effective radius and variance grid
+!     --------------------------------------------------
+      IF (firstcall) THEN
+
+!       1.1 Pi!
+        pi = 2. * asin(1.e0)
+
+!       1.2 Effective radius
+        refftab(1)    = refftabmin
+        refftab(refftabsize) = refftabmax
+
+        logvratgrid = log(refftabmax/refftabmin) / float(refftabsize-1)*3.
+        vratgrid = exp(logvratgrid)
+
+        do i = 2, refftabsize-1
+          refftab(i) = refftab(i-1)*vratgrid**(1./3.)
+        enddo
+
+!       1.3 Effective variance
+        if(nuefftabsize.eq.1)then ! addded by RDW
+           print*,'Warning: no variance range in aeroptproperties'
+           nuefftab(1)=0.2
+        else
+           do i = 0, nuefftabsize-1
+              nuefftab(i+1) = exp( nuefftabmin + i*(nuefftabmax-nuefftabmin)/(nuefftabsize-1) )
+           enddo
+        endif
+
+        firstcall = .false.
+      ENDIF
+
+!       1.4 Radius middle point and range for Gauss integration
+        radiusm=0.5*(radiustab(iaer,idomain,nsize(iaer,idomain)) + radiustab(iaer,idomain,1))
+        radiusr=0.5*(radiustab(iaer,idomain,nsize(iaer,idomain)) - radiustab(iaer,idomain,1))
+
+!       1.5 Interpolating data at the Gauss quadrature points:
+        DO gausind=1,ngau
+          drad=radiusr*radgaus(gausind)
+          radGAUSa(gausind,iaer,idomain)=radiusm-drad
+
+          radius_id=minloc(abs(radiustab(iaer,idomain,:) - (radiusm-drad)),DIM=1)
+          IF ((radiustab(iaer,idomain,radius_id) - (radiusm-drad)).GT.0) THEN
+            radius_id=radius_id-1
+          ENDIF
+          IF (radius_id.GE.nsize(iaer,idomain)) THEN
+            radius_id=nsize(iaer,idomain)-1
+            kint = 1.
+          ELSEIF (radius_id.LT.1) THEN
+            radius_id=1
+            kint = 0.
+          ELSE
+          kint = ( (radiusm-drad) -				&
+                   radiustab(iaer,idomain,radius_id) ) /	&
+                 ( radiustab(iaer,idomain,radius_id+1) -	&
+                   radiustab(iaer,idomain,radius_id) )
+          ENDIF
+          IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN -----------------
+            DO m=1,L_NSPECTV
+               qsqrefVISa(m,gausind,iaer)=                      &
+                    (1-kint)*QVISsQREF(m,iaer,radius_id) +      &
+                    kint*QVISsQREF(m,iaer,radius_id+1)
+            omegVISa(m,gausind,iaer)=                           &
+                    (1-kint)*omegaVIS(m,iaer,radius_id) +       &
+                    kint*omegaVIS(m,iaer,radius_id+1)
+            gVISa(m,gausind,iaer)=                              &
+                    (1-kint)*gVIS(m,iaer,radius_id) +           &
+                    kint*gVIS(m,iaer,radius_id+1)
+            ENDDO
+            qrefVISa(gausind,iaer)=                             &
+                    (1-kint)*QREFvis(iaer,radius_id) +          &
+                    kint*QREFvis(iaer,radius_id+1)
+            omegrefVISa(gausind,iaer)=                          &
+                    (1-kint)*omegaREFvis(iaer,radius_id) +      &
+                    kint*omegaREFvis(iaer,radius_id+1)
+          ELSE ! INFRARED DOMAIN ----------------------------------
+            DO m=1,L_NSPECTI
+            qsqrefIRa(m,gausind,iaer)=                          &
+                    (1-kint)*QIRsQREF(m,iaer,radius_id) +       &
+                    kint*QIRsQREF(m,iaer,radius_id+1)
+            omegIRa(m,gausind,iaer)=                            &
+                    (1-kint)*omegaIR(m,iaer,radius_id) +        &
+                    kint*omegaIR(m,iaer,radius_id+1)
+            gIRa(m,gausind,iaer)=                               &
+                    (1-kint)*gIR(m,iaer,radius_id) +            &
+                    kint*gIR(m,iaer,radius_id+1)
+            ENDDO
+            qrefIRa(gausind,iaer)=                              &
+                    (1-kint)*QREFir(iaer,radius_id) +           &
+                    kint*QREFir(iaer,radius_id+1)
+            omegrefIRa(gausind,iaer)=                           &
+                    (1-kint)*omegaREFir(iaer,radius_id) +       &
+                    kint*omegaREFir(iaer,radius_id+1)
+          ENDIF
+        ENDDO
+
+        DO gausind=1,ngau
+          drad=radiusr*radgaus(gausind)
+          radGAUSb(gausind,iaer,idomain)=radiusm+drad
+
+          radius_id=minloc(abs(radiustab(iaer,idomain,:) -      &
+                               (radiusm+drad)),DIM=1)
+          IF ((radiustab(iaer,idomain,radius_id) -              &
+               (radiusm+drad)).GT.0) THEN
+            radius_id=radius_id-1
+          ENDIF
+          IF (radius_id.GE.nsize(iaer,idomain)) THEN
+            radius_id=nsize(iaer,idomain)-1
+            kint = 1.
+          ELSEIF (radius_id.LT.1) THEN
+            radius_id=1
+            kint = 0.
+          ELSE
+            kint = ( (radiusm+drad) -                           &
+                     radiustab(iaer,idomain,radius_id) ) /      &
+                   ( radiustab(iaer,idomain,radius_id+1) -      &
+                     radiustab(iaer,idomain,radius_id) )
+          ENDIF
+          IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN -----------------
+            DO m=1,L_NSPECTV
+            qsqrefVISb(m,gausind,iaer)=                         &
+                    (1-kint)*QVISsQREF(m,iaer,radius_id) +      &
+                    kint*QVISsQREF(m,iaer,radius_id+1)    
+            omegVISb(m,gausind,iaer)=                           &
+                    (1-kint)*omegaVIS(m,iaer,radius_id) +       &
+                    kint*omegaVIS(m,iaer,radius_id+1)
+            gVISb(m,gausind,iaer)=                              &
+                    (1-kint)*gVIS(m,iaer,radius_id) +           &
+                    kint*gVIS(m,iaer,radius_id+1)
+            ENDDO
+            qrefVISb(gausind,iaer)=                             &
+                    (1-kint)*QREFvis(iaer,radius_id) +          &
+                    kint*QREFvis(iaer,radius_id+1)
+            omegrefVISb(gausind,iaer)=                          &
+                    (1-kint)*omegaREFvis(iaer,radius_id) +      &
+                    kint*omegaREFvis(iaer,radius_id+1)
+          ELSE ! INFRARED DOMAIN ----------------------------------
+            DO m=1,L_NSPECTI
+            qsqrefIRb(m,gausind,iaer)=                          &
+                    (1-kint)*QIRsQREF(m,iaer,radius_id) +       &
+                    kint*QIRsQREF(m,iaer,radius_id+1)
+            omegIRb(m,gausind,iaer)=                            &
+                    (1-kint)*omegaIR(m,iaer,radius_id) +        &
+                    kint*omegaIR(m,iaer,radius_id+1)
+            gIRb(m,gausind,iaer)=                               &
+                    (1-kint)*gIR(m,iaer,radius_id) +            &
+                    kint*gIR(m,iaer,radius_id+1)
+            ENDDO
+            qrefIRb(gausind,iaer)=                              &
+                    (1-kint)*QREFir(iaer,radius_id) +           &
+                    kint*QREFir(iaer,radius_id+1)
+            omegrefIRb(gausind,iaer)=                           &
+                    (1-kint)*omegaREFir(iaer,radius_id) +       &
+                    kint*omegaREFir(iaer,radius_id+1)
+          ENDIF
+        ENDDO
+
+!==================================================================
+! CONSTANT NUEFF FROM HERE
+!==================================================================
+
+!     2. Compute the scattering parameters using linear
+!       interpolation over grain sizes and constant nueff
+!     ---------------------------------------------------
+
+      DO lg = 1,nlayer
+        DO ig = 1, ngrid
+!         2.1 Effective radius index and kx calculation
+          var_tmp=reffrad(ig,lg,iaer)/refftabmin
+          var_tmp=log(var_tmp)*3.
+          var_tmp=var_tmp/logvratgrid+1.
+          grid_i=floor(var_tmp)
+          IF (grid_i.GE.refftabsize) THEN
+!           WRITE(*,*) 'Warning: particle size in grid box #'
+!           WRITE(*,*) ig,' is too large to be used by the '
+!           WRITE(*,*) 'radiative transfer; please extend the '
+!           WRITE(*,*) 'interpolation grid to larger grain sizes.'
+            grid_i=refftabsize-1
+            kx = 1.
+          ELSEIF (grid_i.LT.1) THEN
+!           WRITE(*,*) 'Warning: particle size in grid box #'
+!           WRITE(*,*) ig,' is too small to be used by the '
+!           WRITE(*,*) 'radiative transfer; please extend the '
+!           WRITE(*,*) 'interpolation grid to smaller grain sizes.'
+            grid_i=1
+            kx = 0.
+          ELSE
+            kx = ( reffrad(ig,lg,iaer)-refftab(grid_i) ) /            &
+                 ( refftab(grid_i+1)-refftab(grid_i) )
+          ENDIF
+!         2.3 Integration
+          DO j=grid_i,grid_i+1
+!             2.3.1 Check if the calculation has been done
+              IF (.NOT.checkgrid(j,1,iaer,idomain)) THEN
+!               2.3.2 Log-normal dist., r_g and sigma_g are defined
+!                 in [hansen_1974], "Light scattering in planetary
+!                 atmospheres", Space Science Reviews 16 527-610.
+!                 Here, sizedistk1=r_g and sizedistk2=sigma_g^2
+                sizedistk2 = log(1.+nueffrad(1,1,iaer))
+                sizedistk1 = exp(2.5*sizedistk2)
+                sizedistk1 = refftab(j) / sizedistk1
+
+                normd(j,1,iaer,idomain) = 1e-30
+                DO gausind=1,ngau
+                  drad=radiusr*radgaus(gausind)
+                  dista(j,1,iaer,idomain,gausind) = LOG((radiusm-drad)/sizedistk1)
+                  dista(j,1,iaer,idomain,gausind) =                   &
+                    EXP(-dista(j,1,iaer,idomain,gausind) *            &
+                    dista(j,1,iaer,idomain,gausind) *                 &
+                    0.5e0/sizedistk2)/(radiusm-drad)                  
+                  dista(j,1,iaer,idomain,gausind) =                   &
+                    dista(j,1,iaer,idomain,gausind) /                 &
+                    (sqrt(2e0*pi*sizedistk2))
+
+                  distb(j,1,iaer,idomain,gausind) = LOG((radiusm+drad)/sizedistk1)
+                  distb(j,1,iaer,idomain,gausind) =                   &
+                    EXP(-distb(j,1,iaer,idomain,gausind) *            &
+                    distb(j,1,iaer,idomain,gausind) *                 &
+                    0.5e0/sizedistk2)/(radiusm+drad)
+                  distb(j,1,iaer,idomain,gausind) =                   &
+                    distb(j,1,iaer,idomain,gausind) /                 &
+                    (sqrt(2e0*pi*sizedistk2))
+
+                  normd(j,1,iaer,idomain)=normd(j,1,iaer,idomain) +   &
+                    weightgaus(gausind) *                             &
+                    (                                                 &
+                    distb(j,1,iaer,idomain,gausind) * pi *            &
+                    radGAUSb(gausind,iaer,idomain) *                  &
+                    radGAUSb(gausind,iaer,idomain) +                  &
+                    dista(j,1,iaer,idomain,gausind) * pi *            &
+                    radGAUSa(gausind,iaer,idomain) *                  &
+                    radGAUSa(gausind,iaer,idomain)                    &
+                    )
+                ENDDO
+                IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN -----------
+!                 2.3.3.vis Initialization
+                  qsqrefVISgrid(j,1,:,iaer)=0.
+                  qextVISgrid(j,1,:,iaer)=0.
+                  qscatVISgrid(j,1,:,iaer)=0.
+                  omegVISgrid(j,1,:,iaer)=0.
+                  gVISgrid(j,1,:,iaer)=0.
+                  qrefVISgrid(j,1,iaer)=0.
+                  qscatrefVISgrid(j,1,iaer)=0.
+                  omegrefVISgrid(j,1,iaer)=0.
+
+                  DO gausind=1,ngau
+                    DO m=1,L_NSPECTV
+!                     Convolution:
+                      qextVISgrid(j,1,m,iaer) =              &
+                        qextVISgrid(j,1,m,iaer) +            & 
+                        weightgaus(gausind) *                &
+                        (                                    &
+                        qsqrefVISb(m,gausind,iaer) *         &
+                        qrefVISb(gausind,iaer) *             &
+                        pi*radGAUSb(gausind,iaer,idomain) *  &
+                        radGAUSb(gausind,iaer,idomain) *     &
+                        distb(j,1,iaer,idomain,gausind) +    &
+                        qsqrefVISa(m,gausind,iaer) *         &
+                        qrefVISa(gausind,iaer) *             &
+                        pi*radGAUSa(gausind,iaer,idomain) *  &
+                        radGAUSa(gausind,iaer,idomain) *     &
+                        dista(j,1,iaer,idomain,gausind)      &
+                        )
+                      qscatVISgrid(j,1,m,iaer) =             &
+                        qscatVISgrid(j,1,m,iaer) +           &
+                        weightgaus(gausind) *                &
+                        (                                    &
+                        omegVISb(m,gausind,iaer) *           &
+                        qsqrefVISb(m,gausind,iaer) *         &
+                        qrefVISb(gausind,iaer) *             &
+                        pi*radGAUSb(gausind,iaer,idomain) *  &
+                        radGAUSb(gausind,iaer,idomain) *     &
+                        distb(j,1,iaer,idomain,gausind) +    &
+                        omegVISa(m,gausind,iaer) *           &
+                        qsqrefVISa(m,gausind,iaer) *         &
+                        qrefVISa(gausind,iaer) *             &
+                        pi*radGAUSa(gausind,iaer,idomain) *  &
+                        radGAUSa(gausind,iaer,idomain) *     &
+                        dista(j,1,iaer,idomain,gausind)      &
+                        )
+                      gVISgrid(j,1,m,iaer) =                 &
+                        gVISgrid(j,1,m,iaer) +               &
+                        weightgaus(gausind) *                &
+                        (                                    &
+                        omegVISb(m,gausind,iaer) *           &
+                        qsqrefVISb(m,gausind,iaer) *         &
+                        qrefVISb(gausind,iaer) *             &
+                        gVISb(m,gausind,iaer) *              &
+                        pi*radGAUSb(gausind,iaer,idomain) *  &
+                        radGAUSb(gausind,iaer,idomain) *     &
+                        distb(j,1,iaer,idomain,gausind) +    &
+                        omegVISa(m,gausind,iaer) *           &
+                        qsqrefVISa(m,gausind,iaer) *         &
+                        qrefVISa(gausind,iaer) *             &
+                        gVISa(m,gausind,iaer) *              &
+                        pi*radGAUSa(gausind,iaer,idomain) *  &
+                        radGAUSa(gausind,iaer,idomain) *     &
+                        dista(j,1,iaer,idomain,gausind)      &
+                        )
+                    ENDDO
+                    qrefVISgrid(j,1,iaer) =                  &
+                      qrefVISgrid(j,1,iaer) +                &
+                      weightgaus(gausind) *                  &
+                      (                                      &
+                      qrefVISb(gausind,iaer) *               &
+                      pi*radGAUSb(gausind,iaer,idomain) *    &
+                      radGAUSb(gausind,iaer,idomain) *       &
+                      distb(j,1,iaer,idomain,gausind) +      &
+                      qrefVISa(gausind,iaer) *               &
+                      pi*radGAUSa(gausind,iaer,idomain) *    &
+                      radGAUSa(gausind,iaer,idomain) *       &
+                      dista(j,1,iaer,idomain,gausind)        &
+                      )
+                    qscatrefVISgrid(j,1,iaer) =              &
+                      qscatrefVISgrid(j,1,iaer) +            &
+                      weightgaus(gausind) *                  &
+                      (                                      &
+                      omegrefVISb(gausind,iaer) *            &
+                      qrefVISb(gausind,iaer) *               & 
+                      pi*radGAUSb(gausind,iaer,idomain) *    &
+                      radGAUSb(gausind,iaer,idomain) *       &
+                      distb(j,1,iaer,idomain,gausind) +      &
+                      omegrefVISa(gausind,iaer) *            &
+                      qrefVISa(gausind,iaer) *               &
+                      pi*radGAUSa(gausind,iaer,idomain) *    &
+                      radGAUSa(gausind,iaer,idomain) *       &
+                      dista(j,1,iaer,idomain,gausind)        &
+                      )
+                  ENDDO
+
+                  qrefVISgrid(j,1,iaer)=qrefVISgrid(j,1,iaer) /          &
+                                normd(j,1,iaer,idomain)       
+                  qscatrefVISgrid(j,1,iaer)=qscatrefVISgrid(j,1,iaer) /  &
+                                normd(j,1,iaer,idomain)
+                  omegrefVISgrid(j,1,iaer)=qscatrefVISgrid(j,1,iaer) /   &
+                               qrefVISgrid(j,1,iaer)
+                  DO m=1,L_NSPECTV
+                    qextVISgrid(j,1,m,iaer)=qextVISgrid(j,1,m,iaer) /    &
+                                normd(j,1,iaer,idomain)
+                    qscatVISgrid(j,1,m,iaer)=qscatVISgrid(j,1,m,iaer) /  &
+                                normd(j,1,iaer,idomain)
+                    gVISgrid(j,1,m,iaer)=gVISgrid(j,1,m,iaer) /          &
+                                qscatVISgrid(j,1,m,iaer) /               &
+                                normd(j,1,iaer,idomain)
+
+                    qsqrefVISgrid(j,1,m,iaer)=qextVISgrid(j,1,m,iaer) /  &
+                                qrefVISgrid(j,1,iaer)
+                    omegVISgrid(j,1,m,iaer)=qscatVISgrid(j,1,m,iaer) /   &
+                                qextVISgrid(j,1,m,iaer)
+                  ENDDO
+                ELSE                   ! INFRARED DOMAIN ----------
+!                 2.3.3.ir Initialization
+                  qsqrefIRgrid(j,1,:,iaer)=0.
+                  qextIRgrid(j,1,:,iaer)=0.
+                  qscatIRgrid(j,1,:,iaer)=0.
+                  omegIRgrid(j,1,:,iaer)=0.
+                  gIRgrid(j,1,:,iaer)=0.
+                  qrefIRgrid(j,1,iaer)=0.
+                  qscatrefIRgrid(j,1,iaer)=0.
+                  omegrefIRgrid(j,1,iaer)=0.
+
+                  DO gausind=1,ngau
+                    DO m=1,L_NSPECTI
+!                     Convolution:
+                      qextIRgrid(j,1,m,iaer) =                  &
+                        qextIRgrid(j,1,m,iaer) +                &
+                        weightgaus(gausind) *                   &
+                        (                                       &
+                        qsqrefIRb(m,gausind,iaer) *             &
+                        qrefVISb(gausind,iaer) *                &
+                        pi*radGAUSb(gausind,iaer,idomain) *     &
+                        radGAUSb(gausind,iaer,idomain) *        &
+                        distb(j,1,iaer,idomain,gausind) +       &
+                        qsqrefIRa(m,gausind,iaer) *             &
+                        qrefVISa(gausind,iaer) *                &
+                        pi*radGAUSa(gausind,iaer,idomain) *     &
+                        radGAUSa(gausind,iaer,idomain) *        &
+                        dista(j,1,iaer,idomain,gausind)         &
+                        )
+                      qscatIRgrid(j,1,m,iaer) =                 &
+                        qscatIRgrid(j,1,m,iaer) +               &
+                        weightgaus(gausind) *                   &
+                        (                                       &
+                        omegIRb(m,gausind,iaer) *               &
+                        qsqrefIRb(m,gausind,iaer) *             &
+                        qrefVISb(gausind,iaer) *                &
+                        pi*radGAUSb(gausind,iaer,idomain) *     &
+                        radGAUSb(gausind,iaer,idomain) *        &
+                        distb(j,1,iaer,idomain,gausind) +       &
+                        omegIRa(m,gausind,iaer) *               &
+                        qsqrefIRa(m,gausind,iaer) *             &
+                        qrefVISa(gausind,iaer) *                &
+                        pi*radGAUSa(gausind,iaer,idomain) *     &
+                        radGAUSa(gausind,iaer,idomain) *        &
+                        dista(j,1,iaer,idomain,gausind)         &
+                        )
+                      gIRgrid(j,1,m,iaer) =                     &
+                        gIRgrid(j,1,m,iaer) +                   &
+                        weightgaus(gausind) *                   &
+                        (                                       &
+                        omegIRb(m,gausind,iaer) *               &
+                        qsqrefIRb(m,gausind,iaer) *             &
+                        qrefVISb(gausind,iaer) *                &
+                        gIRb(m,gausind,iaer) *                  &
+                        pi*radGAUSb(gausind,iaer,idomain) *     &
+                        radGAUSb(gausind,iaer,idomain) *        &
+                        distb(j,1,iaer,idomain,gausind) +       &
+                        omegIRa(m,gausind,iaer) *               &
+                        qsqrefIRa(m,gausind,iaer) *             &
+                        qrefVISa(gausind,iaer) *                &
+                        gIRa(m,gausind,iaer) *                  &
+                        pi*radGAUSa(gausind,iaer,idomain) *     &
+                        radGAUSa(gausind,iaer,idomain) *        &
+                        dista(j,1,iaer,idomain,gausind)         &
+                        )
+                    ENDDO
+                    qrefIRgrid(j,1,iaer) =                      &
+                      qrefIRgrid(j,1,iaer) +                    &
+                      weightgaus(gausind) *                     &
+                      (                                         &
+                      qrefIRb(gausind,iaer) *                   &
+                      pi*radGAUSb(gausind,iaer,idomain) *       &
+                      radGAUSb(gausind,iaer,idomain) *          &
+                      distb(j,1,iaer,idomain,gausind) +         &
+                      qrefIRa(gausind,iaer) *                   &
+                      pi*radGAUSa(gausind,iaer,idomain) *       &
+                      radGAUSa(gausind,iaer,idomain) *          &
+                      dista(j,1,iaer,idomain,gausind)           &
+                      )
+                    qscatrefIRgrid(j,1,iaer) =                  &
+                      qscatrefIRgrid(j,1,iaer) +                &
+                      weightgaus(gausind) *                     &
+                      (                                         &
+                      omegrefIRb(gausind,iaer) *                &
+                      qrefIRb(gausind,iaer) *                   &
+                      pi*radGAUSb(gausind,iaer,idomain) *       &
+                      radGAUSb(gausind,iaer,idomain) *          &
+                      distb(j,1,iaer,idomain,gausind) +         &
+                      omegrefIRa(gausind,iaer) *                &
+                      qrefIRa(gausind,iaer) *                   &
+                      pi*radGAUSa(gausind,iaer,idomain) *       &
+                      radGAUSa(gausind,iaer,idomain) *          &
+                      dista(j,1,iaer,idomain,gausind)           &
+                      )
+                  ENDDO
+ 
+                  qrefIRgrid(j,1,iaer)=qrefIRgrid(j,1,iaer) /          &
+                                normd(j,1,iaer,idomain)
+                  qscatrefIRgrid(j,1,iaer)=qscatrefIRgrid(j,1,iaer) /  &
+                                normd(j,1,iaer,idomain)
+                  omegrefIRgrid(j,1,iaer)=qscatrefIRgrid(j,1,iaer) /   &
+                               qrefIRgrid(j,1,iaer)
+                  DO m=1,L_NSPECTI
+                    qextIRgrid(j,1,m,iaer)=qextIRgrid(j,1,m,iaer) /    &
+                                normd(j,1,iaer,idomain)
+                    qscatIRgrid(j,1,m,iaer)=qscatIRgrid(j,1,m,iaer) /  &
+                                normd(j,1,iaer,idomain)
+                    gIRgrid(j,1,m,iaer)=gIRgrid(j,1,m,iaer) /          &
+                                qscatIRgrid(j,1,m,iaer) /              &
+                                normd(j,1,iaer,idomain)
+
+                    qsqrefIRgrid(j,1,m,iaer)=qextIRgrid(j,1,m,iaer) /  &
+                                qrefVISgrid(j,1,iaer)
+                    omegIRgrid(j,1,m,iaer)=qscatIRgrid(j,1,m,iaer) /   &
+                                qextIRgrid(j,1,m,iaer)
+                  ENDDO
+                ENDIF                  ! --------------------------
+                checkgrid(j,1,iaer,idomain) = .true.
+              ENDIF !checkgrid
+          ENDDO !grid_i
+!         2.4 Linear interpolation
+          k1 = (1-kx)
+          k2 = kx
+          IF (idomain.EQ.1) THEN ! VISIBLE ------------------------
+          DO m=1,L_NSPECTV
+             QVISsQREF3d(ig,lg,m,iaer) =                           &
+                        k1*qsqrefVISgrid(grid_i,1,m,iaer) +        &
+                        k2*qsqrefVISgrid(grid_i+1,1,m,iaer)
+            omegaVIS3d(ig,lg,m,iaer) =                             &
+                        k1*omegVISgrid(grid_i,1,m,iaer) +          &
+                        k2*omegVISgrid(grid_i+1,1,m,iaer)
+            gVIS3d(ig,lg,m,iaer) =                                 &
+                        k1*gVISgrid(grid_i,1,m,iaer) +             &
+                        k2*gVISgrid(grid_i+1,1,m,iaer)
+          ENDDO !L_NSPECTV
+          QREFvis3d(ig,lg,iaer) =                                  &
+                        k1*qrefVISgrid(grid_i,1,iaer) +            &
+                        k2*qrefVISgrid(grid_i+1,1,iaer)
+          omegaREFvis3d(ig,lg,iaer) =                              &
+                        k1*omegrefVISgrid(grid_i,1,iaer) +         &
+                        k2*omegrefVISgrid(grid_i+1,1,iaer)
+          ELSE                   ! INFRARED -----------------------
+          DO m=1,L_NSPECTI
+            QIRsQREF3d(ig,lg,m,iaer) =                             &
+                        k1*qsqrefIRgrid(grid_i,1,m,iaer) +         &
+                        k2*qsqrefIRgrid(grid_i+1,1,m,iaer)
+            omegaIR3d(ig,lg,m,iaer) =                              &
+                        k1*omegIRgrid(grid_i,1,m,iaer) +           &
+                        k2*omegIRgrid(grid_i+1,1,m,iaer) 
+            gIR3d(ig,lg,m,iaer) =                                  & 
+                        k1*gIRgrid(grid_i,1,m,iaer) +              &
+                        k2*gIRgrid(grid_i+1,1,m,iaer)
+          ENDDO !L_NSPECTI
+          QREFir3d(ig,lg,iaer) =                                   &
+                        k1*qrefIRgrid(grid_i,1,iaer) +             &
+                        k2*qrefIRgrid(grid_i+1,1,iaer)
+          omegaREFir3d(ig,lg,iaer) =                               &
+                        k1*omegrefIRgrid(grid_i,1,iaer) +          &
+                        k2*omegrefIRgrid(grid_i+1,1,iaer)
+          ENDIF                  ! --------------------------------
+        ENDDO !nlayermx
+      ENDDO !ngrid
+
+!==================================================================
+
+
+
+      ENDDO ! idomain
+
+      ENDIF ! nsize = 1
+
+      ENDDO ! iaer (loop on aerosol kind)
+
+      RETURN
+    END SUBROUTINE aeroptproperties
+
+
+
+      
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerosol_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerosol_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/aerosol_mod.F90	(revision 222)
@@ -0,0 +1,21 @@
+!==================================================================
+module aerosol_mod
+implicit none
+save
+!==================================================================
+
+!  aerosol indexes: these are initialized to be 0 if the
+!                 corresponding aerosol was not activated in callphys.def
+!                 -- otherwise a value is given in iniaerosol
+      integer :: iaero_co2 = 0 
+      integer :: iaero_h2o = 0
+      integer :: iaero_dust = 0
+      integer :: iaero_h2so4 = 0
+      logical :: noaero = .false.
+
+! two-layer simple aerosol model
+      integer :: iaero_back2lay = 0
+      
+!==================================================================
+end module aerosol_mod
+!==================================================================
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ave_stelspec.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ave_stelspec.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ave_stelspec.F90	(revision 222)
@@ -0,0 +1,179 @@
+      subroutine ave_stelspec(STELLAR)
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Average the chosen high resolution stellar spectrum over the
+!     visible bands in the model.
+!     
+!     Authors
+!     ------- 
+!     Robin Wordsworth (2010).
+!     Generalized to very late spectral types (and Brown dwarfs) Jeremy Leconte (2012)
+!
+!     Called by
+!     ---------
+!     setspv.F
+!     
+!     Calls
+!     -----
+!     none
+!     
+!==================================================================
+
+      use radinc_h, only: L_NSPECTV
+      use radcommon_h, only: BWNV, DWNV, tstellar
+      use datafile_mod, only: datadir
+
+      implicit none
+
+#include "callkeys.h"
+
+      real*8 STELLAR(L_NSPECTV)
+!      integer startype 
+
+      integer Nfine
+      integer,parameter :: Nfineband=200
+      integer ifine
+
+      real,allocatable :: lam(:),stel_f(:)
+      real band,lamm,lamp
+      real dl
+
+      character(len=100)  :: file_id,file_id_lam
+      character(len=200) :: file_path,file_path_lam
+
+      real lam_temp
+      double precision stel_temp
+      
+      integer :: ios ! file opening/reading status
+
+      STELLAR(:)=0.0
+
+      print*,'enter ave_stellspec'
+      if(stelbbody)then
+         tstellar=stelTbb
+	 Nfine=L_NSPECTV*Nfineband
+	 do band=1,L_NSPECTV
+	    lamm=10000.0/BWNV(band+1)
+	    lamp=10000.0/BWNV(band)
+	    dl=(lamp-lamm)/(Nfineband)
+	    do ifine=1,Nfineband
+	       lam_temp=lamm+(lamp-lamm)*(ifine-1.)/(Nfineband)
+               call blackl(dble(lam_temp*1e-6),dble(tstellar),stel_temp)
+	       STELLAR(band)=STELLAR(band)+stel_temp*dl
+	    enddo	    
+	 end do
+         STELLAR(1:L_NSPECTV)=STELLAR(1:L_NSPECTV)/sum(STELLAR(1:L_NSPECTV))
+      else
+         ! load high resolution stellar data
+         Select Case(startype)
+	   Case(1)
+            file_id='/stellar_spectra/sol.txt'
+            tstellar=5800.
+            file_id_lam='/stellar_spectra/lam.txt'
+            Nfine=5000
+	   Case(2)
+            file_id='/stellar_spectra/gl581.txt'
+            tstellar=3200.
+            file_id_lam='/stellar_spectra/lam.txt'
+            Nfine=5000
+	   Case(3)
+            file_id='/stellar_spectra/adleo.txt'
+            tstellar=3200.
+            file_id_lam='/stellar_spectra/lam.txt'
+            Nfine=5000
+	   Case(4)
+            file_id='/stellar_spectra/gj644.txt'
+            print*,'Find out tstellar before using this star!'
+            call abort
+            file_id_lam='/stellar_spectra/lam.txt'
+            Nfine=5000
+	   Case(5)
+            file_id='/stellar_spectra/hd128167.txt'
+            tstellar=6700. ! Segura et al. (2003)
+            file_id_lam='/stellar_spectra/lam.txt'
+            Nfine=5000
+	   Case(6)
+            file_id='/stellar_spectra/BD_Teff-1600K.txt'
+            tstellar=1600. 
+            file_id_lam='/stellar_spectra/lamBD.txt'
+            Nfine=5000
+	   Case(7)
+            file_id='/stellar_spectra/BD_Teff-1000K.txt'
+            tstellar=1000. 
+            file_id_lam='/stellar_spectra/lamBD.txt'
+            Nfine=5000
+	   Case(8)
+            file_id='/stellar_spectra/Flux_K5_Teff4700_logg4.5_Met-0.5_BTsettle.dat'
+            tstellar=4700. 
+            file_id_lam='/stellar_spectra/lambda_K5_Teff4700_logg4.5_Met-0.5_BTsettle.dat'
+            Nfine=3986
+	   Case Default
+            print*,'Error: unknown star type chosen'
+            call abort
+         End Select
+
+	 allocate(lam(Nfine),stel_f(Nfine))
+
+         file_path_lam=TRIM(datadir)//TRIM(file_id_lam)
+         open(110,file=file_path_lam,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from ave_stelspec'
+           write(*,*) 'Data file ',trim(file_id_lam),' not found.'
+           write(*,*)'Check that your path to datagcm:',trim(datadir)
+           write(*,*)' is correct. You can change it in callphys.def with:'
+           write(*,*)' datadir = /absolute/path/to/datagcm'
+           write(*,*)' Also check that there is a ',trim(file_id_lam),' there.'
+           call abort
+         else
+           do ifine=1,Nfine
+             read(110,*) lam(ifine)
+           enddo
+           close(110)
+         endif
+
+
+         ! load high resolution wavenumber data
+         file_path=TRIM(datadir)//TRIM(file_id)
+         open(111,file=file_path,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from ave_stelspec'
+           write(*,*) 'Data file ',trim(file_id),' not found.'
+           write(*,*)'Check that your path to datagcm:',trim(datadir)
+           write(*,*)' is correct. You can change it in callphys.def with:'
+           write(*,*)' datadir = /absolute/path/to/datagcm'
+           write(*,*)' Also check that there is a ',trim(file_id),' there.'
+           call abort
+         else
+           do ifine=1,Nfine
+             read(111,*) stel_f(ifine)
+           enddo
+           close(111)
+         endif
+	 
+         ! sum data by band
+         band=1
+	 Do while(lam(1).lt. real(10000.0/BWNV(band+1)))
+	    if (band.gt.L_NSPECTV-1) exit
+            band=band+1
+	 enddo
+	 dl=lam(2)-lam(1)
+         STELLAR(band)=STELLAR(band)+stel_f(1)*dl
+         do ifine = 2,Nfine
+            if(lam(ifine) .gt. real(10000.0/BWNV(band)))then
+               band=band-1
+            endif
+            if(band .lt. 1) exit
+	    dl=lam(ifine)-lam(ifine-1)
+            STELLAR(band)=STELLAR(band)+stel_f(ifine)*dl
+         end do
+	       
+	 
+         STELLAR(1:L_NSPECTV)=STELLAR(1:L_NSPECTV)/sum(STELLAR(1:L_NSPECTV))
+         deallocate(lam,stel_f)
+         
+      endif
+
+      end subroutine ave_stelspec
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bands.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bands.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bands.h	(revision 222)
@@ -0,0 +1,14 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'bands.h'
+!
+!   bands.h contains the visible & infrared bands in the model
+!
+!   NBinfrared = L_NSPECTI in the model
+!   NBvisible  = L_NSPECTV in the model
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: NBinfrared=20
+      INTEGER, parameter :: NBvisible=30
+
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bilinear.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bilinear.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bilinear.F90	(revision 222)
@@ -0,0 +1,18 @@
+!-------------------------------------------------------------------------
+subroutine bilinear(f,f11,f21,f12,f22,x,x1,x2,y,y1,y2)  
+! Used for interpolation of continuum data
+
+  implicit none
+
+  real*8 x,y,x1,x2,y1,y2
+  real*8 f,f11,f12,f21,f22,fA,fB
+
+  ! 1st in x-direction
+  fA=f11*(x2-x)/(x2-x1)+f21*(x-x1)/(x2-x1)
+  fB=f12*(x2-x)/(x2-x1)+f22*(x-x1)/(x2-x1)
+
+  ! then in y-direction
+  f=fA*(y2-y)/(y2-y1)+fB*(y-y1)/(y2-y1)
+
+  return
+end subroutine bilinear
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bilinearbig.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bilinearbig.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/bilinearbig.F90	(revision 222)
@@ -0,0 +1,84 @@
+      subroutine bilinearbig(nX,nY,x_arr,y_arr,f2d_arr,x_in,y_in,f,ind)
+
+!     Necessary for interpolation of continuum data
+!     optimized by A. Spiga 01/2013 
+
+      implicit none
+
+      integer nX,nY,i,j,ind,b
+
+      real*8 x_in,y_in,x1,x2,y1,y2
+      real*8 f,f11,f12,f21,f22,fA,fB
+      real*8 x_arr(nX)
+      real*8 y_arr(nY)
+      real*8 f2d_arr(nX,nY)
+      real*8,save :: x,y
+
+      integer strlen
+      character*100 label
+      label='subroutine bilinear'
+
+
+      x=x_in
+      y=y_in
+
+   !! AS: important to optimize here because the array is quite large
+   !! ... and actually calculations only need to be done once
+   !! IF ind=-9999 we have not calculated yet
+   if ( ind == -9999) then
+      !1st check we're within the wavenumber range
+      if ((x.lt.x_arr(2)).or.(x.gt.x_arr(nX-2))) then
+         ind=-1
+      else
+        i=1
+        x2=x_arr(i)
+        do while ( x2 .le. x )
+          x1=x2
+          i=i+1
+          x2=x_arr(i)
+          ind=i-1
+        end do
+      endif
+   endif
+
+   !! Either we already saw we are out of wavenumber range
+   !! ... and we just have to set f=0 and exit
+   if ( ind == -1) then 
+      f=0.0D+0
+      return
+   !! Or we already determined ind -- so we just proceed
+   else
+      x1=x_arr(ind)
+      x2=x_arr(ind+1)
+   endif
+
+!     ... and for y within the temperature range
+      if ((y.lt.y_arr(1)).or.(y.gt.y_arr(nY))) then
+         write(*,*) 'Warning from bilinearH2H2:'
+         write(*,*) 'Outside continuum temperature range!'
+         if(y.lt.y_arr(1))then
+            y=y_arr(1)+0.01
+         endif
+         if(y.gt.y_arr(nY))then
+            y=y_arr(nY)-0.01
+         endif
+      else
+        j=1
+        y2=y_arr(j)
+        do while ( y2 .le. y )
+          y1=y2
+          j=j+1
+          y2=y_arr(j)
+          b=j-1
+        end do
+      endif
+      
+      f11=f2d_arr(ind,b)
+      f21=f2d_arr(ind+1,b)
+      f12=f2d_arr(ind,b+1)
+      f22=f2d_arr(ind+1,b+1)
+
+      call bilinear(f,f11,f21,f12,f22,x,x1,x2,y,y1,y2)
+
+      return
+    end subroutine bilinearbig
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/blackl.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/blackl.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/blackl.F	(revision 222)
@@ -0,0 +1,21 @@
+      subroutine blackl(blalong,blat,blae)
+
+      implicit double precision (a-h,o-z)
+
+      ! physical constants
+      sigma=5.67032D-8
+      pi=datan(1.d0)*4.d0
+      c0=2.9979d+08
+      h=6.6262d-34
+      cbol=1.3806d-23
+      rind=1.d0
+      c=c0/rind
+      c1=h*(c**2)
+      c2=h*c/cbol
+
+
+      blae=2.d0*pi*c1/blalong**5/(dexp(c2/blalong/blat)-1.d0)
+
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_cpp3d.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_cpp3d.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_cpp3d.F90	(revision 222)
@@ -0,0 +1,33 @@
+      subroutine calc_cpp3d(cppNI,rcpNI,t,p)
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the atmospheric specific heat capacity as a 
+!     function of pressure and temperature (for CO2 gas only)
+!
+!     Authors
+!     ------- 
+!     Robin Wordsworth (2009)
+!
+!==================================================================
+
+      implicit none
+
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "cpdet.h"
+
+      !real cp0, dB2dT2
+      real cppNI      ! specific heat capacity at const. pressure
+      real rcpNI      ! R / specific heat capacity
+      real t
+      real p
+
+      ! dummy function until I decide what to do!
+
+      cppNI  = cpp
+      rcpNI  = R/cppNI
+
+      return
+    end subroutine calc_cpp3d
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_cpp_mugaz.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_cpp_mugaz.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_cpp_mugaz.F90	(revision 222)
@@ -0,0 +1,117 @@
+      subroutine calc_cpp_mugaz
+
+!==================================================================
+!     Purpose
+!     -------
+!     Check to see if the atmospheric specific heat capacity and
+!     mean molar mass for the gas mixture defined in gases.def
+!     corresponds to what we're using. If it doesn't, abort run
+!     unless option 'check_cpp_match' is set to false in 
+!     callphys.def.
+!
+!     Authors
+!     ------- 
+!     Robin Wordsworth (2009)
+!     A. Spiga: make the routine OK with latest changes in rcm1d
+!
+!==================================================================
+
+      use gases_h
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+      real cpp_c   
+      real mugaz_c
+
+      integer igas
+
+      cpp_c   = 0.0
+      mugaz_c = 0.0
+
+      do igas=1,ngasmx
+
+         if(igas.eq.vgas)then
+            ! ignore variable gas in cpp calculation
+         else
+            ! all values at 300 K from Engineering Toolbox
+            if(igas.eq.igas_CO2)then
+               !cpp_c   = cpp_c   + 0.744*gfrac(igas) ! @ ~210 K (better for Mars conditions) 
+               cpp_c   = cpp_c   + 0.846*gfrac(igas)
+               mugaz_c = mugaz_c + 44.01*gfrac(igas)
+            elseif(igas.eq.igas_N2)then
+               cpp_c   = cpp_c   + 1.040*gfrac(igas)
+               mugaz_c = mugaz_c + 28.01*gfrac(igas)
+            elseif(igas.eq.igas_H2)then
+               cpp_c   = cpp_c   + 14.31*gfrac(igas)
+               mugaz_c = mugaz_c + 2.01*gfrac(igas)
+            elseif(igas.eq.igas_He)then
+               cpp_c   = cpp_c   + 5.19*gfrac(igas)
+               mugaz_c = mugaz_c + 4.003*gfrac(igas)
+            elseif(igas.eq.igas_H2O)then
+               cpp_c   = cpp_c   + 1.864*gfrac(igas)
+               mugaz_c = mugaz_c + 18.02*gfrac(igas)
+            elseif(igas.eq.igas_SO2)then
+               cpp_c   = cpp_c   + 0.64*gfrac(igas)
+               mugaz_c = mugaz_c + 64.066*gfrac(igas)
+            elseif(igas.eq.igas_H2S)then
+               cpp_c   = cpp_c   + 1.003*gfrac(igas) ! from wikipedia...
+               mugaz_c = mugaz_c + 34.08*gfrac(igas)
+            elseif(igas.eq.igas_CH4)then
+               cpp_c   = cpp_c   + 2.226*gfrac(igas)
+               mugaz_c = mugaz_c + 16.04*gfrac(igas)
+            elseif(igas.eq.igas_NH3)then
+               cpp_c   = cpp_c   + 2.175*gfrac(igas)
+               mugaz_c = mugaz_c + 17.03*gfrac(igas)
+               print*,'WARNING, cpp for NH3 may be for liquid'
+            elseif(igas.eq.igas_C2H6)then 
+               ! C2H6 http://encyclopedia.airliquide.com/Encyclopedia.asp?GasID=28
+               cpp_c   = cpp_c   + 1.763*gfrac(igas)
+               mugaz_c = mugaz_c + 30.07*gfrac(igas)
+            elseif(igas.eq.igas_C2H2)then
+               ! C2H2 http://encyclopedia.airliquide.com/Encyclopedia.asp?GasID=1
+               cpp_c   = cpp_c   + 1.575*gfrac(igas)
+               mugaz_c = mugaz_c + 26.04*gfrac(igas)
+            else
+               print*,'Error in calc_cpp_mugaz: Gas species not recognised!'
+               call abort
+            endif
+         endif
+
+      enddo
+
+      cpp_c = 1000.0*cpp_c
+
+      print*,'Cp in calc_cpp_mugaz is ',cpp_c,'J kg^-1 K^-1'
+      print*,'Mg in calc_cpp_mugaz is ',mugaz_c,'amu'
+      print*,'Predefined Cp in physics is ',cpp,'J kg^-1 K^-1'
+      print*,'Predefined Mg in physics is ',mugaz,'amu'
+
+      if (check_cpp_match) then
+         print*,'REQUEST TO CHECK cpp_match :'
+         if((abs(1.-cpp/cpp_c).gt.1.e-6) .or.  &
+              (abs(1.-mugaz/mugaz_c).gt.1.e-6)) then
+            ! Ehouarn: tolerate a small mismatch between computed/stored values
+            print*,'--> Values do not match!'
+            print*,'    Either adjust cpp / mugaz via newstart to calculated values,'
+            print*,'    or set check_cpp_match to .false. in callphys.def.'
+            stop
+         else
+            print*,'--> OK. Settings match composition.'
+         endif
+      endif
+
+      if (.not.force_cpp) then
+          print*,'*** Setting cpp & mugaz to computations in calc_cpp_mugaz.'
+          mugaz = mugaz_c
+          cpp = cpp_c
+      else
+          print*,'*** Setting cpp & mugaz to predefined values.'
+      endif
+
+
+      return
+    end subroutine calc_cpp_mugaz
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_rayleigh.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_rayleigh.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calc_rayleigh.F90	(revision 222)
@@ -0,0 +1,167 @@
+      subroutine calc_rayleigh
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Average the Rayleigh scattering in each band, weighting the 
+!     average by the blackbody function at temperature tstellar.
+!     Works for an arbitrary mix of gases (currently CO2, N2 and 
+!     H2 are possible).
+!     
+!     Authors
+!     ------- 
+!     Robin Wordsworth (2010)
+!     Jeremy Leconte (2012): Added option for variable gas. Improved water rayleigh (Bucholtz 1995).
+!
+!     Called by
+!     ---------
+!     setspv.F
+!     
+!     Calls
+!     -----
+!     none
+!     
+!==================================================================
+
+      use radinc_h, only: L_NSPECTV
+      use radcommon_h, only: WAVEV, BWNV, DWNV, tstellar, tauray, taurayvar, scalep
+      use gases_h
+
+      implicit none
+
+#include "comcstfi.h"
+#include "callkeys.h"
+
+      real*8 wl
+      integer N,Nfine,ifine,igas
+      parameter(Nfine=500.0)
+      real*8 :: P0 = 9.423D+6   ! Rayleigh scattering reference pressure in pascals.    
+
+      logical typeknown
+      real*8 tauvar,tauvarvar,tausum,tausumvar,tauwei,tauweivar,bwidth,bstart
+      double precision df
+
+      real*8 tauconsti(ngasmx)
+      real*8 tauvari(ngasmx)
+
+      integer icantbewrong
+
+      ! tau0/p0=tau/p (Hansen 1974)
+      ! Then calculate tau0 = (8*pi^3*p_1atm)/(3*N0^2) * 4*delta^2/(g*mugaz*lambda^4)
+      ! where delta=n-1 and N0 is an amagat
+
+      typeknown=.false.
+      do igas=1,ngasmx
+         if(igas.eq.vgas)then
+            print*,'variable gas is ',trim(gnom(igas)),' in Rayleigh scattering '
+	 endif
+	 if((igas/=vgas).and.(gfrac(igas).lt.5.e-2))then
+            print*,'Ignoring ',trim(gnom(igas)),' in Rayleigh scattering '// &
+            'as its mixing ratio is less than 0.05.' 
+            ! ignore variable gas in Rayleigh calculation
+            ! ignore gases of mixing ratio < 0.05 in Rayleigh calculation
+            tauconsti(igas) = 0.0
+         else
+            if(igas.eq.igas_CO2) then
+               tauconsti(igas) = (8.7/g)*1.527*scalep/P0
+            elseif(igas.eq.igas_N2)then
+               tauconsti(igas) = (9.81/g)*8.569E-3*scalep/(P0/93.0)
+            elseif(igas.eq.igas_H2O)then
+!               tauconsti(igas) = (10.0/g)*9.22E-3*scalep/101325.0 
+               tauconsti(igas) = 1.98017E-10/(g*mugaz*100.) 
+            elseif(igas.eq.igas_H2)then
+               tauconsti(igas) = (10.0/g)*0.0241*scalep/101325.0
+               !tauconsti(igas) = (10.0/g)*0.0487*scalep/(101325.0)
+               ! uses n=1.000132 from Optics, Fourth Edition.
+               ! was out by a factor 2!
+            elseif(igas.eq.igas_He)then
+               tauconsti(igas) = (10.0/g)*0.00086*scalep/101325.0
+            else
+               print*,'Error in calc_rayleigh: Gas species not recognised!'
+               call abort
+            endif
+
+            if((gfrac(igas).eq.1.0).and.(vgas.eq.0))then
+               print*,'Rayleigh scattering is for a pure ',trim(gnom(igas)),' atmosphere.'
+               typeknown=.true.
+            endif
+
+         endif
+      enddo
+
+      if(.not.typeknown)then
+         print*,'Rayleigh scattering is for a mixed gas atmosphere.'
+         typeknown=.true.
+      endif
+
+ 
+      do N=1,L_NSPECTV
+         
+         tausum = 0.0
+         tauwei = 0.0
+         tausumvar = 0.0
+         tauweivar = 0.0
+         bstart = 10000.0/BWNV(N+1)
+         bwidth = (10000.0/BWNV(N)) - (10000.0/BWNV(N+1))
+         do ifine=1,Nfine
+            wl=bstart+dble(ifine)*bwidth/Nfine
+
+            tauvar=0.0
+            tauvarvar=0.0
+            do igas=1,ngasmx
+               if((igas/=vgas).and.(gfrac(igas).lt.5.e-2))then
+                  ! ignore variable gas in Rayleigh calculation
+                  ! ignore gases of mixing ratio < 0.05 in Rayleigh calculation
+                  tauvari(igas)   = 0.0
+               else
+                  if(igas.eq.igas_CO2)then
+                     tauvari(igas) = (1.0+0.013/wl**2)/wl**4
+                  elseif(igas.eq.igas_N2)then
+                     tauvari(igas) = (1.0+0.0113/wl**2+0.00013/wl**4)/wl**4
+                  elseif(igas.eq.igas_H2O)then
+!                     tauvari(igas) = 1.0/wl**4 ! to be improved...
+                     tauvari(igas) = (5.7918E6/(2.38E2-1/wl**2)+1.679E5/(57.36E0-1/wl**2))**2/wl**4 
+                  elseif(igas.eq.igas_H2)then
+                     tauvari(igas) = 1.0/wl**4 
+                  elseif(igas.eq.igas_He)then
+                     tauvari(igas) = 1.0/wl**4 
+                  else
+                     print*,'Error in calc_rayleigh: Gas species not recognised!'
+                     call abort
+                  endif
+               endif
+
+               if(igas.eq.vgas) then
+                  tauvarvar=tauvarvar+tauconsti(igas)*tauvari(igas)
+                  tauvar=tauvar+0.0*0.0*gfrac(igas)
+               else
+                  tauvar=tauvar+tauconsti(igas)*tauvari(igas)*gfrac(igas)
+               endif
+
+            enddo
+
+            call blackl(dble(wl*1e-6),dble(tstellar),df)
+            df=df*bwidth/Nfine
+            tauwei=tauwei+df
+            tausum=tausum+tauvar*df
+            tauweivar=tauweivar+df
+            tausumvar=tausumvar+tauvarvar*df
+         
+         enddo
+         TAURAY(N)=tausum/tauwei
+         TAURAYVAR(N)=tausumvar/tauweivar
+         ! we multiply by scalep here (100) because plev, which is used in optcv,
+         ! is in units of mBar, so we need to convert.
+
+      end do
+
+      IF (L_NSPECTV > 6) THEN
+        icantbewrong = L_NSPECTV-6
+        print*,'At 1 atm and lambda = ',WAVEV(icantbewrong),' um'
+        print*,'tau_R = ',TAURAY(icantbewrong)*1013.25
+        print*,'sig_R = ',TAURAY(icantbewrong)*g*mugaz*1.67e-27*100, &
+               'cm^2 molecule^-1'
+      ENDIF
+
+    end subroutine calc_rayleigh
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calcenergy_kcm.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calcenergy_kcm.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/calcenergy_kcm.F90	(revision 222)
@@ -0,0 +1,79 @@
+subroutine calcenergy_kcm(Tsurf,T,Play,Plev,Qsurf,Q,muvar,Eatmtot)
+
+
+use params_h, only : Rc
+use watercommon_h, only : mH2O
+implicit none
+
+!     ----------------------------------------------------------------
+!     Purpose: Calculate total energy of the (steam) atmosphere
+!     Authour: R. Wordsworth (2011)
+!     ----------------------------------------------------------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+!#include "callkeys.h"
+
+
+
+  ! inputs
+  real Tsurf,T(1:nlayermx)
+  real Play(1:nlayermx),Plev(1:nlayermx+1)
+  real Qsurf,Q(1:nlayermx)
+  real muvar(1,nlayermx+1)
+
+  ! internal
+  integer il
+  real m_n,m_v,cp_n,cp_v,cp_a,Eatmlay
+  real s_c,rho_v,L
+  double precision p_v, s_v, nul
+  real VMR(1:nlayermx)
+
+  ! output
+  real Eatmtot
+
+  ! functions
+  double precision cp_neutral
+
+  m_n = mugaz/1000.
+  m_v = mH2O/1000.
+
+
+  do il=1,nlayermx
+     VMR(il)=Q(il)*(muvar(1,il+1)/mH2O)
+  end do
+
+
+  Eatmtot = 0.0
+  do il=1,nlayermx
+
+
+     cp_n = cp_neutral(dble(T(il)))
+     cp_v = (32.24+1.923d-3*T(il) + 1.055d-5*T(il)**2-3.511d-9*T(il)**3)/m_v
+     ! / by m_v makes it per kg not per mol
+
+     call psat_H2O(dble(T(il)),p_v)
+     p_v   = p_v*1d6
+     rho_v = real(p_v)*m_v/(real(Rc)*T(il))
+
+     call therm(dble(T(il)),dble(rho_v)*1d-3,nul,nul,nul,nul,nul,nul,nul,&
+                nul,nul,nul,s_v,nul)
+
+     s_c = 2.06 * log(T(il)/273.15)
+     s_v = s_v * 1d3
+     s_c = s_c * 1d3
+     L   = (real(s_v)-s_c)*T(il)
+
+     cp_a    = (1-VMR(il))*cp_n + VMR(il)*cp_v 
+     !cp_a    = (1-Q(il))*cp_n + Q(il)*cp_v 
+
+     Eatmlay = ( cp_a*T(il) + L*VMR(il) ) * (Plev(il)-Plev(il+1))/g
+
+     Eatmtot = Eatmtot + Eatmlay 
+  enddo
+
+  print*,'WARNING: E-calc currently assumes H2O saturation!'
+
+end subroutine calcenergy_kcm
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callcorrk.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callcorrk.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callcorrk.F90	(revision 222)
@@ -0,0 +1,877 @@
+      subroutine callcorrk(ngrid,nlayer,pq,nq,qsurf,           &
+          albedo,emis,mu0,pplev,pplay,pt,                      & 
+          tsurf,fract,dist_star,aerosol,muvar,                 &
+          dtlw,dtsw,fluxsurf_lw,                               &
+          fluxsurf_sw,fluxtop_lw,fluxabs_sw,fluxtop_dn,        &
+          OLR_nu,OSR_nu,                                       &
+          tau_col,cloudfrac,totcloudfrac,                      &
+          clearsky,firstcall,lastcall)
+
+      use radinc_h
+      use radcommon_h
+      use watercommon_h
+      use datafile_mod, only: datadir
+      use ioipsl_getincom 
+      use gases_h
+      use radii_mod, only : su_aer_radii,co2_reffrad,h2o_reffrad,dust_reffrad,h2so4_reffrad,back2lay_reffrad
+      use aerosol_mod, only : iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4, iaero_back2lay
+      USE tracer_h
+
+      implicit none
+
+!==================================================================
+!
+!     Purpose
+!     -------
+!     Solve the radiative transfer using the correlated-k method for
+!     the gaseous absorption and the Toon et al. (1989) method for
+!     scatttering due to aerosols.
+!
+!     Authors
+!     ------- 
+!     Emmanuel 01/2001, Forget 09/2001
+!     Robin Wordsworth (2009)
+!
+!==================================================================
+
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+!-----------------------------------------------------------------------
+!     Declaration of the arguments (INPUT - OUTPUT) on the LMD GCM grid
+!     Layer #1 is the layer near the ground. 
+!     Layer #nlayermx is the layer at the top.
+
+      INTEGER,INTENT(IN) :: ngrid ! number of atmospheric columns
+      INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers
+      REAL,INTENT(IN) :: pq(ngrid,nlayer,nq) ! tracers (.../kg_of_air)
+      integer,intent(in) :: nq ! number of tracers
+      REAL,INTENT(IN) :: qsurf(ngrid,nq) ! tracer on surface (kg.m-2)
+      REAL,INTENT(IN) :: albedo(ngrid)   ! SW albedo
+      REAL,INTENT(IN) :: emis(ngrid)     ! LW emissivity
+      real,intent(in) :: mu0(ngrid) ! cosine of sun incident angle
+      REAL,INTENT(IN) :: pplev(ngrid,nlayermx+1)  ! inter-layer pressure (Pa)
+      REAL,INTENT(IN) :: pplay(ngrid,nlayermx)    ! mid-layer pressure (Pa)
+      REAL,INTENT(IN) :: pt(ngrid,nlayermx)  ! air temperature (K)
+      REAL,INTENT(IN) :: tsurf(ngrid)        ! surface temperature (K)
+      REAL,INTENT(IN) :: fract(ngrid)        ! fraction of day
+      REAL,INTENT(IN) :: dist_star           ! distance star-planet (AU)
+      REAL,INTENT(OUT) :: aerosol(ngrid,nlayermx,naerkind) ! aerosol tau (kg/kg)
+      real,intent(in) :: muvar(ngrid,nlayermx+1)
+      REAL,INTENT(OUT) :: dtlw(ngrid,nlayermx) ! heating rate (K/s) due to LW
+      REAL,INTENT(OUT) :: dtsw(ngrid,nlayermx) ! heating rate (K/s) due to SW
+      REAL,INTENT(OUT) :: fluxsurf_lw(ngrid)   ! incident LW flux to surf (W/m2)
+      REAL,INTENT(OUT) :: fluxsurf_sw(ngrid)   ! incident SW flux to surf (W/m2)
+      REAL,INTENT(OUT) :: fluxtop_lw(ngrid)    ! outgoing LW flux to space (W/m2)
+      REAL,INTENT(OUT) :: fluxabs_sw(ngrid)    ! SW flux absorbed by planet (W/m2)
+      REAL,INTENT(OUT) :: fluxtop_dn(ngrid)    ! incident top of atmosphere SW flux (W/m2)
+      REAL,INTENT(OUT) :: OLR_nu(ngrid,L_NSPECTI)! Outgoing LW radition in each band (Normalized to the band width (W/m2/cm-1)
+      REAL,INTENT(OUT) :: OSR_nu(ngrid,L_NSPECTV)! Outgoing SW radition in each band (Normalized to the band width (W/m2/cm-1)
+      REAL,INTENT(OUT) :: tau_col(ngrid) ! diagnostic from aeropacity
+!     for H2O cloud fraction in aeropacity
+      real,intent(in) :: cloudfrac(ngrid,nlayermx)
+      real,intent(out) :: totcloudfrac(ngrid)
+      logical,intent(in) :: clearsky
+      logical,intent(in) :: firstcall ! signals first call to physics
+      logical,intent(in) :: lastcall ! signals last call to physics
+
+!     Globally varying aerosol optical properties on GCM grid
+!     Not needed everywhere so not in radcommon_h
+      REAL :: QVISsQREF3d(ngrid,nlayermx,L_NSPECTV,naerkind)
+      REAL :: omegaVIS3d(ngrid,nlayermx,L_NSPECTV,naerkind)
+      REAL :: gVIS3d(ngrid,nlayermx,L_NSPECTV,naerkind)
+
+      REAL :: QIRsQREF3d(ngrid,nlayermx,L_NSPECTI,naerkind)
+      REAL :: omegaIR3d(ngrid,nlayermx,L_NSPECTI,naerkind)
+      REAL :: gIR3d(ngrid,nlayermx,L_NSPECTI,naerkind)
+
+!      REAL :: omegaREFvis3d(ngrid,nlayermx,naerkind)
+!      REAL :: omegaREFir3d(ngrid,nlayermx,naerkind) ! not sure of the point of these...
+
+      REAL,ALLOCATABLE,SAVE :: reffrad(:,:,:) ! aerosol effective radius (m)
+      REAL,ALLOCATABLE,SAVE :: nueffrad(:,:,:) ! aerosol effective variance
+
+!-----------------------------------------------------------------------
+!     Declaration of the variables required by correlated-k subroutines
+!     Numbered from top to bottom unlike in the GCM!
+
+      REAL*8 tmid(L_LEVELS),pmid(L_LEVELS)
+      REAL*8 tlevrad(L_LEVELS),plevrad(L_LEVELS)
+
+!     Optical values for the optci/cv subroutines
+      REAL*8 stel(L_NSPECTV),stel_fract(L_NSPECTV)
+      REAL*8 dtaui(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+      REAL*8 dtauv(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+      REAL*8 cosbv(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+      REAL*8 cosbi(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+      REAL*8 wbari(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+      REAL*8 wbarv(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+      REAL*8 tauv(L_NLEVRAD,L_NSPECTV,L_NGAUSS)
+      REAL*8 taucumv(L_LEVELS,L_NSPECTV,L_NGAUSS)
+      REAL*8 taucumi(L_LEVELS,L_NSPECTI,L_NGAUSS)
+
+      REAL*8 tauaero(L_LEVELS+1,naerkind)
+      REAL*8 nfluxtopv,nfluxtopi,nfluxtop,fluxtopvdn
+      real*8 nfluxoutv_nu(L_NSPECTV) ! outgoing band-resolved VI flux at TOA (W/m2)
+      real*8 nfluxtopi_nu(L_NSPECTI) ! net band-resolved IR flux at TOA (W/m2)
+      real*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI) ! for 1D diagnostic
+      REAL*8 fmneti(L_NLAYRAD),fmnetv(L_NLAYRAD)
+      REAL*8 fluxupv(L_NLAYRAD),fluxupi(L_NLAYRAD)
+      REAL*8 fluxdnv(L_NLAYRAD),fluxdni(L_NLAYRAD)
+      REAL*8 albi,albv,acosz
+
+      INTEGER ig,l,k,nw,iaer,irad
+      INTEGER icount
+
+      real szangle
+      logical global1d
+      save szangle,global1d
+      real*8 taugsurf(L_NSPECTV,L_NGAUSS-1)
+      real*8 taugsurfi(L_NSPECTI,L_NGAUSS-1)
+
+      real*8 qvar(L_LEVELS)          ! mixing ratio of variable component (mol/mol)
+
+!     Local aerosol optical properties for each column on RADIATIVE grid
+      real*8,save ::  QXVAER(L_LEVELS+1,L_NSPECTV,naerkind)
+      real*8,save ::  QSVAER(L_LEVELS+1,L_NSPECTV,naerkind)
+      real*8,save ::  GVAER(L_LEVELS+1,L_NSPECTV,naerkind)
+      real*8,save ::  QXIAER(L_LEVELS+1,L_NSPECTI,naerkind)
+      real*8,save ::  QSIAER(L_LEVELS+1,L_NSPECTI,naerkind)
+      real*8,save ::  GIAER(L_LEVELS+1,L_NSPECTI,naerkind)
+
+      !REAL :: QREFvis3d(ngrid,nlayermx,naerkind)
+      !REAL :: QREFir3d(ngrid,nlayermx,naerkind)
+      !save QREFvis3d, QREFir3d 
+      real, dimension(:,:,:), save, allocatable :: QREFvis3d
+      real, dimension(:,:,:), save, allocatable :: QREFir3d
+
+
+!     Misc.
+      logical nantest
+      real*8  tempv(L_NSPECTV)
+      real*8  tempi(L_NSPECTI)
+      real*8  temp,temp1,temp2,pweight
+      character(len=10) :: tmp1
+      character(len=10) :: tmp2
+
+!     for fixed water vapour profiles
+      integer i_var
+      real RH
+      real*8 pq_temp(nlayer)
+      real ptemp, Ttemp, qsat
+
+!      real(KIND=r8) :: pq_temp(nlayer) ! better F90 way.. DOESNT PORT TO F77!!!
+
+      !real ptime, pday
+      logical OLRz
+      real*8 NFLUXGNDV_nu(L_NSPECTV)
+
+
+      ! for weird cloud test
+      real pqtest(ngrid,nlayer,nq)
+
+      real maxrad, minrad
+            
+      real,external :: CBRT
+
+!     included by RW for runaway greenhouse 1D study
+      real vtmp(nlayermx)
+      REAL*8 muvarrad(L_LEVELS)
+
+!===============================================================
+!     Initialization on first call
+
+      qxvaer(:,:,:)=0.0
+      qsvaer(:,:,:)=0.0
+      gvaer(:,:,:) =0.0
+
+      qxiaer(:,:,:)=0.0
+      qsiaer(:,:,:)=0.0
+      giaer(:,:,:) =0.0
+
+      if(firstcall) then
+
+         !!! ALLOCATED instances are necessary because of CLFvarying
+         !!! strategy to call callcorrk twice in physiq...
+         IF(.not.ALLOCATED(QREFvis3d)) ALLOCATE(QREFvis3d(ngrid,nlayermx,naerkind))
+         IF(.not.ALLOCATED(QREFir3d)) ALLOCATE(QREFir3d(ngrid,nlayermx,naerkind))
+         ! Effective radius and variance of the aerosols
+         IF(.not.ALLOCATED(reffrad)) allocate(reffrad(ngrid,nlayer,naerkind))
+         IF(.not.ALLOCATED(nueffrad)) allocate(nueffrad(ngrid,nlayer,naerkind))
+
+         call system('rm -f surf_vals_long.out')
+
+         if(naerkind.gt.4)then
+            print*,'Code not general enough to deal with naerkind > 4 yet.'
+            call abort
+         endif
+         call su_aer_radii(ngrid,reffrad,nueffrad)
+	 
+	 
+
+!--------------------------------------------------
+!     set up correlated k
+         print*, "callcorrk: Correlated-k data base folder:",trim(datadir)
+         call getin("corrkdir",corrkdir)
+         print*, "corrkdir = ",corrkdir
+         write( tmp1, '(i3)' ) L_NSPECTI
+         write( tmp2, '(i3)' ) L_NSPECTV
+         banddir=trim(adjustl(tmp1))//'x'//trim(adjustl(tmp2))
+         banddir=trim(adjustl(corrkdir))//'/'//trim(adjustl(banddir))
+
+         call setspi            ! basic infrared properties
+         call setspv            ! basic visible properties
+         call sugas_corrk       ! set up gaseous absorption properties
+         call suaer_corrk       ! set up aerosol optical properties
+
+
+         if((igcm_h2o_vap.eq.0) .and. varactive)then
+            print*,'varactive in callcorrk but no h2o_vap tracer.'
+            stop
+         endif
+
+         OLR_nu(:,:) = 0.
+         OSR_nu(:,:) = 0.
+
+         if (ngrid.eq.1) then
+           PRINT*, 'Simulate global averaged conditions ?'
+           global1d = .false. ! default value
+           call getin("global1d",global1d)
+           write(*,*) "global1d = ",global1d
+           ! Test of incompatibility:
+           ! if global1d is true, there should not be any diurnal cycle
+           if (global1d.and.diurnal) then
+            print*,'if global1d is true, diurnal must be set to false'
+            stop
+           endif
+
+           if (global1d) then
+             PRINT *,'Solar Zenith angle (deg.) ?'
+             PRINT *,'(assumed for averaged solar flux S/4)'
+             szangle=60.0  ! default value
+             call getin("szangle",szangle)
+             write(*,*) "szangle = ",szangle
+           endif
+         endif
+
+      end if ! of if (firstcall)
+
+!=======================================================================
+!     Initialization on every call    
+
+!--------------------------------------------------
+!     Effective radius and variance of the aerosols
+      do iaer=1,naerkind
+
+         if ((iaer.eq.iaero_co2).and.tracer.and.(igcm_co2_ice.gt.0)) then ! treat condensed co2 particles.
+	    call co2_reffrad(ngrid,nq,pq,reffrad(1,1,iaero_co2))
+            print*,'Max. CO2 ice particle size = ',maxval(reffrad(1:ngrid,1:nlayermx,iaer))/1.e-6,' um'
+            print*,'Min. CO2 ice particle size = ',minval(reffrad(1:ngrid,1:nlayermx,iaer))/1.e-6,' um'
+	 end if
+         if ((iaer.eq.iaero_h2o).and.water) then ! treat condensed water particles. to be generalized for other aerosols
+	    call h2o_reffrad(ngrid,pq(1,1,igcm_h2o_ice),pt, &
+                             reffrad(1,1,iaero_h2o),nueffrad(1,1,iaero_h2o))
+            print*,'Max. H2O cloud particle size = ',maxval(reffrad(1:ngrid,1:nlayermx,iaer))/1.e-6,' um'
+            print*,'Min. H2O cloud particle size = ',minval(reffrad(1:ngrid,1:nlayermx,iaer))/1.e-6,' um'
+         endif
+         if(iaer.eq.iaero_dust)then
+	    call dust_reffrad(ngrid,reffrad(1,1,iaero_dust))
+            print*,'Dust particle size = ',reffrad(1,1,iaer)/1.e-6,' um'
+         endif
+         if(iaer.eq.iaero_h2so4)then
+	    call h2so4_reffrad(ngrid,reffrad(1,1,iaero_h2so4))
+            print*,'H2SO4 particle size =',reffrad(1,1,iaer)/1.e-6,' um'
+         endif
+          if(iaer.eq.iaero_back2lay)then
+	    call back2lay_reffrad(ngrid,reffrad(1,1,iaero_back2lay),nlayer,pplev)
+         endif
+     end do !iaer=1,naerkind
+
+
+!     how much light we get
+      do nw=1,L_NSPECTV
+         stel(nw)=stellarf(nw)/(dist_star**2)
+      end do
+
+      call aeroptproperties(ngrid,nlayer,reffrad,nueffrad,         &
+           QVISsQREF3d,omegaVIS3d,gVIS3d,                          &
+           QIRsQREF3d,omegaIR3d,gIR3d,                             &
+           QREFvis3d,QREFir3d)                                     ! get 3D aerosol optical properties
+
+      call aeropacity(ngrid,nlayer,nq,pplay,pplev,pq,aerosol,      &
+           reffrad,QREFvis3d,QREFir3d,                             & 
+           tau_col,cloudfrac,totcloudfrac,clearsky)                ! get aerosol optical depths
+	  
+!-----------------------------------------------------------------------
+!     Starting Big Loop over every GCM column
+      do ig=1,ngrid
+
+!=======================================================================
+!     Transformation of the GCM variables
+
+!-----------------------------------------------------------------------
+!     Aerosol optical properties Qext, Qscat and g
+!     The transformation in the vertical is the same as for temperature
+           
+!     shortwave
+            do iaer=1,naerkind
+               DO nw=1,L_NSPECTV 
+                  do l=1,nlayermx
+
+                     temp1=QVISsQREF3d(ig,nlayermx+1-l,nw,iaer)         &
+                         *QREFvis3d(ig,nlayermx+1-l,iaer)
+
+                     temp2=QVISsQREF3d(ig,max(nlayermx-l,1),nw,iaer)    &
+                         *QREFvis3d(ig,max(nlayermx-l,1),iaer)
+
+                     qxvaer(2*l,nw,iaer)  = temp1
+                     qxvaer(2*l+1,nw,iaer)=(temp1+temp2)/2
+
+                     temp1=temp1*omegavis3d(ig,nlayermx+1-l,nw,iaer)
+                     temp2=temp2*omegavis3d(ig,max(nlayermx-l,1),nw,iaer)
+
+                     qsvaer(2*l,nw,iaer)  = temp1
+                     qsvaer(2*l+1,nw,iaer)=(temp1+temp2)/2
+
+                     temp1=gvis3d(ig,nlayermx+1-l,nw,iaer)
+                     temp2=gvis3d(ig,max(nlayermx-l,1),nw,iaer)
+
+                     gvaer(2*l,nw,iaer)  = temp1
+                     gvaer(2*l+1,nw,iaer)=(temp1+temp2)/2
+
+                  end do
+
+                  qxvaer(1,nw,iaer)=qxvaer(2,nw,iaer)
+                  qxvaer(2*nlayermx+1,nw,iaer)=0.
+
+                  qsvaer(1,nw,iaer)=qsvaer(2,nw,iaer)
+                  qsvaer(2*nlayermx+1,nw,iaer)=0.
+
+                  gvaer(1,nw,iaer)=gvaer(2,nw,iaer)
+                  gvaer(2*nlayermx+1,nw,iaer)=0.
+
+               end do
+
+!     longwave
+               DO nw=1,L_NSPECTI 
+                  do l=1,nlayermx
+
+                     temp1=QIRsQREF3d(ig,nlayermx+1-l,nw,iaer)         &
+                          *QREFir3d(ig,nlayermx+1-l,iaer)
+
+                     temp2=QIRsQREF3d(ig,max(nlayermx-l,1),nw,iaer)    &
+                          *QREFir3d(ig,max(nlayermx-l,1),iaer)
+
+                     qxiaer(2*l,nw,iaer)  = temp1
+                     qxiaer(2*l+1,nw,iaer)=(temp1+temp2)/2
+
+                     temp1=temp1*omegair3d(ig,nlayermx+1-l,nw,iaer)
+                     temp2=temp2*omegair3d(ig,max(nlayermx-l,1),nw,iaer)
+
+                     qsiaer(2*l,nw,iaer)  = temp1
+                     qsiaer(2*l+1,nw,iaer)=(temp1+temp2)/2
+
+                     temp1=gir3d(ig,nlayermx+1-l,nw,iaer)
+                     temp2=gir3d(ig,max(nlayermx-l,1),nw,iaer)
+
+                     giaer(2*l,nw,iaer)  = temp1
+                     giaer(2*l+1,nw,iaer)=(temp1+temp2)/2
+
+                  end do
+
+                  qxiaer(1,nw,iaer)=qxiaer(2,nw,iaer)
+                  qxiaer(2*nlayermx+1,nw,iaer)=0.
+
+                  qsiaer(1,nw,iaer)=qsiaer(2,nw,iaer)
+                  qsiaer(2*nlayermx+1,nw,iaer)=0.
+
+                  giaer(1,nw,iaer)=giaer(2,nw,iaer)
+                  giaer(2*nlayermx+1,nw,iaer)=0.
+
+               end do
+            end do
+
+            ! test / correct for freaky s. s. albedo values
+            do iaer=1,naerkind
+               do k=1,L_LEVELS+1
+
+                  do nw=1,L_NSPECTV
+                     if(qsvaer(k,nw,iaer).gt.1.05*qxvaer(k,nw,iaer))then
+                        print*,'Serious problems with qsvaer values' 
+                        print*,'in callcorrk'
+                        call abort
+                     endif
+                     if(qsvaer(k,nw,iaer).gt.qxvaer(k,nw,iaer))then
+                        qsvaer(k,nw,iaer)=qxvaer(k,nw,iaer)
+                     endif
+                  end do
+
+                  do nw=1,L_NSPECTI 
+                     if(qsiaer(k,nw,iaer).gt.1.05*qxiaer(k,nw,iaer))then
+                        print*,'Serious problems with qsiaer values'
+                        print*,'in callcorrk'
+                        call abort
+                     endif
+                     if(qsiaer(k,nw,iaer).gt.qxiaer(k,nw,iaer))then
+                        qsiaer(k,nw,iaer)=qxiaer(k,nw,iaer)
+                     endif
+                  end do
+
+               end do
+            end do
+
+!-----------------------------------------------------------------------
+!     Aerosol optical depths
+            
+         do iaer=1,naerkind     ! a bug was here           
+            do k=0,nlayer-1
+               
+               pweight=(pplay(ig,L_NLAYRAD-k)-pplev(ig,L_NLAYRAD-k+1))/   &
+                        (pplev(ig,L_NLAYRAD-k)-pplev(ig,L_NLAYRAD-k+1))
+
+               temp=aerosol(ig,L_NLAYRAD-k,iaer)/QREFvis3d(ig,L_NLAYRAD-k,iaer)
+
+               tauaero(2*k+2,iaer)=max(temp*pweight,0.d0)
+               tauaero(2*k+3,iaer)=max(temp-tauaero(2*k+2,iaer),0.d0)
+!
+            end do
+            ! boundary conditions
+            tauaero(1,iaer)          = tauaero(2,iaer)
+            tauaero(L_LEVELS+1,iaer) = tauaero(L_LEVELS,iaer)
+            !tauaero(1,iaer)          = 0.
+            !tauaero(L_LEVELS+1,iaer) = 0.
+         end do
+
+!     Albedo and emissivity
+         albi=1-emis(ig)        ! longwave
+         albv=albedo(ig)        ! shortwave 
+
+      if(nosurf.and.(albv.gt.0.0))then
+         print*,'For open lower boundary in callcorrk must'
+         print*,'have surface albedo set to zero!'
+         call abort
+      endif
+
+      if ((ngrid.eq.1).and.(global1d)) then       ! fixed zenith angle 'szangle' in 1D simulations w/ globally-averaged sunlight
+         acosz = cos(pi*szangle/180.0)
+         print*,'acosz=',acosz,', szangle=',szangle
+      else
+         acosz=mu0(ig)          ! cosine of sun incident angle : 3D simulations or local 1D simulations using latitude
+      endif
+
+!!! JL13: in the following, I changed some indices in the interpolations so that the model rsults are less dependent on the number of layers
+!!!    the older verions are commented with the commetn !JL13index 
+
+
+!-----------------------------------------------------------------------
+!     Water vapour (to be generalised for other gases eventually)
+      
+      if(varactive)then
+
+         i_var=igcm_h2o_vap
+         do l=1,nlayer
+            qvar(2*l)   = pq(ig,nlayer+1-l,i_var)
+            qvar(2*l+1) = pq(ig,nlayer+1-l,i_var)    
+!JL13index            qvar(2*l+1) = (pq(ig,nlayer+1-l,i_var)+pq(ig,max(nlayer-l,1),i_var))/2    
+!JL13index            ! Average approximation as for temperature...
+         end do
+         qvar(1)=qvar(2)
+
+      elseif(varfixed)then
+
+         do l=1,nlayermx        ! here we will assign fixed water vapour profiles globally
+            RH = satval * ((pplay(ig,l)/pplev(ig,1) - 0.02) / 0.98)
+            if(RH.lt.0.0) RH=0.0
+            
+            ptemp=pplay(ig,l)
+            Ttemp=pt(ig,l)
+            call watersat(Ttemp,ptemp,qsat)
+
+            !pq_temp(l) = qsat      ! fully saturated everywhere
+            pq_temp(l) = RH * qsat ! ~realistic profile (e.g. 80% saturation at ground)
+         end do
+         
+         do l=1,nlayer
+            qvar(2*l)   = pq_temp(nlayer+1-l)
+            qvar(2*l+1) = (pq_temp(nlayer+1-l)+pq_temp(max(nlayer-l,1)))/2
+         end do
+         qvar(1)=qvar(2)
+
+         ! Lowest layer of atmosphere
+         RH = satval * (1 - 0.02) / 0.98
+         if(RH.lt.0.0) RH=0.0
+
+!         ptemp = pplev(ig,1)
+!         Ttemp = tsurf(ig)
+!         call watersat(Ttemp,ptemp,qsat)
+
+         qvar(2*nlayermx+1)= RH * qsat ! ~realistic profile (e.g. 80% saturation at ground)
+ 
+      else
+         do k=1,L_LEVELS
+            qvar(k) = 1.0D-7
+         end do
+      end if
+
+      if(.not.kastprof)then
+      ! IMPORTANT: Now convert from kg/kg to mol/mol
+         do k=1,L_LEVELS
+            qvar(k) = qvar(k)/(epsi+qvar(k)*(1.-epsi))
+         end do
+      end if
+
+!-----------------------------------------------------------------------
+!     kcm mode only
+      if(kastprof)then
+
+         ! initial values equivalent to mugaz
+         DO l=1,nlayer
+            muvarrad(2*l)   = mugaz
+            muvarrad(2*l+1) = mugaz
+         END DO
+
+         if(ngasmx.gt.1)then
+
+            DO l=1,nlayer
+               muvarrad(2*l)   = muvar(ig,nlayer+2-l)
+               muvarrad(2*l+1) = (muvar(ig,nlayer+2-l) + &
+                                muvar(ig,max(nlayer+1-l,1)))/2
+            END DO
+      
+            muvarrad(1) = muvarrad(2)
+            muvarrad(2*nlayermx+1)=muvar(ig,1)
+
+            print*,'Recalculating qvar with VARIABLE epsi for kastprof'
+            print*,'Assumes that the variable gas is H2O!!!'
+            print*,'Assumes that there is only one tracer'
+            !i_var=igcm_h2o_vap
+            i_var=1
+            if(nq.gt.1)then
+               print*,'Need 1 tracer only to run kcm1d.e' 
+               stop
+            endif
+            do l=1,nlayer
+               vtmp(l)=pq(ig,l,i_var)/(epsi+pq(ig,l,i_var)*(1.-epsi)) 
+               !vtmp(l)=pq(ig,l,i_var)*muvar(ig,l+1)/mH2O !JL to be changed
+            end do
+
+            do l=1,nlayer
+               qvar(2*l)   = vtmp(nlayer+1-l)
+               qvar(2*l+1) = vtmp(nlayer+1-l)
+!               qvar(2*l+1) = ( vtmp(nlayer+1-l) + vtmp(max(nlayer-l,1)) )/2
+            end do
+            qvar(1)=qvar(2)
+
+            print*,'Warning: reducing qvar in callcorrk.'
+            print*,'Temperature profile no longer consistent ', &
+                            'with saturated H2O. qsat=',satval
+            do k=1,L_LEVELS
+               qvar(k) = qvar(k)*satval
+            end do
+
+         endif
+      else ! if kastprof
+         DO l=1,nlayer
+            muvarrad(2*l)   = muvar(ig,nlayer+2-l)
+            muvarrad(2*l+1) = (muvar(ig,nlayer+2-l)+muvar(ig,max(nlayer+1-l,1)))/2
+         END DO
+      
+         muvarrad(1) = muvarrad(2)
+         muvarrad(2*nlayermx+1)=muvar(ig,1)         
+      endif
+      
+      ! Keep values inside limits for which we have radiative transfer coefficients
+      if(L_REFVAR.gt.1)then ! there was a bug here!
+         do k=1,L_LEVELS
+            if(qvar(k).lt.wrefvar(1))then
+               qvar(k)=wrefvar(1)+1.0e-8
+            elseif(qvar(k).gt.wrefvar(L_REFVAR))then
+               qvar(k)=wrefvar(L_REFVAR)-1.0e-8
+            endif
+         end do
+      endif
+
+!-----------------------------------------------------------------------
+!     Pressure and temperature
+
+      DO l=1,nlayer
+         plevrad(2*l)   = pplay(ig,nlayer+1-l)/scalep
+         plevrad(2*l+1) = pplev(ig,nlayer+1-l)/scalep
+         tlevrad(2*l)   = pt(ig,nlayer+1-l)
+         tlevrad(2*l+1) = (pt(ig,nlayer+1-l)+pt(ig,max(nlayer-l,1)))/2
+      END DO
+      
+      plevrad(1) = 0.
+      plevrad(2) = max(pgasmin,0.0001*plevrad(3))
+
+      tlevrad(1) = tlevrad(2)
+      tlevrad(2*nlayermx+1)=tsurf(ig)
+      
+      tmid(1) = tlevrad(2)
+      tmid(2) = tlevrad(2)
+      pmid(1) = plevrad(2)
+      pmid(2) = plevrad(2)
+      
+      DO l=1,L_NLAYRAD-1
+         tmid(2*l+1) = tlevrad(2*l)
+         tmid(2*l+2) = tlevrad(2*l)
+         pmid(2*l+1) = plevrad(2*l)
+         pmid(2*l+2) = plevrad(2*l)
+!JL13index         tmid(2*l+1) = tlevrad(2*l+1)
+!JL13index         tmid(2*l+2) = tlevrad(2*l+1)
+!JL13index         pmid(2*l+1) = plevrad(2*l+1)
+!JL13index         pmid(2*l+2) = plevrad(2*l+1)
+      END DO
+      pmid(L_LEVELS) = plevrad(L_LEVELS-1)
+      tmid(L_LEVELS) = tlevrad(L_LEVELS-1)
+!JL13index      pmid(L_LEVELS) = plevrad(L_LEVELS)
+!JL13index      tmid(L_LEVELS) = tlevrad(L_LEVELS)
+
+      ! test for out-of-bounds pressure
+      if(plevrad(3).lt.pgasmin)then
+         print*,'Minimum pressure is outside the radiative'
+         print*,'transfer kmatrix bounds, exiting.'
+         call abort
+      elseif(plevrad(L_LEVELS).gt.pgasmax)then
+         print*,'Maximum pressure is outside the radiative'
+         print*,'transfer kmatrix bounds, exiting.'
+         call abort
+      endif
+
+      ! test for out-of-bounds temperature
+      do k=1,L_LEVELS
+         if(tlevrad(k).lt.tgasmin)then
+            print*,'Minimum temperature is outside the radiative'
+            print*,'transfer kmatrix bounds'
+            print*,"k=",k," tlevrad(k)=",tlevrad(k)
+            print*,"tgasmin=",tgasmin
+            if (strictboundcorrk) then
+              call abort
+            else
+              print*,'***********************************************'
+              print*,'we allow model to continue with tlevrad=tgasmin' 
+              print*,'  ... we assume we know what you are doing ... '
+              print*,'  ... but do not let this happen too often ... '
+              print*,'***********************************************'
+              !tlevrad(k)=tgasmin
+            endif
+         elseif(tlevrad(k).gt.tgasmax)then
+            print*,'Maximum temperature is outside the radiative'
+            print*,'transfer kmatrix bounds, exiting.'
+            print*,"k=",k," tlevrad(k)=",tlevrad(k)
+            print*,"tgasmax=",tgasmax
+            if (strictboundcorrk) then
+              call abort
+            else
+              print*,'***********************************************'
+              print*,'we allow model to continue with tlevrad=tgasmax'  
+              print*,'  ... we assume we know what you are doing ... '
+              print*,'  ... but do not let this happen too often ... '
+              print*,'***********************************************'
+              !tlevrad(k)=tgasmax
+            endif
+         endif
+      enddo
+      do k=1,L_NLAYRAD+1
+         if(tmid(k).lt.tgasmin)then
+            print*,'Minimum temperature is outside the radiative'
+            print*,'transfer kmatrix bounds, exiting.'
+            print*,"k=",k," tmid(k)=",tmid(k)
+            print*,"tgasmin=",tgasmin
+            if (strictboundcorrk) then
+              call abort
+            else
+              print*,'***********************************************'
+              print*,'we allow model to continue with tmid=tgasmin'
+              print*,'  ... we assume we know what you are doing ... '
+              print*,'  ... but do not let this happen too often ... '
+              print*,'***********************************************'
+              tmid(k)=tgasmin
+            endif
+         elseif(tmid(k).gt.tgasmax)then
+            print*,'Maximum temperature is outside the radiative'
+            print*,'transfer kmatrix bounds, exiting.'
+            print*,"k=",k," tmid(k)=",tmid(k)
+            print*,"tgasmax=",tgasmax
+            if (strictboundcorrk) then
+              call abort
+            else
+              print*,'***********************************************'
+              print*,'we allow model to continue with tmid=tgasmin'
+              print*,'  ... we assume we know what you are doing ... '
+              print*,'  ... but do not let this happen too often ... '
+              print*,'***********************************************'
+              tmid(k)=tgasmax
+            endif
+         endif
+      enddo
+
+!=======================================================================
+!     Calling the main radiative transfer subroutines
+
+
+         Cmk= 0.01 * 1.0 / (glat(ig) * mugaz * 1.672621e-27) ! q_main=1.0 assumed
+	 glat_ig=glat(ig)
+
+!-----------------------------------------------------------------------
+!     Shortwave
+
+         if(fract(ig) .ge. 1.0e-4) then ! only during daylight!
+            if((ngrid.eq.1).and.(global1d))then
+               do nw=1,L_NSPECTV
+                  stel_fract(nw)= stel(nw)* 0.25 / acosz
+                                ! globally averaged = divide by 4
+                                ! but we correct for solar zenith angle
+               end do
+            else
+               do nw=1,L_NSPECTV
+                  stel_fract(nw)= stel(nw) * fract(ig)
+               end do
+            endif 
+            call optcv(dtauv,tauv,taucumv,plevrad,                 &
+                 qxvaer,qsvaer,gvaer,wbarv,cosbv,tauray,tauaero,   &
+                 tmid,pmid,taugsurf,qvar,muvarrad)
+
+            call sfluxv(dtauv,tauv,taucumv,albv,dwnv,wbarv,cosbv,  &
+                 acosz,stel_fract,gweight,                         &
+                 nfluxtopv,fluxtopvdn,nfluxoutv_nu,nfluxgndv_nu,              &
+                 fmnetv,fluxupv,fluxdnv,fzerov,taugsurf)
+
+         else                          ! during the night, fluxes = 0
+            nfluxtopv       = 0.0d0
+	    fluxtopvdn      = 0.0d0
+            nfluxoutv_nu(:) = 0.0d0
+            nfluxgndv_nu(:) = 0.0d0
+            do l=1,L_NLAYRAD
+               fmnetv(l)=0.0d0
+               fluxupv(l)=0.0d0
+               fluxdnv(l)=0.0d0
+            end do
+         end if
+
+!-----------------------------------------------------------------------
+!     Longwave
+
+         call optci(plevrad,tlevrad,dtaui,taucumi,                  &
+              qxiaer,qsiaer,giaer,cosbi,wbari,tauaero,tmid,pmid,    &
+              taugsurfi,qvar,muvarrad)
+
+         call sfluxi(plevrad,tlevrad,dtaui,taucumi,ubari,albi,      &
+              wnoi,dwni,cosbi,wbari,gweight,nfluxtopi,nfluxtopi_nu, & 
+              fmneti,fluxupi,fluxdni,fluxupi_nu,fzeroi,taugsurfi)
+
+!-----------------------------------------------------------------------
+!     Transformation of the correlated-k code outputs
+!     (into dtlw, dtsw, fluxsurf_lw, fluxsurf_sw, fluxtop_lw, fluxtop_sw)
+
+!     Flux incident at the top of the atmosphere
+         fluxtop_dn(ig)=fluxtopvdn 
+
+         fluxtop_lw(ig)  = real(nfluxtopi)
+         fluxabs_sw(ig)  = real(-nfluxtopv)
+         fluxsurf_lw(ig) = real(fluxdni(L_NLAYRAD))
+         fluxsurf_sw(ig) = real(fluxdnv(L_NLAYRAD))
+
+         if(fluxtop_dn(ig).lt.0.0)then
+            print*,'Achtung! fluxtop_dn has lost the plot!'
+            print*,'fluxtop_dn=',fluxtop_dn(ig)
+            print*,'acosz=',acosz
+            print*,'aerosol=',aerosol(ig,:,:)
+            print*,'temp=   ',pt(ig,:)
+            print*,'pplay=  ',pplay(ig,:)
+            call abort
+         endif
+
+!     Spectral output, for exoplanet observational comparison
+         if(specOLR)then
+            do nw=1,L_NSPECTI 
+               OLR_nu(ig,nw)=nfluxtopi_nu(nw)/DWNI(nw) !JL Normalize to the bandwidth
+            end do
+            do nw=1,L_NSPECTV 
+               !GSR_nu(ig,nw)=nfluxgndv_nu(nw)
+               OSR_nu(ig,nw)=nfluxoutv_nu(nw)/DWNV(nw) !JL Normalize to the bandwidth
+            end do
+         endif
+
+!     Finally, the heating rates
+
+         DO l=2,L_NLAYRAD
+            dtsw(ig,L_NLAYRAD+1-l)=(fmnetv(l)-fmnetv(l-1))  &
+                *glat(ig)/(cpp*scalep*(plevrad(2*l+1)-plevrad(2*l-1)))
+            dtlw(ig,L_NLAYRAD+1-l)=(fmneti(l)-fmneti(l-1))  &
+                *glat(ig)/(cpp*scalep*(plevrad(2*l+1)-plevrad(2*l-1)))
+         END DO      
+
+!     These are values at top of atmosphere
+         dtsw(ig,L_NLAYRAD)=(fmnetv(1)-nfluxtopv)           &
+             *glat(ig)/(cpp*scalep*(plevrad(3)-plevrad(1)))
+         dtlw(ig,L_NLAYRAD)=(fmneti(1)-nfluxtopi)           &
+             *glat(ig)/(cpp*scalep*(plevrad(3)-plevrad(1)))
+
+!     ---------------------------------------------------------------
+      end do                    ! end of big loop over every GCM column (ig = 1:ngrid)
+
+
+!-----------------------------------------------------------------------
+!     Additional diagnostics
+
+!     IR spectral output, for exoplanet observational comparison
+
+
+      if(lastcall.and.(ngrid.eq.1))then  ! could disable the 1D output, they are in the diagfi and diagspec... JL12
+
+           print*,'Saving scalar quantities in surf_vals.out...'
+           print*,'psurf = ', pplev(1,1),' Pa'
+           open(116,file='surf_vals.out')
+           write(116,*) tsurf(1),pplev(1,1),fluxtop_dn(1),         &
+                real(-nfluxtopv),real(nfluxtopi) 
+           close(116)
+
+!          I am useful, please don`t remove me!
+!           if(specOLR)then
+!               open(117,file='OLRnu.out')
+!               do nw=1,L_NSPECTI
+!                  write(117,*) OLR_nu(1,nw)
+!               enddo
+!               close(117)
+!
+!               open(127,file='OSRnu.out')
+!               do nw=1,L_NSPECTV
+!                  write(127,*) OSR_nu(1,nw)
+!               enddo
+!               close(127)
+!           endif
+
+!     OLR vs altitude: do it as a .txt file
+           OLRz=.false.
+           if(OLRz)then
+              print*,'saving IR vertical flux for OLRz...'
+              open(118,file='OLRz_plevs.out')
+              open(119,file='OLRz.out')
+              do l=1,L_NLAYRAD
+                 write(118,*) plevrad(2*l)
+                 do nw=1,L_NSPECTI
+                     write(119,*) fluxupi_nu(l,nw) 
+                  enddo
+              enddo 
+              close(118)
+              close(119)
+           endif
+
+      endif
+
+      ! see physiq.F for explanations about CLFvarying. This is temporary.
+      if (lastcall .and. .not.CLFvarying) then
+        IF( ALLOCATED( gasi ) ) DEALLOCATE( gasi )
+        IF( ALLOCATED( gasv ) ) DEALLOCATE( gasv )
+        IF( ALLOCATED( pgasref ) ) DEALLOCATE( pgasref )
+        IF( ALLOCATED( tgasref ) ) DEALLOCATE( tgasref )
+        IF( ALLOCATED( wrefvar ) ) DEALLOCATE( wrefvar )
+        IF( ALLOCATED( pfgasref ) ) DEALLOCATE( pfgasref )
+        IF ( ALLOCATED(reffrad)) DEALLOCATE(reffrad)
+        IF ( ALLOCATED(nueffrad)) DEALLOCATE(nueffrad)
+      endif
+
+
+    end subroutine callcorrk
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callkeys.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callkeys.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callkeys.h	(revision 222)
@@ -0,0 +1,118 @@
+!
+! For Fortran 77/Fortran 90 compliance always use line continuation
+! symbols '&' in columns 73 and 6
+!
+! Group commons according to their type for minimal performance impact
+
+      COMMON/callkeys_l/callrad,corrk,calldifv,UseTurbDiff,calladj      &
+     &   , co2cond,callsoil                                             &
+     &   , season,diurnal,tlocked,rings_shadow,lwrite                   &
+     &   , callstats,calleofdump                                        &
+     &   , enertest                                                     &
+     &   , callgasvis,continuum,H2Ocont_simple,graybody                 &
+     &   , radfixed                                                     &
+     &   , meanOLR, specOLR                                             &
+     &   , kastprof                                                     &
+     &   , nosurf, oblate                                               &     
+     &   , newtonian, testradtimes                                      &
+     &   , check_cpp_match, force_cpp                                   &
+     &   , rayleigh                                                     &
+     &   , stelbbody                                                    &
+     &   , nearco2cond                                                  &
+     &   , tracer, mass_redistrib, varactive, varfixed                  &
+     &   , sedimentation,water,watercond,waterrain                      &
+     &   , aeroco2,aeroh2o,aeroh2so4,aeroback2lay                       &
+     &   , aerofixco2,aerofixh2o                                        &
+     &   , hydrology, sourceevol                                        &
+     &   , CLFvarying                                                   &
+     &   , strictboundcorrk                                             &                                        
+     &   , ok_slab_ocean                                                &
+     &   , ok_slab_sic                                                  &
+     &   , ok_slab_heat_transp                                          
+
+
+      COMMON/callkeys_i/iaervar,iddist,iradia,startype
+      
+      COMMON/callkeys_r/topdustref,Nmix_co2,dusttau,Fat1AU,stelTbb,     &
+     &                  Tstrat,tplanet,obs_tau_col_tropo,               &
+     &                  obs_tau_col_strato,pres_bottom_tropo,           &
+     &                  pres_top_tropo,pres_bottom_strato,              &
+     &                  pres_top_strato,size_tropo,size_strato,satval,  &
+     &                  CLFfixval,n2mixratio,co2supsat,pceil,albedosnow,&
+     &                  maxicethick,Tsaldiff,tau_relax,cloudlvl,        &
+     &                  icetstep,intheat,flatten,Rmean,J2,MassPlanet
+      
+      logical callrad,corrk,calldifv,UseTurbDiff                        &
+     &   , calladj,co2cond,callsoil                                     &
+     &   , season,diurnal,tlocked,rings_shadow,lwrite                   &
+     &   , callstats,calleofdump                                        &
+     &   , callgasvis,continuum,H2Ocont_simple,graybody                 &
+     &   , strictboundcorrk                                             
+
+      logical enertest
+      logical nonideal
+      logical meanOLR
+      logical specOLR
+      logical kastprof
+      logical newtonian
+      logical check_cpp_match
+      logical force_cpp
+      logical testradtimes
+      logical rayleigh
+      logical stelbbody
+      logical ozone
+      logical nearco2cond
+      logical tracer
+      logical mass_redistrib
+      logical varactive
+      logical varfixed
+      logical radfixed
+      logical sedimentation
+      logical water,watercond,waterrain
+      logical aeroco2,aeroh2o,aeroh2so4,aeroback2lay
+      logical aerofixco2,aerofixh2o
+      logical hydrology
+      logical sourceevol
+      logical CLFvarying
+      logical nosurf
+      logical oblate
+      logical ok_slab_ocean
+      logical ok_slab_sic
+      logical ok_slab_heat_transp
+
+      integer iddist
+      integer iaervar
+      integer iradia
+      integer startype
+
+      real topdustref
+      real Nmix_co2
+      real dusttau
+      real Fat1AU
+      real stelTbb
+      real Tstrat
+      real tplanet
+      real obs_tau_col_tropo
+      real obs_tau_col_strato
+      real pres_bottom_tropo
+      real pres_top_tropo
+      real pres_bottom_strato
+      real pres_top_strato
+      real size_tropo
+      real size_strato
+      real satval
+      real CLFfixval
+      real n2mixratio
+      real co2supsat
+      real pceil
+      real albedosnow
+      real maxicethick
+      real Tsaldiff
+      real tau_relax
+      real cloudlvl
+      real icetstep
+      real intheat
+      real flatten
+      real Rmean
+      real J2
+      real MassPlanet
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callsedim.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callsedim.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/callsedim.F	(revision 222)
@@ -0,0 +1,159 @@
+      SUBROUTINE callsedim(ngrid,nlay, ptimestep,
+     &                pplev,zlev, pt, pdt,
+     &                pq, pdqfi, pdqsed,pdqs_sed,nq)
+
+      use radinc_h, only : naerkind
+      use radii_mod, only: h2o_reffrad
+      use aerosol_mod, only : iaero_h2o
+      USE tracer_h, only : igcm_co2_ice,igcm_h2o_ice,radius,rho_q
+
+      IMPLICIT NONE
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates sedimentation of aerosols depending on their
+!     density and radius.
+!     
+!     Authors
+!     -------
+!     F. Forget (1999)
+!     Tracer generalisation by E. Millour (2009)
+!     
+!==================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+c   arguments:
+c   ----------
+
+      integer,intent(in):: ngrid ! number of horizontal grid points
+      integer,intent(in):: nlay  ! number of atmospheric layers
+      real,intent(in):: ptimestep  ! physics time step (s)
+      real,intent(in):: pplev(ngrid,nlay+1) ! pressure at inter-layers (Pa)
+      real,intent(in):: pt(ngrid,nlay)      ! temperature at mid-layer (K)
+      real,intent(in):: pdt(ngrid,nlay) ! tendency on temperature
+      real,intent(in):: zlev(ngrid,nlay+1)  ! altitude at layer boundaries
+      integer,intent(in) :: nq ! number of tracers
+      real,intent(in) :: pq(ngrid,nlay,nq)  ! tracers (kg/kg)
+      real,intent(in) :: pdqfi(ngrid,nlay,nq)  ! tendency on tracers before
+                                               ! sedimentation (kg/kg.s-1)
+      
+      real,intent(out) :: pdqsed(ngrid,nlay,nq) ! tendency due to sedimentation (kg/kg.s-1)
+      real,intent(out) :: pdqs_sed(ngrid,nq)    ! flux at surface (kg.m-2.s-1)
+      
+c   local:
+c   ------
+
+      INTEGER l,ig, iq
+
+      ! for particles with varying radii:
+      real reffrad(ngrid,nlay,naerkind) ! particle radius (m) 
+      real nueffrad(ngrid,nlay,naerkind) ! aerosol effective radius variance
+
+      real zqi(ngrid,nlay,nq) ! to locally store tracers
+      real zt(ngrid,nlay) ! to locally store temperature (K)
+      real masse (ngrid,nlay) ! Layer mass (kg.m-2)
+      real epaisseur (ngrid,nlay) ! Layer thickness (m)
+      real wq(ngrid,nlay+1) ! displaced tracer mass (kg.m-2)
+c      real dens(ngrid,nlayermx) ! Mean density of the ice part. accounting for dust core
+
+
+      LOGICAL,SAVE :: firstcall=.true.
+
+c    ** un petit test de coherence
+c       --------------------------
+
+      IF (firstcall) THEN
+        firstcall=.false.
+        ! add some tests on presence of required tracers/aerosols:
+        if (water) then
+          if (igcm_h2o_ice.eq.0) then
+            write(*,*) "callsedim error: water=.true.",
+     &                 " but igcm_h2o_ice=0"
+          stop
+          endif
+          if (iaero_h2o.eq.0) then
+            write(*,*) "callsedim error: water=.true.",
+     &                 " but iaero_ho2=0"
+          stop
+          endif
+        endif
+      ENDIF ! of IF (firstcall)
+      
+!=======================================================================
+!     Preliminary calculation of the layer characteristics
+!     (mass (kg.m-2), thickness (m), etc.
+
+      do  l=1,nlay
+        do ig=1, ngrid
+          masse(ig,l)=(pplev(ig,l) - pplev(ig,l+1)) /g 
+          epaisseur(ig,l)= zlev(ig,l+1) - zlev(ig,l)
+          zt(ig,l)=pt(ig,l)+pdt(ig,l)*ptimestep
+        end do
+      end do
+
+!======================================================================
+! Calculate the transport due to sedimentation for each tracer
+! [This has been rearranged by L. Kerber to allow the sedimentation
+!  of general tracers.]
+ 
+      do iq=1,nq
+       if((radius(iq).gt.1.e-9).and.(iq.ne.igcm_co2_ice)) then   
+!         (no sedim for gases, and co2_ice sedim is done in condense_cloud)      
+
+! store locally updated tracers
+
+          do l=1,nlay 
+            do ig=1, ngrid
+              zqi(ig,l,iq)=pq(ig,l,iq)+pdqfi(ig,l,iq)*ptimestep
+            enddo
+          enddo ! of do l=1,nlay
+        
+!======================================================================
+! Sedimentation 
+!======================================================================
+! Water          
+          if (water.and.(iq.eq.igcm_h2o_ice)) then
+            ! compute radii for h2o_ice 
+             call h2o_reffrad(ngrid,zqi(1,1,igcm_h2o_ice),zt,
+     &                reffrad(1,1,iaero_h2o),nueffrad(1,1,iaero_h2o))
+            ! call sedimentation for h2o_ice
+             call newsedim(ngrid,nlay,ngrid*nlay,ptimestep,
+     &            pplev,masse,epaisseur,zt,reffrad(1,1,iaero_h2o),
+     &            rho_q(iq),zqi(1,1,igcm_h2o_ice),wq)
+
+! General Case
+          else 
+             call newsedim(ngrid,nlay,1,ptimestep,
+     &            pplev,masse,epaisseur,zt,radius(iq),rho_q(iq),
+     &            zqi(1,1,iq),wq)
+          endif
+
+!=======================================================================
+!     Calculate the tendencies
+!======================================================================
+
+          do ig=1,ngrid
+!     Ehouarn: with new way of tracking tracers by name, this is simply
+            pdqs_sed(ig,iq) = wq(ig,1)/ptimestep
+          end do
+
+          DO l = 1, nlay
+            DO ig=1,ngrid
+              pdqsed(ig,l,iq)=(zqi(ig,l,iq)-
+     &        (pq(ig,l,iq) + pdqfi(ig,l,iq)*ptimestep))/ptimestep
+            ENDDO
+          ENDDO
+       endif ! of no gases no co2_ice
+      enddo ! of do iq=1,nq
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comcstfi.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comcstfi.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comcstfi.h	(revision 222)
@@ -0,0 +1,9 @@
+!-----------------------------------------------------------------------
+! INCLUDE "comcstfi.h"
+
+      common/comcstfi/pi,rad,g,r,cpp,rcp,dtphys,daysec,mugaz,omeg
+      common/comcstfi/avocado!,molrad,visc
+      
+      real pi,rad,g,r,cpp,rcp,dtphys,daysec,mugaz,omeg
+      real avocado!,molrad,visc
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comdiurn_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comdiurn_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comdiurn_h.F90	(revision 222)
@@ -0,0 +1,10 @@
+
+       module comdiurn_h
+
+       implicit none
+
+       real, allocatable, dimension(:) :: sinlon, coslon, sinlat, coslat
+       logical :: ldiurn
+
+       end module comdiurn_h
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comg1d.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comg1d.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comg1d.h	(revision 222)
@@ -0,0 +1,63 @@
+!.......................................................................
+!  le COMMON pour GRADS-1D
+!  (Utilise pour les sorties format Grads dans la version 1D du modele)
+!
+!  on peut se dire : "on ne sauvera pas plus de 1000 variables ... hein ?"
+!
+      INTEGER g1d_nvarmx
+      PARAMETER(g1d_nvarmx=1000)
+
+!         * g1d_nlayer     ---> nombre de couches verticales
+!         * g1d_nomfich    ---> nom du fichier grads
+!         * g1d_unitfich   ---> code du fichier grads
+!         * g1d_nomctl     ---> nom du fichier ctl
+!         * g1d_unitctl    ---> code du fichier ctl
+!         * g1d_premier    ---> variable logique pour dire si le fichier
+!                               est deja ouvert
+!         * g1d_irec       ---> indice de derniere ecriture
+!         * g1d_nvar       ---> nombre de variables deja definies a la
+!                               derniere ecriture
+!         * g1d_nomvar     ---> noms des vecteurs existants
+!         * g1d_dimvar     ---> taille des vecteurs
+!         * g1d_titrevar   ---> titres des vecteurs
+!         * g1d_tmp1       ---> caractere 
+!         * g1d_tmp2       ---> caractere 
+
+      INTEGER g1d_nlayer
+      CHARACTER*100 g1d_nomfich
+      INTEGER g1d_unitfich
+      CHARACTER*100 g1d_nomctl
+      INTEGER g1d_unitctl
+      LOGICAL g1d_premier
+      LOGICAL g2d_premier
+      INTEGER g1d_irec
+      INTEGER g2d_irec
+      INTEGER g2d_appel
+      INTEGER g1d_nvar
+      CHARACTER*100 g1d_nomvar
+      INTEGER g1d_dimvar
+      CHARACTER*100 g1d_titrevar
+      CHARACTER*100 g1d_tmp1,g1d_tmp2
+
+!     added by RW
+      integer saveG1D
+
+      COMMON/COMG1DI/g1d_nlayer                                         &
+     &             ,g1d_unitfich                                        &
+     &             ,g1d_unitctl                                         &
+     &             ,g1d_irec                                            &
+     &             ,g2d_irec                                            &
+     &             ,g2d_appel                                           &
+     &             ,g1d_nvar                                            &
+     &             ,saveG1D
+      COMMON/COMG1DC/g1d_dimvar(0:g1d_nvarmx)                           &
+     &             ,g1d_nomfich                                         &
+     &             ,g1d_nomctl                                          &
+     &             ,g1d_nomvar(0:g1d_nvarmx)                            &
+     &             ,g1d_titrevar(0:g1d_nvarmx)                          &
+     &             ,g1d_tmp1                                            &
+     &             ,g1d_tmp2                                            
+      COMMON/COMG1DL/g1d_premier                                        &
+     &             ,g2d_premier
+!
+!.......................................................................
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comgeomfi_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comgeomfi_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comgeomfi_h.F90	(revision 222)
@@ -0,0 +1,10 @@
+
+       module comgeomfi_h
+
+       implicit none
+
+       REAL,ALLOCATABLE,DIMENSION(:) :: long,lati,area
+       REAL :: totarea, totarea_planet
+
+       end module comgeomfi_h
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comgeomphy.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comgeomphy.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comgeomphy.F90	(revision 222)
@@ -0,0 +1,23 @@
+module comgeomphy
+   real,save,allocatable :: airephy(:)
+   real,save,allocatable :: cuphy(:)
+   real,save,allocatable :: cvphy(:)
+   real,save,allocatable :: rlatd(:)
+   real,save,allocatable :: rlond(:)
+!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond)
+contains
+  
+  subroutine initcomgeomphy
+  USE mod_phys_lmdz_para, only: klon_omp
+  implicit none
+    
+ 
+    allocate(airephy(klon_omp))
+    allocate(cuphy(klon_omp))
+    allocate(cvphy(klon_omp))
+    allocate(rlatd(klon_omp))
+    allocate(rlond(klon_omp))
+
+  end subroutine initcomgeomphy
+  
+end module comgeomphy
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comhdiff.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comhdiff.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comhdiff.h	(revision 222)
@@ -0,0 +1,15 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/comdissipn.h,v 1.1.1.1 2008-03-27 12:53:06 lmdzadmin Exp $
+!
+!-----------------------------------------------------------------------
+! INCLUDE comdhdiff.h
+
+
+
+      COMMON/comhdiff/                                                  &
+     &     zmasqu(ip1jmp1),zmasqv(ip1jm),alpha_var,                     &     
+     &     unsfv(ip1jm),unsev(ip1jm),unsfu(ip1jmp1),unseu(ip1jmp1),     &
+     &     slab_upstream      
+
+      LOGICAL alpha_var,slab_upstream
+      REAL zmasqu,zmasqv,unsfv,unsev,unsfu,unseu
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comsaison_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comsaison_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comsaison_h.F90	(revision 222)
@@ -0,0 +1,12 @@
+
+       module comsaison_h
+
+       implicit none 
+
+       integer isaison
+       logical callsais
+       real dist_star,declin
+
+       real, allocatable, dimension(:) :: mu0,fract
+
+       end module comsaison_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comsoil_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comsoil_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/comsoil_h.F90	(revision 222)
@@ -0,0 +1,31 @@
+module comsoil_h
+
+implicit none
+! nsoilmx : number of subterranean layers
+!integer, parameter :: nsoilmx = 18 ! for z1=0.0002 m, depth = 18 m => mars case 
+!integer, parameter :: nsoilmx = 13 ! for z1=0.03 m, depth = 104.8 m => earth case
+  integer, parameter :: nsoilmx = 18
+
+  real,save,allocatable,dimension(:) :: layer      ! soil layer depths
+  real,save,allocatable,dimension(:) :: mlayer     ! soil mid-layer depths
+  real,save,allocatable,dimension(:,:) :: inertiedat ! soil thermal inertia
+  real,save :: volcapa    ! soil volumetric heat capacity
+       ! NB: volcapa is read fromn control(35) from physicq start file
+       !     in physdem (or set via tabfi, or initialized in
+       !                 soil_settings.F)
+
+contains
+
+  subroutine ini_comsoil_h(ngrid)
+  
+  implicit none
+  integer,intent(in) :: ngrid ! number of atmospheric columns
+  
+    if (.not.allocated(layer)) allocate(layer(nsoilmx)) !soil layer depths
+    if (.not.allocated(mlayer)) allocate(mlayer(0:nsoilmx-1)) ! soil mid-layer depths
+    if (.not.allocated(inertiedat)) allocate(inertiedat(ngrid,nsoilmx)) ! soil thermal inertia
+  
+  end subroutine ini_comsoil_h
+
+end module comsoil_h
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/condense_cloud.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/condense_cloud.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/condense_cloud.F90	(revision 222)
@@ -0,0 +1,527 @@
+      subroutine condense_cloud(ngrid,nlayer,nq,ptimestep, &
+          pcapcal,pplay,pplev,ptsrf,pt, &
+          pphi,pdt,pdu,pdv,pdtsrf,pu,pv,pq,pdq, &
+          piceco2,psolaralb,pemisurf, &
+          pdtc,pdtsrfc,pdpsrf,pduc,pdvc, &
+          pdqc)
+
+      use radinc_h, only : naerkind
+      use gases_h, only: gfrac, igas_co2
+      use radii_mod, only : co2_reffrad
+      use aerosol_mod, only : iaero_co2
+      USE surfdat_h, only: albedodat, albedice, emisice, emissiv
+      USE comgeomfi_h, only: lati
+      USE tracer_h, only: noms, rho_co2
+
+
+      implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Condense and/or sublime CO2 ice on the ground and in the
+!     atmosphere, and sediment the ice.
+!  
+!     Inputs
+!     ------
+!     ngrid                 Number of vertical columns
+!     nlayer                Number of layers
+!     pplay(ngrid,nlayer)   Pressure layers
+!     pplev(ngrid,nlayer+1) Pressure levels 
+!     pt(ngrid,nlayer)      Temperature (in K)
+!     ptsrf(ngrid)          Surface temperature
+!     
+!     pdt(ngrid,nlayermx)   Time derivative before condensation/sublimation of pt
+!     pdtsrf(ngrid)         Time derivative before condensation/sublimation of ptsrf
+!     pqsurf(ngrid,nq)      Sedimentation flux at the surface (kg.m-2.s-1)
+!     
+!     Outputs
+!     -------
+!     pdpsrf(ngrid)         \  Contribution of condensation/sublimation
+!     pdtc(ngrid,nlayermx)  /  to the time derivatives of Ps, pt, and ptsrf
+!     pdtsrfc(ngrid)       /
+!     
+!     Both
+!     ----
+!     piceco2(ngrid)        CO2 ice at the surface (kg/m2)
+!     psolaralb(ngrid)      Albedo at the surface
+!     pemisurf(ngrid)       Emissivity of the surface
+!
+!     Authors
+!     ------- 
+!     Francois Forget (1996)
+!     Converted to Fortran 90 and slightly modified by R. Wordsworth (2009)
+!     Includes simplifed nucleation by J. Leconte (2011)
+!     
+!==================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "comvert.h"
+#include "callkeys.h"
+
+!-----------------------------------------------------------------------
+!     Arguments
+
+      INTEGER,INTENT(IN) :: ngrid
+      INTEGER,INTENT(IN) :: nlayer
+      INTEGER,INTENT(IN) :: nq
+      REAL,INTENT(IN) :: ptimestep 
+      REAL,INTENT(IN) :: pcapcal(ngrid)
+      REAL,INTENT(IN) :: pplay(ngrid,nlayer)
+      REAL,INTENT(IN) :: pplev(ngrid,nlayer+1)
+      REAL,INTENT(IN) :: ptsrf(ngrid)
+      REAL,INTENT(IN) :: pt(ngrid,nlayer)
+      REAL,INTENT(IN) :: pphi(ngrid,nlayer)
+      REAL,INTENT(IN) :: pdt(ngrid,nlayer)
+      REAL,INTENT(IN) :: pdu(ngrid,nlayer)
+      REAL,INTENT(IN) :: pdv(ngrid,nlayer)
+      REAL,INTENT(IN) :: pdtsrf(ngrid)
+      REAL,INTENT(IN) :: pu(ngrid,nlayer)
+      REAL,INTENT(IN) :: pv(ngrid,nlayer)
+      REAL,INTENT(IN) :: pq(ngrid,nlayer,nq)
+      REAL,INTENT(IN) :: pdq(ngrid,nlayer,nq)
+      REAL,INTENT(INOUT) :: piceco2(ngrid)
+      REAL,INTENT(OUT) :: psolaralb(ngrid)
+      REAL,INTENT(OUT) :: pemisurf(ngrid)
+      REAL,INTENT(OUT) :: pdtc(ngrid,nlayer)
+      REAL,INTENT(OUT) :: pdtsrfc(ngrid)
+      REAL,INTENT(OUT) :: pdpsrf(ngrid)
+      REAL,INTENT(OUT) :: pduc(ngrid,nlayer)
+      REAL,INTENT(OUT) :: pdvc(ngrid,nlayer)
+      REAL,INTENT(OUT) :: pdqc(ngrid,nlayer,nq)
+
+!-----------------------------------------------------------------------
+!     Local variables
+
+      INTEGER l,ig,icap,ilay,it,iq
+
+      REAL reffrad(ngrid,nlayer) ! radius (m) of the co2 ice particles
+      REAL*8 zt(ngrid,nlayermx)
+      REAL zq(ngrid,nlayermx,nq)
+      REAL zcpi
+      REAL ztcond (ngrid,nlayermx)
+      REAL ztnuc (ngrid,nlayermx)
+      REAL ztcondsol(ngrid) 
+      REAL zdiceco2(ngrid)
+      REAL zcondicea(ngrid,nlayermx), zcondices(ngrid)
+      REAL zfallice(ngrid), Mfallice(ngrid) 
+      REAL zmflux(nlayermx+1)
+      REAL zu(nlayermx),zv(nlayermx)
+      REAL ztsrf(ngrid)
+      REAL ztc(nlayermx), ztm(nlayermx+1) 
+      REAL zum(nlayermx+1) , zvm(nlayermx+1)
+      LOGICAL condsub(ngrid)
+      REAL subptimestep
+      Integer Ntime
+      real masse (ngrid,nlayermx), w(ngrid,nlayermx,nq)
+      real wq(ngrid,nlayermx+1)
+      real vstokes,reff
+
+!     Special diagnostic variables
+      real tconda1(ngrid,nlayermx)
+      real tconda2(ngrid,nlayermx)
+      real zdtsig (ngrid,nlayermx)
+      real zdt (ngrid,nlayermx)
+
+!-----------------------------------------------------------------------
+!     Saved local variables
+
+      REAL,SAVE :: latcond=5.9e5
+      REAL,SAVE :: ccond
+      REAL,SAVE :: cpice=1000.
+      REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: emisref
+
+      LOGICAL,SAVE :: firstcall=.true.
+      REAL,EXTERNAL :: SSUM
+
+      REAL,EXTERNAL :: CBRT
+
+      INTEGER,SAVE :: i_co2ice=0      ! co2 ice
+      CHARACTER(LEN=20) :: tracername ! to temporarily store text
+
+      integer igas
+
+      real ppco2
+
+!-----------------------------------------------------------------------
+!     Initializations
+
+      pdqc(1:ngrid,1:nlayer,1:nq)=0
+      pdtc(1:ngrid,1:nlayer)=0
+      zq(1:ngrid,1:nlayer,1:nq)=0
+      zt(1:ngrid,1:nlayer)=0
+
+!     Initialisation
+      IF (firstcall) THEN
+
+         ALLOCATE(emisref(ngrid)) !! this should be deallocated in lastcall...
+
+         ! find CO2 ice tracer
+         do iq=1,nq
+            tracername=noms(iq)
+            if (tracername.eq."co2_ice") then
+               i_co2ice=iq
+            endif
+         enddo
+         
+        write(*,*) "condense_cloud: i_co2ice=",i_co2ice       
+
+        if((i_co2ice.lt.1))then
+           print*,'In condens_cloud but no CO2 ice tracer, exiting.'
+           print*,'Still need generalisation to arbitrary species!'
+           stop
+        endif
+
+         ccond=cpp/(g*latcond)
+         print*,'In condens_cloud: ccond=',ccond,' latcond=',latcond
+
+!          Prepare special treatment if gas is not pure CO2
+             !if (addn2) then
+             !   m_co2   = 44.01E-3 ! CO2 molecular mass (kg/mol)   
+             !   m_noco2 = 28.02E-3 ! N2 molecular mass (kg/mol)  
+!               Compute A and B coefficient use to compute
+!               mean molecular mass Mair defined by
+!               1/Mair = q(ico2)/m_co2 + (1-q(ico2))/m_noco2
+!               1/Mair = A*q(ico2) + B
+             !   A = (1/m_co2 - 1/m_noco2)
+             !   B = 1/m_noco2
+             !endif
+
+!          Minimum CO2 mixing ratio below which mixing occurs with layer above: 
+           !qco2min =0.75  
+
+           firstcall=.false.
+      ENDIF
+      zcpi=1./cpp
+
+!-----------------------------------------------------------------------
+!     Calculation of CO2 condensation / sublimation 
+!
+!     Variables used:
+!     piceco2(ngrid)       amount of co2 ice on the ground  (kg/m2)
+!     zcondicea(ngrid,l)   condensation rate in layer l     (kg/m2/s)
+!     zcondices(ngrid)     condensation rate on the ground  (kg/m2/s)
+!     zfallice(ngrid)      flux of ice falling on surface   (kg/m2/s)
+!     pdtc(ngrid,nlayermx) dT/dt due to phase changes       (K/s)
+     
+
+!     Tendencies initially set to 0 (except pdtc)
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            zcondicea(ig,l) = 0.
+            pduc(ig,l)  = 0
+            pdvc(ig,l)  = 0
+            pdqc(ig,l,i_co2ice)  = 0
+         END DO
+      END DO
+      
+      DO ig=1,ngrid
+         Mfallice(ig) = 0.
+         zfallice(ig) = 0.
+         zcondices(ig) = 0.
+         pdtsrfc(ig) = 0.
+         pdpsrf(ig) = 0.
+         condsub(ig) = .false.
+         zdiceco2(ig) = 0.
+      ENDDO
+
+!-----------------------------------------------------------------------
+!     Atmospheric condensation
+
+
+!     Compute CO2 Volume mixing ratio
+!     -------------------------------
+!      if (addn2) then
+!         DO l=1,nlayer
+!            DO ig=1,ngrid
+!              qco2=pq(ig,l,ico2)+pdq(ig,l,ico2)*ptimestep
+!!             Mean air molecular mass = 1/(q(ico2)/m_co2 + (1-q(ico2))/m_noco2)
+!              mmean=1/(A*qco2 +B)
+!              vmr_co2(ig,l) = qco2*mmean/m_co2 
+!            ENDDO
+!         ENDDO
+!      else
+!         DO l=1,nlayer
+!            DO ig=1,ngrid
+!              vmr_co2(ig,l)=0.5
+!            ENDDO
+!         ENDDO
+!      end if
+
+!     Forecast the atmospheric frost temperature 'ztcond' and nucleation temperature 'ztnuc'
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            ppco2=gfrac(igas_CO2)*pplay(ig,l)
+            call get_tcond_co2(ppco2,ztcond(ig,l))
+            call get_tnuc_co2(ppco2,ztnuc(ig,l))
+         ENDDO
+      ENDDO
+      
+!     Initialize zq and zt at the beginning of the sub-timestep loop
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            zt(ig,l)=pt(ig,l)
+            zq(ig,l,i_co2ice)=pq(ig,l,i_co2ice)
+            IF( zq(ig,l,i_co2ice).lt.-1.e-6 ) THEN
+               print*,'Uh-oh, zq = ',zq(ig,l,i_co2ice),'at ig,l=',ig,l
+               if(l.eq.1)then
+                  print*,'Perhaps the atmosphere is collapsing on surface...?'
+               endif
+            END IF
+         ENDDO
+      ENDDO
+
+!     Calculate the mass of each atmospheric layer (kg.m-2)
+      do  ilay=1,nlayer
+         DO ig=1,ngrid
+            masse(ig,ilay)=(pplev(ig,ilay) - pplev(ig,ilay+1)) /g
+         end do
+      end do
+
+!     -----------------------------------------------
+!     START CONDENSATION/SEDIMENTATION SUB-TIME LOOP
+!     -----------------------------------------------
+      Ntime =  20               ! number of sub-timestep 
+      subptimestep = ptimestep/float(Ntime)           
+
+      DO it=1,Ntime
+
+!     Add the tendencies from other physical processes at each subtimstep
+         DO l=1,nlayer
+            DO ig=1,ngrid
+               zt(ig,l)   = zt(ig,l)   + pdt(ig,l)   * subptimestep
+               zq(ig,l,i_co2ice) = zq(ig,l,i_co2ice) + pdq(ig,l,i_co2ice) * subptimestep
+            END DO
+         END DO
+
+
+!     Gravitational sedimentation
+            
+!     sedimentation computed from radius computed from q in module radii_mod
+	 call co2_reffrad(ngrid,nq,zq,reffrad)
+	 
+         do  ilay=1,nlayer
+            DO ig=1,ngrid
+
+               reff = reffrad(ig,ilay)
+
+               call stokes                      &
+                   (pplev(ig,ilay),pt(ig,ilay), &
+                    reff,vstokes,rho_co2)
+
+               !w(ig,ilay,i_co2ice) = 0.0
+               w(ig,ilay,i_co2ice) = vstokes *  subptimestep * &
+                   pplev(ig,ilay)/(r*pt(ig,ilay))
+
+            end do
+         end do
+
+!     Computing q after sedimentation
+
+         call vlz_fi(ngrid,zq(1,1,i_co2ice),2.,masse,w(1,1,i_co2ice),wq)
+
+
+!     Progressively accumulating the flux to the ground
+!     Mfallice is the total amount of ice fallen to the ground
+         DO ig=1,ngrid
+            Mfallice(ig) =  Mfallice(ig) + wq(ig,i_co2ice)
+         end do
+
+
+!     Condensation / sublimation in the atmosphere
+!     --------------------------------------------
+!     (calculation of zcondicea, zfallice and pdtc)
+!     (MODIFICATIONS FOR EARLY MARS: falling heat neglected, condensation
+!     of CO2 into tracer i_co2ice)
+
+         DO l=nlayer , 1, -1
+            DO ig=1,ngrid
+               pdtc(ig,l)=0.
+
+
+   !     ztcond-> ztnuc in test beneath to nucleate only when super saturation occurs(JL 2011)
+               IF ((zt(ig,l).LT.ztnuc(ig,l)).or.(zq(ig,l,i_co2ice).gt.1.E-10)) THEN 
+                  condsub(ig)=.true.
+                  pdtc(ig,l)   = (ztcond(ig,l) - zt(ig,l))/subptimestep
+                  pdqc(ig,l,i_co2ice) = pdtc(ig,l)*ccond*g
+
+!     Case when the ice from above sublimes entirely
+                  IF ((zq(ig,l,i_co2ice).lt.-pdqc(ig,l,i_co2ice)*subptimestep) &
+                      .AND. (zq(ig,l,i_co2ice).gt.0)) THEN
+
+                     pdqc(ig,l,i_co2ice) = -zq(ig,l,i_co2ice)/subptimestep
+                     pdtc(ig,l)   =-zq(ig,l,i_co2ice)/(ccond*g*subptimestep)
+
+                  END IF
+
+!     Temperature and q after condensation
+                  zt(ig,l)   = zt(ig,l)   + pdtc(ig,l)   * subptimestep
+                  zq(ig,l,i_co2ice) = zq(ig,l,i_co2ice) + pdqc(ig,l,i_co2ice) * subptimestep
+               END IF
+
+            ENDDO
+         ENDDO
+      ENDDO                     ! end of subtimestep loop
+
+!     Computing global tendencies after the subtimestep
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            pdtc(ig,l) = &
+              (zt(ig,l) - (pt(ig,l) + pdt(ig,l)*ptimestep))/ptimestep
+            pdqc(ig,l,i_co2ice) = &
+              (zq(ig,l,i_co2ice)-(pq(ig,l,i_co2ice)+pdq(ig,l,i_co2ice)*ptimestep))/ptimestep
+         END DO
+      END DO
+      DO ig=1,ngrid
+         zfallice(ig) = Mfallice(ig)/ptimestep
+      END DO
+
+
+!-----------------------------------------------------------------------
+!     Condensation/sublimation on the ground
+!     (calculation of zcondices and pdtsrfc)
+
+!     forecast of ground temperature ztsrf and frost temperature ztcondsol
+      DO ig=1,ngrid
+         ppco2=gfrac(igas_CO2)*pplay(ig,1)
+         call get_tcond_co2(ppco2,ztcondsol(ig))
+         
+         ztsrf(ig) = ptsrf(ig)
+
+         if((ztsrf(ig).le.ztcondsol(ig)+2.0).and.(ngrid.eq.1))then
+            print*,'CO2 is condensing on the surface in 1D. This atmosphere is doomed.'
+            print*,'T_surf = ',ztsrf,'K'
+            print*,'T_cond = ',ztcondsol,'K'
+            open(116,file='surf_vals.out')
+            write(116,*) 0.0, pplev(1,1), 0.0, 0.0
+            close(116)
+            call abort
+         endif
+
+         ztsrf(ig) = ptsrf(ig) + pdtsrf(ig)*ptimestep
+
+      ENDDO
+     
+      DO ig=1,ngrid
+         IF(ig.GT.ngrid/2+1) THEN
+            icap=2
+         ELSE
+            icap=1
+         ENDIF
+
+!     Loop over where we have condensation / sublimation
+         IF ((ztsrf(ig) .LT. ztcondsol(ig)) .OR.           &        ! ground condensation
+                    (zfallice(ig).NE.0.) .OR.              &        ! falling snow
+                    ((ztsrf(ig) .GT. ztcondsol(ig)) .AND.  &        ! ground sublimation
+                    ((piceco2(ig)+zfallice(ig)*ptimestep) .NE. 0.))) THEN
+            condsub(ig) = .true.
+
+!     Condensation or partial sublimation of CO2 ice
+            zcondices(ig)=pcapcal(ig)*(ztcondsol(ig)-ztsrf(ig)) &
+                /(latcond*ptimestep)         
+            pdtsrfc(ig) = (ztcondsol(ig) - ztsrf(ig))/ptimestep
+
+!     If the entire CO_2 ice layer sublimes
+!     (including what has just condensed in the atmosphere)
+            IF((piceco2(ig)/ptimestep+zfallice(ig)).LE. &
+                -zcondices(ig))THEN
+               zcondices(ig) = -piceco2(ig)/ptimestep - zfallice(ig)
+               pdtsrfc(ig)=(latcond/pcapcal(ig))*       &
+                   (zcondices(ig))
+            END IF
+
+!     Changing CO2 ice amount and pressure
+
+            zdiceco2(ig) = zcondices(ig) + zfallice(ig)
+            piceco2(ig)  = piceco2(ig) + zdiceco2(ig)*ptimestep
+            pdpsrf(ig)   = -zdiceco2(ig)*g
+
+            IF(ABS(pdpsrf(ig)*ptimestep).GT.pplev(ig,1)) THEN
+               PRINT*,'STOP in condens'
+               PRINT*,'condensing more than total mass'
+               PRINT*,'Grid point ',ig
+               PRINT*,'Ps = ',pplev(ig,1)
+               PRINT*,'d Ps = ',pdpsrf(ig)
+               STOP
+            ENDIF
+         END IF
+      ENDDO
+
+!     Surface albedo and emissivity of the ground below the snow (emisref)
+!     --------------------------------------------------------------------
+      DO ig=1,ngrid
+         IF(lati(ig).LT.0.) THEN
+            icap=2 ! Southern Hemisphere
+         ELSE
+            icap=1 ! Nortnern hemisphere
+         ENDIF
+
+         if(.not.piceco2(ig).ge.0.) THEN
+            if(piceco2(ig).le.-1.e-8) print*,   &
+                'WARNING in condense_co2cloud: piceco2(',ig,')=', piceco2(ig)
+            piceco2(ig)=0.
+         endif
+         if (piceco2(ig).gt.0) then
+            psolaralb(ig) = albedice(icap)
+            emisref(ig)   = emisice(icap)
+         else
+            psolaralb(ig) = albedodat(ig)
+            emisref(ig)   = emissiv
+            pemisurf(ig)  = emissiv
+         end if
+      end do
+
+      return
+    end subroutine condense_cloud
+
+!-------------------------------------------------------------------------
+    subroutine get_tcond_co2(p,tcond)
+!   Calculates the condensation temperature for CO2
+
+      implicit none
+
+#include "callkeys.h"
+
+      real p, peff, tcond
+      real, parameter :: ptriple=518000.0
+
+      peff=p
+
+      if(peff.lt.ptriple)then
+         tcond = (-3167.8)/(log(.01*peff)-23.23) ! Fanale's formula
+      else
+         tcond = 684.2-92.3*log(peff)+4.32*log(peff)**2 
+         ! liquid-vapour transition (based on CRC handbook 2003 data)
+      endif
+      return
+
+    end subroutine get_tcond_co2
+    
+    
+    
+ 
+!-------------------------------------------------------------------------
+    subroutine get_tnuc_co2(p,tnuc)
+!   Calculates the nucleation temperature for CO2, based on a simple super saturation criterion 
+!     (JL 2011)
+
+      implicit none
+
+#include "callkeys.h"
+
+      real p, peff, tnuc
+      real, parameter :: ptriple=518000.0
+
+      peff=p/co2supsat
+
+      if(peff.lt.ptriple)then
+         tnuc = (-3167.8)/(log(.01*peff)-23.23) ! Fanale's formula
+      else
+         tnuc = 684.2-92.3*log(peff)+4.32*log(peff)**2 
+         ! liquid-vapour transition (based on CRC handbook 2003 data)
+      endif
+      return
+
+    end subroutine get_tnuc_co2
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/convadj.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/convadj.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/convadj.F	(revision 222)
@@ -0,0 +1,418 @@
+      subroutine convadj(ngrid,nlay,nq,ptimestep,
+     &                   pplay,pplev,ppopsk,
+     &                   pu,pv,ph,pq,
+     &                   pdufi,pdvfi,pdhfi,pdqfi,
+     &                   pduadj,pdvadj,pdhadj,
+     &                   pdqadj)
+
+      USE tracer_h
+
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates dry convective adjustment. If one tracer is CO2,
+!     we take into account the molecular mass variation (e.g. when
+!     CO2 condenses) to trigger convection (F. Forget 01/2005)
+!
+!     Authors
+!     -------
+!     Original author unknown.
+!     Modif. 2005 by F. Forget.
+!     
+!==================================================================
+
+!     ------------
+!     Declarations
+!     ------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+!     Arguments
+!     ---------
+
+      INTEGER ngrid,nlay
+      REAL ptimestep
+      REAL ph(ngrid,nlay),pdhfi(ngrid,nlay),pdhadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1),ppopsk(ngrid,nlay)
+      REAL pu(ngrid,nlay),pdufi(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvfi(ngrid,nlay),pdvadj(ngrid,nlay)
+
+!     Tracers
+      integer nq
+      real pq(ngrid,nlay,nq), pdqfi(ngrid,nlay,nq)
+      real pdqadj(ngrid,nlay,nq)
+
+
+!     Local
+!     -----
+
+      INTEGER ig,i,l,l1,l2,jj
+      INTEGER jcnt, jadrs(ngrid)
+
+      REAL sig(nlayermx+1),sdsig(nlayermx),dsig(nlayermx)
+      REAL zu(ngrid,nlayermx),zv(ngrid,nlayermx)
+      REAL zh(ngrid,nlayermx)
+      REAL zu2(ngrid,nlayermx),zv2(ngrid,nlayermx)
+      REAL zh2(ngrid,nlayermx), zhc(ngrid,nlayermx)
+      REAL zhm,zsm,zdsm,zum,zvm,zalpha,zhmc
+
+!     Tracers
+      INTEGER iq,ico2
+      save ico2
+      REAL zq(ngrid,nlayermx,nq), zq2(ngrid,nlayermx,nq)
+      REAL zqm(nq),zqco2m
+      real m_co2, m_noco2, A , B
+      save A, B
+
+      real mtot1, mtot2 , mm1, mm2
+       integer l1ref, l2ref
+      LOGICAL vtest(ngrid),down,firstcall
+      save firstcall
+      data firstcall/.true./
+
+!     for conservation test
+      real masse,cadjncons
+
+      EXTERNAL SCOPY
+
+!     --------------
+!     Initialisation
+!     --------------
+
+      IF (firstcall) THEN 
+        ico2=0
+        if (tracer) then
+!     Prepare Special treatment if one of the tracers is CO2 gas
+           do iq=1,nq
+             if (noms(iq).eq."co2") then
+                print*,'dont go there'
+                stop
+                ico2=iq
+                m_co2 = 44.01E-3  ! CO2 molecular mass (kg/mol)   
+                m_noco2 = 33.37E-3  ! Non condensible mol mass (kg/mol)   
+!               Compute A and B coefficient use to compute
+!               mean molecular mass Mair defined by
+!               1/Mair = q(ico2)/m_co2 + (1-q(ico2))/m_noco2
+!               1/Mair = A*q(ico2) + B
+                A =(1/m_co2 - 1/m_noco2)
+                B=1/m_noco2
+             end if
+           enddo
+        endif
+        firstcall=.false.
+      ENDIF ! of IF (firstcall)
+
+      DO l=1,nlay
+         DO ig=1,ngrid
+            zh(ig,l)=ph(ig,l)+pdhfi(ig,l)*ptimestep
+            zu(ig,l)=pu(ig,l)+pdufi(ig,l)*ptimestep
+            zv(ig,l)=pv(ig,l)+pdvfi(ig,l)*ptimestep
+         ENDDO
+      ENDDO
+
+      if(tracer) then      
+        DO iq =1, nq
+         DO l=1,nlay
+           DO ig=1,ngrid
+              zq(ig,l,iq)=pq(ig,l,iq)+pdqfi(ig,l,iq)*ptimestep
+           ENDDO
+         ENDDO
+        ENDDO
+      end if
+
+      CALL scopy(ngrid*nlay,zh,1,zh2,1)
+      CALL scopy(ngrid*nlay,zu,1,zu2,1)
+      CALL scopy(ngrid*nlay,zv,1,zv2,1)
+      CALL scopy(ngrid*nlay*nq,zq,1,zq2,1)
+
+!     -----------------------------
+!     Detection of unstable columns
+!     -----------------------------
+!     If ph(above) < ph(below) we set vtest=.true.
+
+      DO ig=1,ngrid
+        vtest(ig)=.false.
+      ENDDO
+
+      if (ico2.ne.0) then
+!     Special case if one of the tracers is CO2 gas
+         DO l=1,nlay
+           DO ig=1,ngrid
+             zhc(ig,l) = zh2(ig,l)*(A*zq2(ig,l,ico2)+B)
+           ENDDO
+         ENDDO
+       else
+          CALL scopy(ngrid*nlay,zh2,1,zhc,1)
+       end if
+
+!     Find out which grid points are convectively unstable
+      DO l=2,nlay
+        DO ig=1,ngrid
+          IF(zhc(ig,l).LT.zhc(ig,l-1)) vtest(ig)=.true.
+        ENDDO
+      ENDDO
+
+!     Make a list of them
+      jcnt=0
+      DO ig=1,ngrid
+         IF(vtest(ig)) THEN
+            jcnt=jcnt+1
+            jadrs(jcnt)=ig
+         ENDIF
+      ENDDO
+
+
+!     ---------------------------------------------------------------
+!     Adjustment of the "jcnt" unstable profiles indicated by "jadrs"
+!     ---------------------------------------------------------------
+
+      DO jj = 1, jcnt   ! loop on every convective grid point
+
+          i = jadrs(jj)
+ 
+!     Calculate sigma in this column
+          DO l=1,nlay+1
+            sig(l)=pplev(i,l)/pplev(i,1)
+        
+          ENDDO
+         DO l=1,nlay
+            dsig(l)=sig(l)-sig(l+1)
+            sdsig(l)=ppopsk(i,l)*dsig(l)
+         ENDDO
+          l2 = 1
+
+!     Test loop upwards on l2
+
+          DO
+            l2 = l2 + 1
+            IF (l2 .GT. nlay) EXIT
+            IF (zhc(i, l2) .LT. zhc(i, l2-1)) THEN
+ 
+!     l2 is the highest level of the unstable column
+ 
+              l1 = l2 - 1
+              l  = l1
+              zsm = sdsig(l2)
+              zdsm = dsig(l2)
+              zhm = zh2(i, l2)
+              if(ico2.ne.0) zqco2m = zq2(i,l2,ico2)
+
+!     Test loop downwards
+
+              DO
+                zsm = zsm + sdsig(l)
+                zdsm = zdsm + dsig(l)
+                zhm = zhm + sdsig(l) * (zh2(i, l) - zhm) / zsm
+                if(ico2.ne.0) then
+                  zqco2m = 
+     &            zqco2m + dsig(l) * (zq2(i,l,ico2) - zqco2m) / zdsm
+                  zhmc = zhm*(A*zqco2m+B)
+                else 
+                  zhmc = zhm
+                end if
+ 
+!     do we have to extend the column downwards?
+ 
+                down = .false.
+                IF (l1 .ne. 1) then    !--  and then
+                  IF (zhmc .lt. zhc(i, l1-1)) then
+                    down = .true.
+                  END IF
+                END IF
+ 
+                ! this could be a problem...
+
+                if (down) then
+ 
+                  l1 = l1 - 1
+                  l  = l1
+ 
+                else
+ 
+!     can we extend the column upwards?
+ 
+                  if (l2 .eq. nlay) exit
+ 
+                  if (zhc(i, l2+1) .ge. zhmc) exit
+
+                  l2 = l2 + 1
+                  l  = l2
+
+                end if
+
+              enddo
+
+!     New constant profile (average value)
+
+
+              zalpha=0.
+              zum=0.
+              zvm=0.
+              do iq=1,nq
+                zqm(iq) = 0.
+              end do
+              DO l = l1, l2
+                if(ico2.ne.0) then
+                  zalpha=zalpha+
+     &            ABS(zhc(i,l)/(A+B*zqco2m) -zhm)*dsig(l)
+                else
+                  zalpha=zalpha+ABS(zh2(i,l)-zhm)*dsig(l)
+                endif
+                zh2(i, l) = zhm
+!     modifs by RDW !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+                zum=zum+dsig(l)*zu2(i,l)
+                zvm=zvm+dsig(l)*zv2(i,l)
+!                zum=zum+dsig(l)*zu(i,l)
+!                zvm=zvm+dsig(l)*zv(i,l)
+                do iq=1,nq
+                   zqm(iq) = zqm(iq)+dsig(l)*zq2(i,l,iq)
+!                   zqm(iq) = zqm(iq)+dsig(l)*zq(i,l,iq)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!     to conserve tracers/ KE, we must calculate zum, zvm and zqm using 
+!     the up-to-date column values. If we do not do this, there are cases 
+!     where convection stops at one level and starts at the next where we
+!     can break conservation of stuff (particularly tracers) significantly.
+
+                end do
+              ENDDO
+              zalpha=zalpha/(zhm*(sig(l1)-sig(l2+1)))
+              zum=zum/(sig(l1)-sig(l2+1))
+              zvm=zvm/(sig(l1)-sig(l2+1))
+              do iq=1,nq
+                 zqm(iq) = zqm(iq)/(sig(l1)-sig(l2+1))
+              end do
+
+              IF(zalpha.GT.1.) THEN
+                 zalpha=1.
+              ELSE
+!                IF(zalpha.LT.0.) STOP
+                 IF(zalpha.LT.1.e-4) zalpha=1.e-4
+              ENDIF
+
+              DO l=l1,l2
+                 zu2(i,l)=zu2(i,l)+zalpha*(zum-zu2(i,l))
+                 zv2(i,l)=zv2(i,l)+zalpha*(zvm-zv2(i,l))
+                 do iq=1,nq
+!                  zq2(i,l,iq)=zq2(i,l,iq)+zalpha*(zqm(iq)-zq2(i,l,iq)) 
+                   zq2(i,l,iq)=zqm(iq)
+                 end do
+              ENDDO
+              if (ico2.ne.0) then
+                DO l=l1, l2
+                  zhc(i,l) = zh2(i,l)*(A*zq2(i,l,ico2)+B)
+                ENDDO
+              end if
+
+
+              l2 = l2 + 1
+
+            END IF   ! End of l1 to l2 instability treatment
+                     ! We now continue to test from l2 upwards
+
+          ENDDO   ! End of upwards loop on l2
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!     check conservation
+         cadjncons=0.0
+         if(water)then
+         do l = 1, nlay
+            masse = (pplev(i,l) - pplev(i,l+1))/g
+            iq    = igcm_h2o_vap
+            cadjncons = cadjncons + 
+     &           masse*(zq2(i,l,iq)-zq(i,l,iq))/ptimestep 
+         end do
+         endif
+
+         if(cadjncons.lt.-1.e-6)then
+            print*,'convadj has just crashed...'
+            print*,'i  = ',i
+            print*,'l1 = ',l1
+            print*,'l2 = ',l2
+            print*,'cadjncons        = ',cadjncons
+         do l = 1, nlay
+            print*,'dsig         = ',dsig(l)
+         end do         
+         do l = 1, nlay
+            print*,'dsig         = ',dsig(l)
+         end do
+         do l = 1, nlay
+            print*,'sig         = ',sig(l)
+         end do
+         do l = 1, nlay
+            print*,'pplay(ig,:)         = ',pplay(i,l)
+         end do
+         do l = 1, nlay+1
+            print*,'pplev(ig,:)         = ',pplev(i,l)
+         end do
+         do l = 1, nlay
+            print*,'ph(ig,:)         = ',ph(i,l)
+         end do
+         do l = 1, nlay
+            print*,'ph(ig,:)         = ',ph(i,l)
+         end do
+         do l = 1, nlay
+            print*,'ph(ig,:)         = ',ph(i,l)
+         end do
+         do l = 1, nlay
+            print*,'zh(ig,:)         = ',zh(i,l)
+         end do
+         do l = 1, nlay
+            print*,'zh2(ig,:)        = ',zh2(i,l)
+         end do
+         do l = 1, nlay
+            print*,'zq(ig,:,vap)     = ',zq(i,l,igcm_h2o_vap)
+         end do
+         do l = 1, nlay
+            print*,'zq2(ig,:,vap)    = ',zq2(i,l,igcm_h2o_vap)
+         end do
+            print*,'zqm(vap)         = ',zqm(igcm_h2o_vap)
+            print*,'jadrs=',jadrs
+
+            call abort
+         endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+      ENDDO
+
+      DO l=1,nlay
+        DO ig=1,ngrid
+          pdhadj(ig,l)=(zh2(ig,l)-zh(ig,l))/ptimestep
+          pduadj(ig,l)=(zu2(ig,l)-zu(ig,l))/ptimestep
+          pdvadj(ig,l)=(zv2(ig,l)-zv(ig,l))/ptimestep
+        ENDDO
+      ENDDO
+
+      if(tracer) then 
+        do iq=1, nq
+          do  l=1,nlay
+            DO ig=1,ngrid
+              pdqadj(ig,l,iq)=(zq2(ig,l,iq)-zq(ig,l,iq))/ptimestep 
+            end do 
+          end do 
+        end do 
+      end if
+
+
+!     output
+!      if (ngrid.eq.1) then
+!         ig=1
+!         iq =1 
+!         write(*,*)'**** l, pq(ig,l,iq),zq(ig,l,iq),zq2(ig,l,iq)'  
+!         do l=nlay,1,-1
+!           write(*,*) l, pq(ig,l,iq),zq(ig,l,iq),zq2(ig,l,iq)
+!         end do
+!      end if
+
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cp_neutral.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cp_neutral.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cp_neutral.F90	(revision 222)
@@ -0,0 +1,37 @@
+double precision function cp_neutral(T)
+
+  use gases_h
+
+  implicit none
+
+  ! inputs
+  double precision T
+
+
+  ! this function has been disabled in gradients_kcm.F90 because it doesnt
+  ! work if you have gaseous mixtures. need to decide whether to generalise
+  ! it or simply remove entirely...
+
+  ! Cp_n : cf CO2 dans abe&matsui (1988)
+  !cp_neutral = (22.26+5.981d-2*T-3.501d-5*T**2+7.469d-9*T**3)/m_n
+
+  if(trim(gnom(1)).eq.'N2_')then
+     cp_neutral = 1040.0
+  elseif(trim(gnom(1)).eq.'H2_')then
+     cp_neutral = 14310.0
+  else
+     print*,'Gas not recognised in cp_neutral!'
+     call abort
+  endif
+
+  
+end function cp_neutral
+
+
+
+
+
+
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cpdet.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cpdet.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cpdet.F	(revision 222)
@@ -0,0 +1,123 @@
+! ADAPTATION GCM POUR CP(T)
+c======================================================================
+c S. Lebonnois, 10/2007:
+c
+c VENUS: Cp(T) = cpp*(T/T0)^nu 
+c avec T0=460. et nu=0.35
+c cpp=RCPD=cp0 = 1000.
+c R/RCPD = RKAPPA
+c
+c La fonction d'Exner reste pk = RCPD*(play/pref)**RKAPPA
+c 
+c T et teta (temperature potentielle) sont liees par:
+c 
+c   integrale[teta a T](cp/T dT) = integrale[pref a p](R/p dp)
+c
+c Dans le cas de l'expression pour Venus, ca donne:
+c
+c   teta**nu = T**nu - nu * T0**nu * ln[ (p/pref)**RKAPPA ]
+c ou
+c   teta**nu = T**nu - nu * T0**nu * ln[pk/RCPD]
+c
+c On passe de T a teta par t2tpot(t,teta,pk)
+c On passe de teta a T par tpot2t(teta,t,pk)
+c
+c Pour DT <-> Dteta, on utilise: dteta = dT *(T/teta)**(nu-1)
+c -> routine dt2dtpot(dt,dteta,t,teta) 
+c (utilisee seulement pour le contregradient)
+c
+c======================================================================
+
+      FUNCTION cpdet(t)
+      IMPLICIT none
+#include "cpdet.h"
+
+      real cpdet,t
+
+      cpdet = cp0*(t/t0)**nu
+
+      return
+      end
+      
+c======================================================================
+c======================================================================
+
+      SUBROUTINE t2tpot(npoints,yt, yteta, ypk)
+      IMPLICIT none
+c======================================================================
+c Arguments:
+c
+c yt   --------input-R- Temperature
+c yteta-------output-R- Temperature potentielle
+c ypk  --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA
+c
+c======================================================================
+#include "cpdet.h"
+
+      integer npoints
+      REAL    yt(npoints), yteta(npoints), ypk(npoints)
+      
+      yteta = yt**nu - nu * t0**nu * log(ypk/cp0)
+      yteta = yteta**(1./nu)
+        
+
+      !yteta = yt/ypk
+
+
+      return
+      end
+
+c======================================================================
+c======================================================================
+
+      SUBROUTINE tpot2t(npoints,yteta, yt, ypk)
+      IMPLICIT none
+c======================================================================
+c Arguments:
+c
+c yteta--------input-R- Temperature potentielle
+c yt   -------output-R- Temperature
+c ypk  --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA
+c
+c======================================================================
+#include "cpdet.h"
+
+      integer npoints
+      REAL yt(npoints), yteta(npoints), ypk(npoints)
+
+      yt = yteta**nu + nu * t0**nu * log(ypk/cp0)
+      yt = yt**(1./nu)
+
+      !yt = yteta*ypk
+
+      return
+      end
+
+c$$$c======================================================================
+c$$$c======================================================================
+c$$$
+c$$$      SUBROUTINE dt2dtpot(npoints,ydt, ydteta, yt, yteta, ypk, ydpk)
+c$$$      IMPLICIT none
+c$$$c======================================================================
+c$$$c Arguments:
+c$$$c
+c$$$c ydt  --------input-R- D Temperature
+c$$$c ydteta------output-R- D Temperature potentielle
+c$$$c yt   --------input-R- Temperature
+c$$$c yteta--------input-R- Temperature potentielle
+c$$$c ypk  --------input-R- Fonction d'Exner: RCPD*(pplay/pref)**RKAPPA
+c$$$c ydpk  -------input-R- D Fonction d'Exner
+c$$$c
+c$$$c======================================================================
+c$$$#include "cpdet.h"
+c$$$
+c$$$      integer npoints
+c$$$      REAL    ydt(npoints), ydteta(npoints), ydpk(npoints)
+c$$$      REAL    yt(npoints), yteta(npoints), ypk(npoints)
+c$$$      
+c$$$      ydteta =  yteta**(1.-nu)* (ydt * yt**(nu-1.) 
+c$$$     .                           - t0**nu * ydpk / ypk)
+c$$$        
+c$$$      return
+c$$$      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cpdet.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cpdet.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cpdet.h	(revision 222)
@@ -0,0 +1,12 @@
+!-----------------------------------------------------------------------
+! INCLUDE cpdet.h
+
+      real cp0,t0,nu
+!      parameter (cp0 = 1000.) !doit etre egal a cpp (dyn) et RCPD (phy)
+      parameter (cp0 = 800.) !doit etre egal a cpp (dyn) et RCPD (phy)
+!      parameter (t0  = 460.)
+      parameter (t0  = 480.)
+!      parameter (t0  = 300.)
+      parameter (nu  = 0.35)
+!      parameter (nu  = 1.0)
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cvmgp.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cvmgp.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cvmgp.F	(revision 222)
@@ -0,0 +1,14 @@
+      FUNCTION cvmgp(x1,x2,x3)
+      IMPLICIT NONE
+
+      REAL x1,x2,x3,cvmgp
+
+      IF(x3.ge.0) then 
+        cvmgp=x1
+      ELSE
+        cvmgp=x2
+      ENDIF
+
+      RETURN
+      END
+C
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cvmgt.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cvmgt.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/cvmgt.F	(revision 222)
@@ -0,0 +1,15 @@
+      FUNCTION cvmgt(x1,x2,l)
+      IMPLICIT NONE
+
+      REAL x1,x2,cvmgt
+      LOGICAL l
+
+      IF(l) then 
+        cvmgt=x1
+      ELSE
+        cvmgt=x2
+      ENDIF
+
+      RETURN
+      END
+C
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/datafile_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/datafile_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/datafile_mod.F90	(revision 222)
@@ -0,0 +1,14 @@
+!-----------------------------------------------------------------------
+      module datafile_mod
+!  Address of the directory containing tables of data needed by the UCM
+      implicit none
+
+      ! Default for Berserker @ UChicago:
+!      character(len=300) :: datadir='/home/rwordsworth/datagcm'
+      ! Default for Gnome Idataplex:
+!      character(len=300) :: datadir='/san/home/rdword/gcm/datagcm'
+      ! Default for LMD machines:
+      character(len=300) :: datadir='/u/rwlmd/datagcm'
+
+      end module datafile_mod
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/datareadnc.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/datareadnc.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/datareadnc.F	(revision 222)
@@ -0,0 +1,287 @@
+c=======================================================================
+      SUBROUTINE datareadnc(relief,filename,phisinit,alb,ith,
+     .                    zmea,zstd,zsig,zgam,zthe)
+c=======================================================================
+c
+c
+c   Author: F. Hourdin      01/1997
+c   -------
+c
+c   Object: To read data from Martian surface to use in a GCM
+c   ------                from NetCDF file "surface.nc"
+c
+c
+c   Arguments:
+c   ----------
+c
+c     Inputs:
+c     ------
+c
+c     Outputs:
+c     --------
+c
+c=======================================================================
+c   donnees ALBEDO, INERTIE THERMIQUE, RELIEF:
+c
+c       Ces donnees sont au format NetCDF dans le fichier "surface.nc"
+c
+c   360 valeurs en longitude (de -179.5 a 179.5)
+c   180 valeurs en latitudes (de 89.5 a -89.5)
+c
+c   Pour les passer au format de la grille, on utilise "interp_horiz.F"
+c
+c   Il faut donc que ces donnees soient au format grille scalaire
+c               (imold+1 jmold+1)
+c       avec passage des coordonnees de la "boite" (rlonu, rlatv)
+c
+c   On prend imd (d pour donnees!) 
+c           imd = 360 avec copie de la 1ere valeur sur la imd+1 
+c                   (rlonud de -179 a -181)
+c           jmd = 179 
+c                   (rlatvd de 89 a -89)
+c=======================================================================
+
+      use datafile_mod, only: datadir
+! to use  'getin'
+      USE ioipsl_getincom 
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comconst.h"
+#include "netcdf.inc"
+
+c=======================================================================
+c   Declarations:
+C=======================================================================
+
+      INTEGER    imd,jmd,imdp1,jmdp1
+      parameter    (imd=360,jmd=179,imdp1=361,jmdp1=180)
+
+      INTEGER    iimp1
+      parameter    (iimp1=iim+1-1/iim)
+
+      character(len=3),intent(inout) :: relief*3
+      character(len=*),intent(in) :: filename ! surface.nc file
+      real,intent(out) :: phisinit(iimp1*jjp1) ! surface geopotential
+      real,intent(out) :: alb(iimp1*jjp1) ! albedo
+      real,intent(out) :: ith(iimp1*jjp1) ! thermal inertia
+      real,intent(out) :: zmea(imdp1*jmdp1)
+      real,intent(out) :: zstd(imdp1*jmdp1)
+      real,intent(out) :: zsig(imdp1*jmdp1)
+      real,intent(out) :: zgam(imdp1*jmdp1)
+      real,intent(out) :: zthe(imdp1*jmdp1)
+      
+      REAL        zdata(imd*jmdp1)
+      REAL        zdataS(imdp1*jmdp1)
+      REAL        pfield(iimp1*jjp1)
+
+      INTEGER   ierr
+
+      INTEGER   unit,nvarid
+
+      INTEGER    i,j,k
+
+      INTEGER klatdat,ngridmixgdat
+      PARAMETER (klatdat=180,ngridmixgdat=360)
+
+c    on passe une grille en rlonu rlatv et im+1 jm a interp_horiz)
+
+      REAL longitude(imd),latitude(jmdp1) ! Pour lecture des donnees
+      REAL rlonud(imdp1),rlatvd(jmd)
+
+      CHARACTER*20 string
+      DIMENSION string(4)
+
+#include "fxyprim.h"
+
+      pi=2.*ASIN(1.)
+
+c=======================================================================
+c    rlonud, rlatvd
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c    Lecture NetCDF des donnees latitude et longitude
+c-----------------------------------------------------------------------
+      ierr = NF_OPEN (trim(datadir)//'/'//trim(adjustl(filename)),
+     &  NF_NOWRITE,unit)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(*,*)'Error : cannot open file '//trim(filename)
+        write(*,*)'(in phystd/datareadnc.F)'
+        write(*,*)'It should be in :',trim(datadir),'/'
+        write(*,*)'Check that your path to datagcm:',trim(datadir)
+        write(*,*)' is correct. You can change it in callphys.def with:'
+        write(*,*)' datadir = /absolute/path/to/datagcm'
+        write(*,*)'If necessary surface.nc (and other datafiles)'
+        write(*,*)' can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+        STOP
+      ENDIF
+
+c
+c Lecture des latitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (unit, "latitude", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(unit, nvarid, latitude)
+#else
+      ierr = NF_GET_VAR_REAL(unit, nvarid, latitude)
+#endif
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (unit, "longitude", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(unit, nvarid, longitude)
+#else
+      ierr = NF_GET_VAR_REAL(unit, nvarid, longitude)
+#endif
+
+c-----------------------------------------------------------------------
+c    Passage au format boites scalaires
+c-----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c       longitude(imd)        -->      rlonud(imdp1) 
+c-----------------------------------------------------------------------
+
+c Passage en coordonnees boites scalaires et en radian
+      do i=1,imd 
+          rlonud(i)=(longitude(i)+.5)*pi/180.
+      enddo
+
+c Repetition de la valeur im+1
+      rlonud(imdp1)=rlonud(1) + 2*pi
+
+c-----------------------------------------------------------------------
+c        latitude(jmdp1)         -->        rlonvd(jmd)
+c-----------------------------------------------------------------------
+
+c Passage en coordonnees boites scalaires et en radian
+      do j=1,jmd 
+          rlatvd(j)=(latitude(j)-.5)*pi/180.
+      enddo
+
+c=======================================================================
+c   lecture NetCDF de albedo, thermal, relief, zdtm (pour francois Lott)
+c=======================================================================
+
+      string(1) = 'albedo'
+      string(2) = 'thermal'
+      if (relief.ne.'pla') then
+        write(*,*) ' La topographie est celle de MOLA'
+        relief = 'MOL'
+          string(3) = 'z'//relief
+      else
+          string(3) = 'zMOL'  ! pour qu''il lise qqchose sur le fichier
+                            ! remise a 0 derriere
+      endif
+      string(4) = 'zMOL'    ! lecture pour calcul topog. sous-maille
+ 
+
+      DO k=1,4
+          write(*,*) 'string',k,string(k)
+          
+c-----------------------------------------------------------------------
+c    initialisation
+c-----------------------------------------------------------------------
+      call initial0(iimp1*jjp1,pfield)
+      call initial0(imd*jmdp1,zdata)
+      call initial0(imdp1*jmdp1,zdataS)
+
+c-----------------------------------------------------------------------
+c    Lecture NetCDF  
+c-----------------------------------------------------------------------
+
+      ierr = NF_INQ_VARID (unit, string(k), nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(unit, nvarid, zdata)
+#else
+      ierr = NF_GET_VAR_REAL(unit, nvarid, zdata)
+#endif
+
+c-----------------------------------------------------------------------
+c        Cas particulier "Francois Lott" ( k=4 ) (relief sous-maille)
+c-----------------------------------------------------------------------
+      if (k.eq.4) then
+
+          call multscal(imd*jmdp1,zdata,1000.,zdata)
+          call multscal(imd,longitude,pi/180.,longitude)
+          call multscal(jmdp1,latitude,pi/180.,latitude)
+
+          call grid_noro1(360, 180, longitude, latitude, zdata,
+     .         iim, jjp1, rlonv, rlatu, zmea,zstd,zsig,zgam,zthe)
+
+          !CALL dump2d(iip1,jjp1,zmea,'zmea')
+          !CALL dump2d(iip1,jjp1,zstd,'zstd')
+          !CALL dump2d(iip1,jjp1,zsig,'zsig')
+          !CALL dump2d(iip1,jjp1,zgam,'zgam')
+          !CALL dump2d(iip1,jjp1,zthe,'zthe')
+
+      endif
+
+c-----------------------------------------------------------------------
+c   Passage de zdata en grille (imdp1 jmdp1)
+c-----------------------------------------------------------------------
+      do j=1,jmdp1
+          do i=1,imd
+              zdataS(i+imdp1*(j-1)) = zdata(i+ngridmixgdat*(j-1))
+          enddo
+          zdataS(imdp1+imdp1*(j-1)) = zdata(1+ngridmixgdat*(j-1))
+      enddo
+
+c-----------------------------------------------------------------------
+c    Interpolation
+c-----------------------------------------------------------------------
+      call interp_horiz(zdataS,pfield,imd,jmd,
+     .    iim, jjm,1,rlonud,rlatvd,rlonu,rlatv) 
+
+c-----------------------------------------------------------------------
+c    Periodicite    
+c-----------------------------------------------------------------------
+
+      do j=1,jjp1
+         pfield(iimp1*j) =  pfield(1+iimp1*(j-1))
+      enddo 
+ 
+c-----------------------------------------------------------------------
+c    Sauvegarde des champs    
+c-----------------------------------------------------------------------
+
+      if (k.eq.1) then                    ! albedo
+         do i=1,iimp1*jjp1
+              alb(i) = pfield(i)
+          enddo
+      elseif (k.eq.2) then                ! thermal
+         do i=1,iimp1*jjp1
+              ith(i) = pfield(i)
+          enddo
+      elseif (k.eq.3) then                ! relief
+        if (relief.eq.'pla') then
+              call initial0(iimp1*jjp1,phisinit)
+        else
+             do i=1,iimp1*jjp1
+                  phisinit(i) = pfield(i)
+              enddo
+        endif
+      endif
+
+      ENDDO
+
+c-----------------------------------------------------------------------
+c    Traitement Phisinit
+c-----------------------------------------------------------------------
+
+      DO i=1,iimp1*jjp1
+            phisinit(i)=1000.*phisinit(i)
+      ENDDO
+      !CALL dump2d(iimp1,jjp1,phisinit,'Altitude en m')
+      CALL multscal(iimp1*jjp1,phisinit,g,phisinit)
+
+c-----------------------------------------------------------------------
+c    FIN
+c-----------------------------------------------------------------------
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/def_var.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/def_var.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/def_var.F90	(revision 222)
@@ -0,0 +1,64 @@
+subroutine def_var(nid,name,title,units,nbdim,dimids,nvarid,ierr)
+
+! This subroutine defines variable 'name' in a (pre-existing and opened)
+! NetCDF file (known from its NetCDF ID 'nid').
+! The number of dimensions 'nbdim' of the variable, as well as the IDs of
+! corresponding dimensions must be set (in array 'dimids').
+! Upon successfull definition of the variable, 'nvarid' contains the
+! NetCDF ID of the variable.
+! The variables' attributes 'title' (Note that 'long_name' would be more
+! appropriate) and 'units' are also set. 
+
+implicit none
+
+#include "netcdf.inc"
+
+integer,intent(in) :: nid ! NetCDF file ID
+character(len=*),intent(in) :: name ! the variable's name
+character(len=*),intent(in) :: title ! 'title' attribute of variable
+character(len=*),intent(in) :: units ! 'units' attribute of variable
+integer,intent(in) :: nbdim ! number of dimensions of the variable
+integer,dimension(nbdim),intent(in) :: dimids ! NetCDF IDs of the dimensions
+                                              ! the variable is defined along
+integer,intent(out) :: nvarid ! NetCDF ID of the variable
+integer,intent(out) :: ierr ! returned NetCDF staus code
+
+! 1. Switch to NetCDF define mode 
+ierr=NF_REDEF(nid)
+
+!print*,'in def_var.F90, dimids='
+!print*,dimids
+
+! 2. Define the variable
+#ifdef NC_DOUBLE
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_DOUBLE,nbdim,dimids,nvarid)
+#else
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_FLOAT,nbdim,dimids,nvarid)
+#endif
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var: Failed defining variable "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 3. Write attributes
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"title",&
+                     len_trim(adjustl(title)),adjustl(title))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var: Failed writing title attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"units",&
+                     len_trim(adjustl(units)),adjustl(units))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var: Failed writing units attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 4. Switch out of NetCDF define mode
+ierr = NF_ENDDEF(nid)
+
+end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dimphy.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dimphy.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dimphy.F90	(revision 222)
@@ -0,0 +1,32 @@
+MODULE dimphy
+  
+  INTEGER,SAVE :: klon   ! number of atmospheric columns (for this OpenMP subgrid)
+  INTEGER,SAVE :: klev   ! number of atmospheric layers
+  INTEGER,SAVE :: klevp1 ! number of atmospheric layers+1
+  INTEGER,SAVE :: klevm1 ! number of atmospheric layers-1
+!  INTEGER,SAVE :: kflev
+
+!$OMP THREADPRIVATE(klon)
+
+CONTAINS
+  
+  SUBROUTINE Init_dimphy(klon0,klev0)
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    
+    klon=klon0
+    
+!$OMP MASTER 
+    klev=klev0
+    klevp1=klev+1
+    klevm1=klev-1
+!    kflev=klev
+!$OMP END MASTER    
+!$OMP BARRIER
+    
+  END SUBROUTINE Init_dimphy
+
+  
+END MODULE dimphy
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dimphys.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dimphys.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dimphys.h	(revision 222)
@@ -0,0 +1,14 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimphys.h'
+
+! ngridmx : number of horizontal grid points
+! note: the -1/jjm term will be 0; unless jj=1
+      integer, parameter :: ngridmx = (2+(jjm-1)*iim - 1/jjm)   
+! nlayermx : number of atmospheric layers
+      integer, parameter :: nlayermx = llm 
+! nsoilmx : number of subterranean layers ! nsoilmx is now in comsoil_h
+      !integer, parameter :: nsoilmx = 4 ! for a test 
+      !integer, parameter :: nsoilmx = 18 ! for z1=0.0002 m, depth = 18 m => mars case 
+      !integer, parameter :: nsoilmx = 13 ! for z1=0.03 m, depth = 104.8 m => earth case
+!-----------------------------------------------------------------------
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dsolver.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dsolver.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dsolver.F	(revision 222)
@@ -0,0 +1,102 @@
+      SUBROUTINE DSOLVER(NL,GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4,BTOP,
+     *                   BSURF,RSF,XK1,XK2)
+
+C  GCM2.0  Feb 2003
+C
+C DOUBLE PRECISION VERSION OF SOLVER
+
+      PARAMETER (NMAX=201)
+      IMPLICIT REAL*8  (A-H,O-Z)
+      DIMENSION GAMA(NL),CP(NL),CM(NL),CPM1(NL),CMM1(NL),XK1(NL),
+     *          XK2(NL),E1(NL),E2(NL),E3(NL),E4(NL)
+      DIMENSION AF(NMAX),BF(NMAX),CF(NMAX),DF(NMAX),XK(NMAX)
+C*********************************************************
+C* THIS SUBROUTINE SOLVES FOR THE COEFFICIENTS OF THE    *
+C* TWO STREAM SOLUTION FOR GENERAL BOUNDARY CONDITIONS   *
+C* NO ASSUMPTION OF THE DEPENDENCE ON OPTICAL DEPTH OF   *
+C* C-PLUS OR C-MINUS HAS BEEN MADE.                      *
+C* NL     = NUMBER OF LAYERS IN THE MODEL                *
+C* CP     = C-PLUS EVALUATED AT TAO=0 (TOP)              *
+C* CM     = C-MINUS EVALUATED AT TAO=0 (TOP)             *
+C* CPM1   = C-PLUS  EVALUATED AT TAOSTAR (BOTTOM)        *
+C* CMM1   = C-MINUS EVALUATED AT TAOSTAR (BOTTOM)        *
+C* EP     = EXP(LAMDA*DTAU)                              *
+C* EM     = 1/EP                                         *
+C* E1     = EP + GAMA *EM                                *
+C* E2     = EP - GAMA *EM                                *
+C* E3     = GAMA*EP + EM                                 *
+C* E4     = GAMA*EP - EM                                 *
+C* BTOP   = THE DIFFUSE RADIATION INTO THE MODEL AT TOP  *
+C* BSURF  = THE DIFFUSE RADIATION INTO THE MODEL AT      *
+C*          THE BOTTOM: INCLUDES EMMISION AND REFLECTION *
+C*          OF THE UNATTENUATED PORTION OF THE DIRECT    *
+C*          BEAM. BSTAR+RSF*FO*EXP(-TAOSTAR/U0)          *
+C* RSF    = REFLECTIVITY OF THE SURFACE                  *
+C* XK1    = COEFFICIENT OF THE POSITIVE EXP TERM         *
+C* XK2    = COEFFICIENT OF THE NEGATIVE EXP TERM         *
+C*********************************************************
+
+C======================================================================C
+
+      L=2*NL
+ 
+C     ************MIXED COEFFICENTS**********
+C     THIS VERSION AVOIDS SINGULARITIES ASSOC.
+C     WITH W0=0 BY SOLVING FOR XK1+XK2, AND XK1-XK2.
+
+      AF(1) = 0.0
+      BF(1) = GAMA(1)+1.
+      CF(1) = GAMA(1)-1.
+      DF(1) = BTOP-CMM1(1)
+      N     = 0
+      LM2   = L-2
+
+C     EVEN TERMS
+ 
+      DO I=2,LM2,2
+        N     = N+1
+        AF(I) = (E1(N)+E3(N))*(GAMA(N+1)-1.)       
+        BF(I) = (E2(N)+E4(N))*(GAMA(N+1)-1.)
+        CF(I) = 2.0*(1.-GAMA(N+1)**2)
+        DF(I) = (GAMA(N+1)-1.) * (CPM1(N+1) - CP(N)) +
+     *            (1.-GAMA(N+1))* (CM(N)-CMM1(N+1))
+      END DO
+ 
+      N   = 0
+      LM1 = L-1
+      DO I=3,LM1,2
+        N     = N+1
+        AF(I) = 2.0*(1.-GAMA(N)**2)
+        BF(I) = (E1(N)-E3(N))*(1.+GAMA(N+1))
+        CF(I) = (E1(N)+E3(N))*(GAMA(N+1)-1.)
+        DF(I) = E3(N)*(CPM1(N+1) - CP(N)) + E1(N)*(CM(N) - CMM1(N+1))
+      END DO
+ 
+      AF(L) = E1(NL)-RSF*E3(NL)
+      BF(L) = E2(NL)-RSF*E4(NL)
+      CF(L) = 0.0
+      DF(L) = BSURF-CP(NL)+RSF*CM(NL)
+ 
+      CALL DTRIDGL(L,AF,BF,CF,DF,XK)
+ 
+C     ***UNMIX THE COEFFICIENTS****
+
+      DO 28 N=1,NL
+        XK1(N) = XK(2*N-1)+XK(2*N)
+        XK2(N) = XK(2*N-1)-XK(2*N)
+
+C       NOW TEST TO SEE IF XK2 IS REALLY ZERO TO THE LIMIT OF THE
+C       MACHINE ACCURACY  = 1 .E -30
+C       XK2 IS THE COEFFICEINT OF THE GROWING EXPONENTIAL AND MUST
+C       BE TREATED CAREFULLY
+
+        IF(XK2(N) .EQ. 0.0) GO TO 28
+c        IF (ABS (XK2(N)/XK(2*N-1)) .LT. 1.E-30) XK2(N)=0.0
+
+        IF (ABS (XK2(N)/(XK(2*N-1)+1.e-20)) .LT. 1.E-30) XK2(N)=0.0   ! For debug only (with -Ktrap=fp option)
+
+
+   28 CONTINUE
+ 
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dtridgl.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dtridgl.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/dtridgl.F	(revision 222)
@@ -0,0 +1,36 @@
+      SUBROUTINE DTRIDGL(L,AF,BF,CF,DF,XK)
+
+C  GCM2.0  Feb 2003
+
+C     DOUBLE PRECISION VERSION OF TRIDGL
+
+      PARAMETER (NMAX=201)
+      IMPLICIT REAL*8  (A-H,O-Z)
+      DIMENSION AF(L),BF(L),CF(L),DF(L),XK(L)
+      DIMENSION AS(NMAX),DS(NMAX)
+
+C*    THIS SUBROUTINE SOLVES A SYSTEM OF TRIDIAGIONAL MATRIX
+C*    EQUATIONS. THE FORM OF THE EQUATIONS ARE:
+C*    A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = D(I)
+C*    WHERE I=1,L  LESS THAN 103.
+C* ..............REVIEWED -CP........
+
+C======================================================================C
+
+      AS(L) = AF(L)/BF(L)
+      DS(L) = DF(L)/BF(L)
+
+      DO I=2,L
+        X         = 1./(BF(L+1-I) - CF(L+1-I)*AS(L+2-I))
+        AS(L+1-I) = AF(L+1-I)*X
+        DS(L+1-I) = (DF(L+1-I)-CF(L+1-I)*DS(L+2-I))*X
+      END DO
+ 
+      XK(1)=DS(1)
+      DO I=2,L
+        XKB   = XK(I-1)
+        XK(I) = DS(I)-AS(I)*XKB
+      END DO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/evap.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/evap.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/evap.F	(revision 222)
@@ -0,0 +1,80 @@
+      subroutine evap(ngrid,nq,dtime,pt, pq, pdq, pdt,  
+     $     dqevap,dtevap, qevap, tevap) 
+        
+      use watercommon_h 
+      USE tracer_h
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Evaporation of all water in the atmopshere.
+!     
+!     Authors
+!     -------
+!     Adapted from the LMDTERRE code by B. Charnay (2010)
+!     Original author Z. X. Li (1993)
+!     
+!==================================================================
+
+      INTEGER ngrid,nq
+
+! Arguments:
+      REAL pt(ngrid,nlayermx) 
+      REAL pq(ngrid,nlayermx,nq) 
+      REAL pdt(ngrid,nlayermx) 
+      REAL pdq(ngrid,nlayermx,nq) 
+      REAL dqevap(ngrid,nlayermx)
+      REAL dtevap(ngrid,nlayermx)
+      REAL qevap(ngrid,nlayermx,nq)
+      REAL dtime
+ 
+! Local:
+      REAL tevap(ngrid,nlayermx) 
+      REAL zlvdcp
+      REAL zlsdcp
+      REAL zdelta
+      INTEGER l,ig
+
+!
+! Re-evaporer l'eau liquide nuageuse
+!
+
+      DO l=1,nlayermx
+        DO ig=1,ngrid
+         qevap(ig,l,igcm_h2o_vap)=pq(ig,l,igcm_h2o_vap)	
+     s          	          +pdq(ig,l,igcm_h2o_vap)*dtime
+         qevap(ig,l,igcm_h2o_ice)=pq(ig,l,igcm_h2o_ice)	
+     s                            +pdq(ig,l,igcm_h2o_ice)*dtime
+         tevap(ig,l)=pt(ig,l)+pdt(ig,l)*dtime
+	ENDDO
+      ENDDO
+
+      DO l = 1, nlayermx  
+      	DO ig = 1, ngrid
+         zlvdcp=RLVTT/RCPD!/(1.0+RVTMP2*qevap(ig,l,igcm_h2o_vap))
+         zlsdcp=RLSTT/RCPD!/(1.0+RVTMP2*qevap(ig,l,igcm_h2o_vap))
+         ! ignoring qevap term creates huge difference when qevap large!!!
+
+         zdelta = MAX(0.,SIGN(1.,T_h2O_ice_liq-tevap(ig,l))) ! what is this?
+                                                  ! for division between water / liquid
+	 dqevap(ig,l) = MAX(0.0,qevap(ig,l,igcm_h2o_ice))/dtime
+         dtevap(ig,l) = - dqevap(ig,l)*RLVTT/RCPD ! exactly as in largescale.F
+!         dtevap(ig,l) = - dqevap(ig,l)	
+!     s                       * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         qevap(ig,l,igcm_h2o_vap) = qevap(ig,l,igcm_h2o_vap)	
+     s     	                    +dqevap(ig,l)*dtime
+	 qevap(ig,l,igcm_h2o_ice) = 0.0
+         tevap(ig,l) = tevap(ig,l)+dtevap(ig,l)*dtime
+
+      	ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/forceWCfn.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/forceWCfn.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/forceWCfn.F	(revision 222)
@@ -0,0 +1,50 @@
+      subroutine forceWCfn(ngrid,nq,pplev,pt,dq,dqs)
+
+      USE tracer_h
+
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Force tracer conservation in a column for a given pair of 
+!     delta q, delta q_s
+!
+!     Authors
+!     ------- 
+!     R. Wordsworth
+!     
+!==================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+
+      INTEGER ngrid,nq
+
+      real masse, Wtot, Wdiff
+
+      real pplev(ngrid,nlayermx+1)
+      real pt(ngrid)
+
+      real dqs(ngrid,nq) 
+      real dq(ngrid,nlayermx,nq)
+
+      integer iq, ig, ilay
+
+      do iq=1,nq 
+        do ig=1,ngrid
+           Wtot = 0.0
+           do ilay=1,nlayermx
+              masse = (pplev(ig,ilay) - pplev(ig,ilay+1))/g
+              Wtot  = Wtot + masse*dq(ig,ilay,iq)
+           enddo
+           Wdiff = Wtot + dqs(ig,iq)
+         
+           dqs(ig,iq) = dqs(ig,iq) - Wdiff
+        enddo
+      enddo
+
+      end 
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gases_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gases_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gases_h.F90	(revision 222)
@@ -0,0 +1,34 @@
+      module gases_h
+
+      implicit none
+
+!======================================================================C
+!
+!     gases_h    
+!
+!     A F90-allocatable version for gases.h -- AS 12/2011
+!
+!======================================================================C
+
+      ! Set and allocated in su_gases.F90
+      integer :: ngasmx
+      integer :: vgas
+      character*20,allocatable,DIMENSION(:) :: gnom ! name of the gas
+      real,allocatable,DIMENSION(:) :: gfrac
+
+      ! in analogy with tracer.h ...
+      integer :: igas_H2
+      integer :: igas_He
+      integer :: igas_H2O
+      integer :: igas_CO2
+      integer :: igas_CO
+      integer :: igas_N2
+      integer :: igas_O2
+      integer :: igas_SO2
+      integer :: igas_H2S
+      integer :: igas_CH4
+      integer :: igas_NH3
+      integer :: igas_C2H2
+      integer :: igas_C2H6
+
+      end module gases_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gfluxi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gfluxi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gfluxi.F	(revision 222)
@@ -0,0 +1,226 @@
+      SUBROUTINE GFLUXI(NLL,TLEV,NW,DW,DTAU,TAUCUM,W0,COSBAR,UBARI,
+     *                  RSF,BTOP,BSURF,FTOPUP,FMIDP,FMIDM)
+
+C  THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITIONS
+C  FOR THE INFRARED FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT
+C  THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS
+C  MEASURED FROM THE TOP OF EACH LAYER.  THE TOP OF EACH LAYER HAS  
+C  OPTICAL DEPTH ZERO.  IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N
+C  HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES
+C  FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES.
+C THE TRI-DIAGONAL MATRIX SOLVER IS DSOLVER AND IS DOUBLE PRECISION SO MANY 
+C VARIABLES ARE PASSED AS SINGLE THEN BECOME DOUBLE IN DSOLVER
+C
+C NLL            = NUMBER OF LEVELS (NLAYERS + 1) MUST BE LESS THAT NL (101)
+C TLEV(L_LEVELS) = ARRAY OF TEMPERATURES AT GCM LEVELS
+C WAVEN          = WAVELENGTH FOR THE COMPUTATION
+C DW             = WAVENUMBER INTERVAL
+C DTAU(NLAYER)   = ARRAY OPTICAL DEPTH OF THE LAYERS
+C W0(NLEVEL)     = SINGLE SCATTERING ALBEDO
+C COSBAR(NLEVEL) = ASYMMETRY FACTORS, 0=ISOTROPIC
+C UBARI          = AVERAGE ANGLE, MUST BE EQUAL TO 0.5 IN IR
+C RSF            = SURFACE REFLECTANCE
+C BTOP           = UPPER BOUNDARY CONDITION ON IR INTENSITY (NOT FLUX)
+C BSURF          = SURFACE EMISSION = (1-RSFI)*PLANCK, INTENSITY (NOT FLUX)
+C FP(NLEVEL)     = UPWARD FLUX AT LEVELS
+C FM(NLEVEL)     = DOWNWARD FLUX AT LEVELS
+C FMIDP(NLAYER)  = UPWARD FLUX AT LAYER MIDPOINTS
+C FMIDM(NLAYER)  = DOWNWARD FLUX AT LAYER MIDPOINTS
+C
+C----------------------------------------------------------------------C
+
+      use radinc_h
+      use radcommon_h, only: planckir
+
+      implicit none
+
+#include "comcstfi.h"
+
+      INTEGER NLP
+      PARAMETER (NLP=101) ! MUST BE LARGER THAN NLEVEL 
+
+      INTEGER NLL, NLAYER, L, NW, NT, NT2
+      REAL*8  TERM, CPMID, CMMID
+      REAL*8  PLANCK
+      REAL*8  EM,EP
+      REAL*8  COSBAR(L_NLAYRAD), W0(L_NLAYRAD), DTAU(L_NLAYRAD)
+      REAL*8  TAUCUM(L_LEVELS), DTAUK
+      REAL*8  TLEV(L_LEVELS)
+      REAL*8  WAVEN, DW, UBARI, RSF
+      REAL*8  BTOP, BSURF, FMIDP(L_NLAYRAD), FMIDM(L_NLAYRAD)
+      REAL*8  B0(NLP),B1(NLP),ALPHA(NLP),LAMDA(NLP),XK1(NLP),XK2(NLP)
+      REAL*8  GAMA(NLP),CP(NLP),CM(NLP),CPM1(NLP),CMM1(NLP),E1(NLP)
+      REAL*8  E2(NLP),E3(NLP),E4(NLP)
+
+      REAL*8  FTOPUP, FLUXUP, FLUXDN
+
+      real*8 :: TAUMAX = L_TAUMAX 
+
+C======================================================================C
+ 
+C     WE GO WITH THE HEMISPHERIC CONSTANT APPROACH IN THE INFRARED
+ 
+
+      IF (NLL .GT. NLP) STOP 'PARAMETER NL TOO SMALL IN GFLUXI'
+
+      NLAYER = L_NLAYRAD
+
+      DO L=1,L_NLAYRAD-1
+
+!----------------------------------------------------
+! There is a problem when W0 = 1
+!         open(888,file='W0')
+!           if ((W0(L).eq.0.).or.(W0(L).eq.1.)) then
+!             write(888,*) W0(L), L, 'gfluxi'
+!           endif
+! Prevent this with an if statement:
+        if (W0(L).eq.1.D0) then
+           W0(L) = 0.99999D0
+        endif
+!----------------------------------------------------
+
+        ALPHA(L) = SQRT( (1.0D0-W0(L))/(1.0D0-W0(L)*COSBAR(L)) )
+        LAMDA(L) = ALPHA(L)*(1.0D0-W0(L)*COSBAR(L))/UBARI
+
+        NT    = int(TLEV(2*L)*NTfac)   - NTstar+1
+        NT2   = int(TLEV(2*L+2)*NTfac) - NTstar+1
+
+        B1(L) = (PLANCKIR(NW,NT2)-PLANCKIR(NW,NT))/DTAU(L)
+        B0(L) = PLANCKIR(NW,NT)
+      END DO
+
+C     Take care of special lower layer
+
+      L        = L_NLAYRAD
+
+      if (W0(L).eq.1.) then
+          W0(L) = 0.99999D0
+      end if
+
+      ALPHA(L) = SQRT( (1.0D0-W0(L))/(1.0D0-W0(L)*COSBAR(L)) )
+      LAMDA(L) = ALPHA(L)*(1.0D0-W0(L)*COSBAR(L))/UBARI
+
+      ! Tsurf is used for 1st layer source function
+      ! -- same results for most thin atmospheres
+      ! -- and stabilizes integrations
+      NT    = int(TLEV(2*L+1)*NTfac) - NTstar+1
+      !! For deep, opaque, thick first layers (e.g. Saturn)
+      !! what is below works much better, not unstable, ...
+      !! ... and actually fully accurate because 1st layer temp (JL) 
+      !NT    = int(TLEV(2*L)*NTfac) - NTstar+1
+      !! (or this one yields same results
+      !NT    = int( (TLEV(2*L)+TLEV(2*L+1))*0.5*NTfac ) - NTstar+1
+
+      NT2   = int(TLEV(2*L)*NTfac)   - NTstar+1
+      B1(L) = (PLANCKIR(NW,NT)-PLANCKIR(NW,NT2))/DTAU(L)
+      B0(L) = PLANCKIR(NW,NT2)
+
+      DO L=1,L_NLAYRAD
+        GAMA(L) = (1.0D0-ALPHA(L))/(1.0D0+ALPHA(L))
+        TERM    = UBARI/(1.0D0-W0(L)*COSBAR(L))
+
+C       CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE
+C       BOTTOM OF THE LAYER.  THAT IS AT DTAU OPTICAL DEPTH
+
+        CP(L) = B0(L)+B1(L)*DTAU(L) +B1(L)*TERM
+        CM(L) = B0(L)+B1(L)*DTAU(L) -B1(L)*TERM
+
+C       CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED
+C       AT THE TOP OF THE LAYER, THAT IS ZERO OPTICAL DEPTH
+
+        CPM1(L) = B0(L)+B1(L)*TERM
+        CMM1(L) = B0(L)-B1(L)*TERM
+      END DO
+ 
+C     NOW CALCULATE THE EXPONENTIAL TERMS NEEDED
+C     FOR THE TRIDIAGONAL ROTATED LAYERED METHOD
+C     WARNING IF DTAU(J) IS GREATER THAN ABOUT 35 (VAX)
+C     WE CLIP IT TO AVOID OVERFLOW.
+
+      DO L=1,L_NLAYRAD
+
+C       CLIP THE EXPONENTIAL HERE.
+
+        EP    = EXP( MIN((LAMDA(L)*DTAU(L)),TAUMAX))
+        EM    = 1.0D0/EP
+        E1(L) = EP+GAMA(L)*EM
+        E2(L) = EP-GAMA(L)*EM
+        E3(L) = GAMA(L)*EP+EM
+        E4(L) = GAMA(L)*EP-EM
+      END DO
+ 
+c     B81=BTOP  ! RENAME BEFORE CALLING DSOLVER - used to be to set
+c     B82=BSURF ! them to real*8 - but now everything is real*8
+c     R81=RSF   ! so this may not be necessary
+
+C     Double precision tridiagonal solver
+
+      CALL DSOLVER(NLAYER,GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4,BTOP,
+     *             BSURF,RSF,XK1,XK2)
+ 
+
+C     NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS.
+ 
+      DO L=1,L_NLAYRAD-1
+        DTAUK = TAUCUM(2*L+1)-TAUCUM(2*L)
+        EP    = EXP(MIN(LAMDA(L)*DTAUK,TAUMAX)) ! CLIPPED EXPONENTIAL 
+        EM    = 1.0D0/EP
+        TERM  = UBARI/(1.D0-W0(L)*COSBAR(L))
+
+C       CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE
+C       BOTTOM OF THE LAYER.  THAT IS AT DTAU  OPTICAL DEPTH
+
+        CPMID    = B0(L)+B1(L)*DTAUK +B1(L)*TERM
+        CMMID    = B0(L)+B1(L)*DTAUK -B1(L)*TERM
+        FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID
+        FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID
+
+C       FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT
+
+        FMIDP(L) = FMIDP(L)*PI
+        FMIDM(L) = FMIDM(L)*PI
+      END DO
+ 
+C     And now, for the special bottom layer
+
+      L    = L_NLAYRAD
+
+      EP   = EXP(MIN((LAMDA(L)*DTAU(L)),TAUMAX)) ! CLIPPED EXPONENTIAL 
+      EM   = 1.0D0/EP
+      TERM = UBARI/(1.D0-W0(L)*COSBAR(L))
+
+C     CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE
+C     BOTTOM OF THE LAYER.  THAT IS AT DTAU  OPTICAL DEPTH
+
+      CPMID    = B0(L)+B1(L)*DTAU(L) +B1(L)*TERM
+      CMMID    = B0(L)+B1(L)*DTAU(L) -B1(L)*TERM
+      FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID
+      FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID
+ 
+C     FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT
+
+      FMIDP(L) = FMIDP(L)*PI
+      FMIDM(L) = FMIDM(L)*PI
+
+C     FLUX AT THE PTOP LEVEL
+
+      EP   = 1.0D0
+      EM   = 1.0D0
+      TERM = UBARI/(1.0D0-W0(1)*COSBAR(1))
+
+C     CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE
+C     BOTTOM OF THE LAYER.  THAT IS AT DTAU  OPTICAL DEPTH
+
+      CPMID  = B0(1)+B1(1)*TERM
+      CMMID  = B0(1)-B1(1)*TERM
+
+      FLUXUP = XK1(1)*EP + GAMA(1)*XK2(1)*EM + CPMID
+      FLUXDN = XK1(1)*EP*GAMA(1) + XK2(1)*EM + CMMID
+ 
+C     FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT
+
+      FTOPUP = (FLUXUP-FLUXDN)*PI
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gfluxv.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gfluxv.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gfluxv.F	(revision 222)
@@ -0,0 +1,319 @@
+      SUBROUTINE GFLUXV(DTDEL,TDEL,TAUCUMIN,WDEL,CDEL,UBAR0,F0PI,RSF,
+     *                  BTOP,BSURF,FMIDP,FMIDM,DIFFV,FLUXUP,FLUXDN)
+
+
+C  THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITIONS
+C  FOR THE VISIBLE  FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT
+C  THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS
+C  MEASURED FROM THE TOP OF EACH LAYER.  (DTAU) TOP OF EACH LAYER HAS  
+C  OPTICAL DEPTH TAU(N).IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N
+C  HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES
+C  FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES.
+C THIS SUBROUTINE DIFFERS FROM ITS IR COUNTERPART IN THAT HERE WE SOLVE FOR 
+C THE FLUXES DIRECTLY USING THE GENERALIZED NOTATION OF MEADOR AND WEAVOR
+C J.A.S., 37, 630-642, 1980.
+C THE TRI-DIAGONAL MATRIX SOLVER IS DSOLVER AND IS DOUBLE PRECISION SO MANY 
+C VARIABLES ARE PASSED AS SINGLE THEN BECOME DOUBLE IN DSOLVER
+C
+C NLL           = NUMBER OF LEVELS (NAYER + 1) THAT WILL BE SOLVED
+C NAYER         = NUMBER OF LAYERS (NOTE DIFFERENT SPELLING HERE)
+C WAVEN         = WAVELENGTH FOR THE COMPUTATION
+C DTDEL(NLAYER) = ARRAY OPTICAL DEPTH OF THE LAYERS
+C TDEL(NLL)     = ARRAY COLUMN OPTICAL DEPTH AT THE LEVELS
+C WDEL(NLEVEL)  = SINGLE SCATTERING ALBEDO
+C CDEL(NLL)     = ASYMMETRY FACTORS, 0=ISOTROPIC
+C UBARV         = AVERAGE ANGLE, 
+C UBAR0         = SOLAR ZENITH ANGLE
+C F0PI          = INCIDENT SOLAR DIRECT BEAM FLUX
+C RSF           = SURFACE REFLECTANCE
+C BTOP          = UPPER BOUNDARY CONDITION ON DIFFUSE FLUX
+C BSURF         = REFLECTED DIRECT BEAM = (1-RSFI)*F0PI*EDP-TAU/U
+C FP(NLEVEL)    = UPWARD FLUX AT LEVELS
+C FM(NLEVEL)    = DOWNWARD FLUX AT LEVELS
+C FMIDP(NLAYER) = UPWARD FLUX AT LAYER MIDPOINTS
+C FMIDM(NLAYER) = DOWNWARD FLUX AT LAYER MIDPOINTS
+C added Dec 2002
+C DIFFV         = downward diffuse solar flux at the surface
+C 
+!======================================================================!
+
+      use radinc_h
+
+      implicit none
+
+      INTEGER NLP
+      PARAMETER (NLP=101) ! MUST BE LARGER THAN NLEVEL
+
+      REAL*8 EM, EP
+      REAL*8 W0(L_NLAYRAD), COSBAR(L_NLAYRAD), DTAU(L_NLAYRAD)
+      REAL*8 TAU(L_NLEVRAD), WDEL(L_NLAYRAD), CDEL(L_NLAYRAD)
+      REAL*8 DTDEL(L_NLAYRAD), TDEL(L_NLEVRAD)
+      REAL*8 FMIDP(L_NLAYRAD), FMIDM(L_NLAYRAD)
+      REAL*8 LAMDA(NLP), ALPHA(NLP), XK1(NLP), XK2(NLP)
+      REAL*8 G1(NLP), G2(NLP), G3(NLP), GAMA(NLP), CP(NLP), CM(NLP)
+      REAL*8 CPM1(NLP)
+      REAL*8 CMM1(NLP), E1(NLP), E2(NLP), E3(NLP), E4(NLP), EXPTRM(NLP)
+      REAL*8 FLUXUP, FLUXDN
+      REAL*8 FACTOR, TAUCUMIN(L_LEVELS), TAUCUM(L_LEVELS)
+
+      integer NAYER, L, K
+      real*8  ubar0, f0pi, rsf, btop, bsurf, g4, denom, am, ap
+      real*8  taumax, taumid, cpmid, cmmid
+      real*8  diffv
+
+C======================================================================C
+
+
+
+
+      NAYER  = L_NLAYRAD
+      TAUMAX = L_TAUMAX    !Default is 35.0
+      
+!  Delta-Eddington Scaling
+
+
+      FACTOR    = 1.0D0 - WDEL(1)*CDEL(1)**2
+
+      TAU(1)    = TDEL(1)*FACTOR
+      TAUCUM(1) = 0.0D0
+      TAUCUM(2) = TAUCUMIN(2)*FACTOR
+      TAUCUM(3) = TAUCUM(2) +(TAUCUMIN(3)-TAUCUMIN(2))*FACTOR
+
+
+      DO L=1,L_NLAYRAD-1
+        FACTOR      = 1.0D0 - WDEL(L)*CDEL(L)**2
+        W0(L)       = WDEL(L)*(1.0D0-CDEL(L)**2)/FACTOR
+        COSBAR(L)   = CDEL(L)/(1.0D0+CDEL(L))
+
+        DTAU(L)     = DTDEL(L)*FACTOR
+        TAU(L+1)    = TAU(L)+DTAU(L)
+        K           = 2*(L+1)
+        TAUCUM(K)   = TAU(L+1)
+        TAUCUM(K+1) = TAUCUM(K) + (TAUCUMIN(K+1)-TAUCUMIN(K))*FACTOR
+      END DO
+
+!  Bottom layer
+
+      L             = L_NLAYRAD
+      FACTOR        = 1.0D0 - WDEL(L)*CDEL(L)**2
+      W0(L)         = WDEL(L)*(1.0D0-CDEL(L)**2)/FACTOR
+      COSBAR(L)     = CDEL(L)/(1.0D0+CDEL(L))
+      DTAU(L)       = DTDEL(L)*FACTOR
+      TAU(L+1)      = TAU(L)+DTAU(L)
+      TAUCUM(2*L+1) = TAU(L+1)
+
+      BSURF = RSF*UBAR0*F0PI*EXP(-MIN(TAU(L+1),TAUMAX)/UBAR0)
+      ! new definition of BSURF
+      ! the old one was false because it used tau, not tau'
+      ! tau' includes the contribution to the downward flux
+      ! of the radiation scattered in the forward direction
+
+C     WE GO WITH THE QUADRATURE APPROACH HERE.  THE "SQRT(3)" factors
+C     ARE THE UBARV TERM.
+
+      DO L=1,L_NLAYRAD
+
+        ALPHA(L)=SQRT( (1.0-W0(L))/(1.0-W0(L)*COSBAR(L) ) )
+
+C       SET OF CONSTANTS DETERMINED BY DOM 
+
+!     Quadrature method
+        G1(L)    = (SQRT(3.0)*0.5)*(2.0- W0(L)*(1.0+COSBAR(L)))
+        G2(L)    = (SQRT(3.0)*W0(L)*0.5)*(1.0-COSBAR(L))
+        G3(L)    = 0.5*(1.0-SQRT(3.0)*COSBAR(L)*UBAR0)
+
+!     ----- some other methods... (RDW) ------
+
+!     Eddington method
+!        G1(L)    =  0.25*(7.0 - W0(L)*(4.0 - 3.0*COSBAR(L)))
+!        G2(L)    = -0.25*(1.0 - W0(L)*(4.0 - 3.0*COSBAR(L)))
+!        G3(L)    =  0.25*(2.0 - 3.0*COSBAR(L)*UBAR0)
+
+!     delta-Eddington method
+!        G1(L)    =  (7.0 - 3.0*g^2 - W0(L)*(4.0 + 3.0*g) + W0(L)*g^2*(4*beta0 + 3*g)) / &
+!                             (4* (1 - g^2*()   ))  0.25*(7.0 - W0(L)*(4.0 - 3.0*COSBAR(L)))
+
+!     Hybrid modified Eddington-delta function method
+
+!     ----------------------------------------
+
+c     So they use Quadrature
+c     but the scaling is Eddington?
+
+        LAMDA(L) = SQRT(G1(L)**2 - G2(L)**2)
+        GAMA(L)  = (G1(L)-LAMDA(L))/G2(L)
+      END DO
+
+
+      DO L=1,L_NLAYRAD
+        G4    = 1.0-G3(L)
+        DENOM = LAMDA(L)**2 - 1./UBAR0**2
+ 
+C       THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0
+C       THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN 
+C       THE SCATTERING GOES TO ZERO
+C       PREVENT THIS WITH AN IF STATEMENT
+
+        IF ( DENOM .EQ. 0.) THEN
+          DENOM=1.E-10
+        END IF
+
+
+        AM = F0PI*W0(L)*(G4   *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM
+        AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4    )/DENOM
+
+C       CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED
+C       AT THE TOP OF THE LAYER, THAT IS LOWER   OPTICAL DEPTH TAU(L)
+ 
+        CPM1(L) = AP*EXP(-TAU(L)/UBAR0)
+        CMM1(L) = AM*EXP(-TAU(L)/UBAR0)
+
+C       CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE
+C       BOTTOM OF THE LAYER.  THAT IS AT HIGHER OPTICAL DEPTH TAU(L+1)
+
+        CP(L) = AP*EXP(-TAU(L+1)/UBAR0)
+        CM(L) = AM*EXP(-TAU(L+1)/UBAR0)
+
+      END DO
+
+
+ 
+C     NOW CALCULATE THE EXPONENTIAL TERMS NEEDED
+C     FOR THE TRIDIAGONAL ROTATED LAYERED METHOD
+
+      DO L=1,L_NLAYRAD
+        EXPTRM(L) = MIN(TAUMAX,LAMDA(L)*DTAU(L))  ! CLIPPED EXPONENTIAL
+        EP = EXP(EXPTRM(L))
+
+        EM        = 1.0/EP
+        E1(L)     = EP+GAMA(L)*EM
+        E2(L)     = EP-GAMA(L)*EM
+        E3(L)     = GAMA(L)*EP+EM
+        E4(L)     = GAMA(L)*EP-EM
+      END DO
+
+      CALL DSOLVER(NAYER,GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4,BTOP,
+     *             BSURF,RSF,XK1,XK2)
+
+C     NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS.
+ 
+      DO L=1,L_NLAYRAD-1
+        EXPTRM(L) = MIN(TAUMAX,LAMDA(L)*(TAUCUM(2*L+1)-TAUCUM(2*L)))
+ 
+        EP = EXP(EXPTRM(L))
+
+        EM    = 1.0/EP
+        G4    = 1.0-G3(L)
+        DENOM = LAMDA(L)**2 - 1./UBAR0**2
+
+C       THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0
+C       THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN 
+C       THE SCATTERING GOES TO ZERO
+C       PREVENT THIS WITH A IF STATEMENT
+
+
+        IF ( DENOM .EQ. 0.) THEN
+          DENOM=1.E-10
+        END IF
+
+        AM = F0PI*W0(L)*(G4   *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM
+        AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4    )/DENOM
+
+C       CPMID AND CMMID  ARE THE CPLUS AND CMINUS TERMS EVALUATED
+C       AT THE MIDDLE OF THE LAYER.
+
+        TAUMID   = TAUCUM(2*L+1)
+
+        CPMID = AP*EXP(-TAUMID/UBAR0)
+        CMMID = AM*EXP(-TAUMID/UBAR0)
+
+        FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID
+        FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID
+ 
+C       ADD THE DIRECT FLUX TO THE DOWNWELLING TERM
+
+        FMIDM(L)= FMIDM(L)+UBAR0*F0PI*EXP(-MIN(TAUMID,TAUMAX)/UBAR0)
+   
+      END DO
+ 
+C     FLUX AT THE Ptop layer
+
+      EP    = 1.0
+      EM    = 1.0
+      G4    = 1.0-G3(1)
+      DENOM = LAMDA(1)**2 - 1./UBAR0**2
+
+C     THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0
+C     THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN 
+C     THE SCATTERING GOES TO ZERO
+C     PREVENT THIS WITH A IF STATEMENT
+
+      IF ( DENOM .EQ. 0.) THEN
+        DENOM=1.E-10
+      END IF
+
+      AM = F0PI*W0(1)*(G4   *(G1(1)+1./UBAR0) +G2(1)*G3(1) )/DENOM
+      AP = F0PI*W0(1)*(G3(1)*(G1(1)-1./UBAR0) +G2(1)*G4    )/DENOM
+
+C     CPMID AND CMMID  ARE THE CPLUS AND CMINUS TERMS EVALUATED
+C     AT THE MIDDLE OF THE LAYER.
+
+      CPMID  = AP
+      CMMID  = AM
+
+      FLUXUP = XK1(1)*EP + GAMA(1)*XK2(1)*EM + CPMID
+      FLUXDN = XK1(1)*EP*GAMA(1) + XK2(1)*EM + CMMID
+
+C     ADD THE DIRECT FLUX TO THE DOWNWELLING TERM
+
+      fluxdn = fluxdn+UBAR0*F0PI*EXP(-MIN(TAUCUM(1),TAUMAX)/UBAR0)
+
+C     This is for the "special" bottom layer, where we take
+C     DTAU instead of DTAU/2.
+
+      L     = L_NLAYRAD 
+      EXPTRM(L) = MIN(TAUMAX,LAMDA(L)*(TAUCUM(L_LEVELS)-
+     *                                 TAUCUM(L_LEVELS-1)))
+
+      EP    = EXP(EXPTRM(L))
+      EM    = 1.0/EP
+      G4    = 1.0-G3(L)
+      DENOM = LAMDA(L)**2 - 1./UBAR0**2
+
+
+C     THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0
+C     THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN 
+C     THE SCATTERING GOES TO ZERO
+C     PREVENT THIS WITH A IF STATEMENT
+
+
+      IF ( DENOM .EQ. 0.) THEN
+        DENOM=1.E-10
+      END IF
+
+      AM = F0PI*W0(L)*(G4   *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM
+      AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4    )/DENOM
+
+C     CPMID AND CMMID  ARE THE CPLUS AND CMINUS TERMS EVALUATED
+C     AT THE MIDDLE OF THE LAYER.
+
+      TAUMID   = MIN(TAUCUM(L_LEVELS),TAUMAX)
+      CPMID    = AP*EXP(-MIN(TAUMID,TAUMAX)/UBAR0)
+      CMMID    = AM*EXP(-MIN(TAUMID,TAUMAX)/UBAR0)
+
+
+      FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID
+      FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID
+
+C  Save the diffuse downward flux for TEMPGR calculations
+
+      DIFFV = FMIDM(L)
+
+
+C     ADD THE DIRECT FLUX TO THE DOWNWELLING TERM
+
+      FMIDM(L)= FMIDM(L)+UBAR0*F0PI*EXP(-MIN(TAUMID,TAUMAX)/UBAR0)
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gradients_kcm.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gradients_kcm.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/gradients_kcm.F90	(revision 222)
@@ -0,0 +1,126 @@
+subroutine gradients_kcm(profil_flag,rho_v,rho_n,T,dTdp,dPvdp,dPndp)
+
+  use params_h
+  use gases_h
+  implicit none
+
+  ! inputs
+  integer profil_flag ! 0 = dry, 1 = moist, 2 = isothermal
+  double precision rho_v,rho_n,T
+
+  ! outputs
+  double precision dTdp,dPndp,dPvdp
+  double precision a_v
+
+  ! internal
+  !double precision cp_n,cp_v
+  double precision cp_v
+
+  double precision press, rho_plus, rho_minus, dVdT, rho_c
+  double precision dlnr,dlna,dpsat,dsv
+  double precision s_minus,s_plus
+  double precision s_v,s_c,L
+  double precision psat_plus,psat_minus,Pn
+  double precision nul
+
+  ! functions
+  double precision cp_neutral
+
+  !cp_n = cp_neutral(T)
+
+  select case(profil_flag)
+  case(2) ! isothermal
+
+     dTdp  = 0.
+     a_v   = rho_v/rho_n ! constant here
+     dPndp = 1/(1d0+m_n/m_v*a_v)
+     dPvdp = 1 - dPndp
+
+  case(1) ! moist
+
+     Pn = rho_n*T*rmn
+
+     if(ngasmx.eq.1)then
+        print*,'Cannot have moist adiabat with one gas...'
+        stop
+     endif
+
+     if(trim(gnom(ngasmx)).eq.'H2O')then
+
+        call psat_H2O(T-2d-1,psat_minus)
+        call psat_H2O(T+2d-1,psat_plus)
+        call psat_H2O(T,press)
+
+        rho_minus = m_v*psat_minus*1d6/(Rc*(T-2d-1))
+        rho_plus  = m_v*psat_plus*1d6/(Rc*(T+2d-1))
+
+        call therm(T-2d-1,rho_minus*1d-3,nul,nul,nul,nul,nul,nul,nul,&
+                   nul,nul,press,s_minus,nul)
+        call therm(T+2d-1,rho_plus*1d-3,nul,nul,nul,nul,nul,nul,nul,&
+                   nul,nul,press,s_plus,nul)
+        s_c = 2.06 * log(T/273.15)
+
+        s_plus  = s_plus  * 1d3
+        s_minus = s_minus * 1d3
+        s_c     = s_c     * 1d3 ! convert to SI
+
+        if(T.lt.280.0)then 
+           dpsat = press*1d6 * ( 1730.63*log(10.) / (T-39.714)**2 )
+        else
+           call tdpsdt(T,dpsat)
+           dpsat = dpsat * 1d6 / T
+        endif
+
+     elseif(trim(gnom(ngasmx)).eq.'NH3')then
+
+        call psat_NH3(T-2d-1,psat_minus)
+        call psat_NH3(T+2d-1,psat_plus)
+        call psat_NH3(T,press)
+
+        rho_minus = m_v*psat_minus*1d6/(Rc*(T-2d-1))
+        rho_plus  = m_v*psat_plus*1d6/(Rc*(T+2d-1))
+
+        call latheat_NH3(T-2d-1,nul,s_minus)
+        call latheat_NH3(T+2d-1,nul,s_plus)
+        call latheat_NH3(T,s_c,nul)
+
+        dpsat = press*1d6 * (-2*1.5609d-4*T + 0.1236)
+
+     endif
+
+     dsv  = (s_plus-s_minus)/4d-1  ! dsv*T = ds / d ln[T]
+     s_v  = (s_plus+s_minus)/2d0
+     dlnr = T/rho_v * (rho_plus-rho_minus)/4d-1  ! d ln[rho_v] / d ln[T]
+
+     if(rho_n/rho_v.lt.1e-5)then
+        dlna = -T*dsv/(s_v-s_c)
+     else
+        a_v  = rho_v/rho_n
+        dlna = (rmn*dlnr - cp_n + rmn - a_v*T*dsv)/(a_v*(s_v-s_c)+rmn)  
+        ! d ln[alpha_v] / d ln[T]
+        ! note cp_n + rmn = cv_n, which is what's required
+     endif
+
+     dTdp  = 1d0 / (dpsat + rho_n*rmn*(1d0 + dlnr - dlna)) ! c.f. Marcq S2.2.2
+     dPvdp = dTdp * dpsat
+     dPndp = 1d0 - dPvdp ! from p = p_v + p_n
+
+  case(0) ! dry
+
+     cp_v=0.0
+     if(trim(gnom(ngasmx)).eq.'H2O')then
+        cp_v = (32.24+1.923d-3*T+1.055d-5*T**2-3.511d-9*T**3)/m_v
+     elseif(trim(gnom(ngasmx)).eq.'NH3')then
+        cp_v = 2.058d3
+     elseif(trim(gnom(ngasmx)).eq.'CH4')then
+        cp_v = 2.226d3
+     endif
+
+     dTdp  = 1/(rho_n*cp_n+rho_v*cp_v)
+     dPndp = 1/(1d0+m_n/m_v*rho_v/rho_n)
+     dPvdp = 1/(1d0+m_v/m_n*rho_n/rho_v)
+      
+  end select
+
+
+end subroutine gradients_kcm
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/hydrol.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/hydrol.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/hydrol.F90	(revision 222)
@@ -0,0 +1,390 @@
+subroutine hydrol(ngrid,nq,ptimestep,rnat,tsurf,          &
+     qsurf,dqsurf,dqs_hyd,pcapcal,                &
+     albedo0,albedo,mu0,pdtsurf,pdtsurf_hyd,hice, &
+     pctsrf_sic,sea_ice)
+
+  use ioipsl_getincom 
+  use watercommon_h, only: T_h2O_ice_liq, RLFTT, rhowater, mx_eau_sol
+  USE surfdat_h
+  use comdiurn_h
+  USE comgeomfi_h
+  USE tracer_h
+  use slab_ice_h
+
+  implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculate the surface hydrology and albedo changes.
+!     
+!     Authors
+!     ------- 
+!     Adapted from LMDTERRE by B. Charnay (2010). Further 
+!     modifications by R. Wordsworth (2010).
+!     
+!     Called by
+!     ---------
+!     physiq.F
+!     
+!     Calls
+!     -----
+!     none
+!
+!     Notes
+!     -----
+!     rnat is terrain type: 0-ocean; 1-continent
+!     
+!==================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+      integer ngrid,nq
+
+!     Inputs
+!     ------
+      real albedoice
+      save albedoice
+
+      real snowlayer
+      parameter (snowlayer=33.0)        ! 33 kg/m^2 of snow, equal to a layer of 3.3 cm 
+      real oceantime
+      parameter (oceantime=10*24*3600)
+
+      logical,save :: oceanbulkavg ! relax ocean temperatures to a GLOBAL mean value?
+      logical,save :: activerunoff ! enable simple runoff scheme?
+      logical,save :: oceanalbvary ! ocean albedo varies with the diurnal cycle?
+
+!     Arguments
+!     ---------
+      real rnat(ngrid) ! I changed this to integer (RW)
+      real,dimension(:),allocatable,save :: runoff
+      real totalrunoff, tsea, oceanarea
+      save oceanarea
+
+      real ptimestep
+      real mu0(ngrid)
+      real qsurf(ngrid,nq), tsurf(ngrid)
+      real dqsurf(ngrid,nq), pdtsurf(ngrid)
+      real hice(ngrid)
+      real albedo0(ngrid), albedo(ngrid)
+      real pctsrf_sic(ngrid), sea_ice(ngrid)
+
+      real oceanarea2
+
+!     Output
+!     ------
+      real dqs_hyd(ngrid,nq)
+      real pdtsurf_hyd(ngrid)
+
+!     Local
+!     -----
+      real a,b,E
+      integer ig,iq, icap ! wld like to remove icap
+      real fsnoi, subli, fauxo
+      real twater(ngrid)
+      real pcapcal(ngrid)
+      real hicebis(ngrid)
+      real zqsurf(ngrid,nq)
+      real ztsurf(ngrid)
+      real albedo_sic, alb_ice
+      real zfra
+
+      integer, save :: ivap, iliq, iice
+
+      logical, save :: firstcall
+
+      data firstcall /.true./
+
+
+      if(firstcall)then
+
+         oceanbulkavg=.false.
+         oceanalbvary=.false.
+         write(*,*)"Activate runnoff into oceans?"
+         activerunoff=.false.
+         call getin("activerunoff",activerunoff)
+         write(*,*)" activerunoff = ",activerunoff
+	 
+	 
+	 
+         if (activerunoff) ALLOCATE(runoff(ngrid))
+
+         ivap=igcm_h2o_vap
+         iliq=igcm_h2o_vap
+         iice=igcm_h2o_ice
+        
+         write(*,*) "hydrol: ivap=",ivap
+         write(*,*) "        iliq=",iliq
+         write(*,*) "        iice=",iice
+
+!     Here's the deal: iice is used in place of igcm_h2o_ice both on the 
+!                      surface and in the atmosphere. ivap is used in
+!                      place of igcm_h2o_vap ONLY in the atmosphere, while
+!                      iliq is used in place of igcm_h2o_vap ONLY on the 
+!                      surface.
+
+!                      Soon to be extended to the entire water cycle...
+
+!     Ice albedo = snow albedo for now
+         albedoice=albedosnow
+
+!     Total ocean surface area
+         oceanarea=0.
+         do ig=1,ngrid
+            if(nint(rnat(ig)).eq.0)then
+               oceanarea=oceanarea+area(ig)
+            endif
+         enddo
+
+         if(oceanbulkavg.and.(oceanarea.le.0.))then
+            print*,'How are we supposed to average the ocean'
+            print*,'temperature, when there are no oceans?'
+            call abort
+         endif
+
+         if(activerunoff.and.(oceanarea.le.0.))then
+            print*,'You have enabled runoff, but you have no oceans.'
+            print*,'Where did you think the water was going to go?'
+            call abort
+         endif
+         
+         firstcall = .false.
+      endif
+
+!     add physical tendencies already calculated
+!     ------------------------------------------
+
+      do ig=1,ngrid
+         ztsurf(ig) = tsurf(ig) + ptimestep*pdtsurf(ig)
+         pdtsurf_hyd(ig)=0.0
+         do iq=1,nq
+            zqsurf(ig,iq) = qsurf(ig,iq) + ptimestep*dqsurf(ig,iq)
+         enddo    
+      enddo
+ 
+      do ig=1,ngrid
+         do iq=1,nq
+            dqs_hyd(ig,iq) = 0.0
+         enddo
+      enddo
+
+      do ig = 1, ngrid
+
+!     Ocean
+!     -----
+         if(nint(rnat(ig)).eq.0)then
+
+!     re-calculate oceanic albedo
+!            if(diurnal.and.oceanalbvary)then
+!               fauxo      = ( 1.47 - ACOS( mu0(ig) ) )/0.15 ! where does this come from (Benjamin)?
+!               albedo(ig) = 1.1*( .03 + .630/( 1. + fauxo*fauxo))
+!               albedo(ig) = MAX(MIN(albedo(ig),0.60),0.04)
+!            else
+               albedo(ig) = alb_ocean ! modif Benjamin
+!            end if
+
+
+          if(ok_slab_ocean) then
+
+! Fraction neige (hauteur critique 45kg/m2~15cm)
+            zfra = MAX(0.0,MIN(1.0,zqsurf(ig,iice)/45.0))
+! Albedo glace
+            alb_ice=alb_ice_max-(alb_ice_max-alb_ice_min) &
+            *exp(-sea_ice(ig)/h_alb_ice)
+! Albedo glace+neige
+            albedo_sic= albedosnow*zfra + alb_ice*(1.0-zfra)
+
+! Albedo final
+            albedo(ig) = pctsrf_sic(ig)*albedo_sic + (1.-pctsrf_sic(ig))*alb_ocean
+!     oceanic ice height, just for diagnostics
+            hice(ig)    = MIN(10.,sea_ice(ig)/rhowater)
+          else !ok_slab_ocean
+
+
+!     calculate oceanic ice height including the latent heat of ice formation
+!     hice is the height of oceanic ice with a maximum of maxicethick.
+            hice(ig)    = zqsurf(ig,iice)/rhowater ! update hice to include recent snowfall
+
+!            twater(ig)  = tsurf(ig) + ptimestep*zdtsurf(ig) &
+            twater(ig)  = ztsurf(ig) - hice(ig)*RLFTT*rhowater/pcapcal(ig)
+            ! this is temperature water would have if we melted entire ocean ice layer
+            hicebis(ig) = hice(ig)
+            hice(ig)    = 0.
+
+            if(twater(ig) .lt. T_h2O_ice_liq)then
+               E=min((T_h2O_ice_liq+Tsaldiff-twater(ig))*pcapcal(ig),RLFTT*rhowater*maxicethick)
+               hice(ig)        = E/(RLFTT*rhowater)
+               hice(ig)        = max(hice(ig),0.0)
+               hice(ig)        = min(hice(ig),maxicethick)
+               pdtsurf_hyd(ig) = (hice(ig) - hicebis(ig))*RLFTT*rhowater/pcapcal(ig)/ptimestep              
+               albedo(ig)      = albedoice
+
+!               if (zqsurf(ig,iice).ge.snowlayer) then
+!                  albedo(ig) = albedoice
+!               else
+!                  albedo(ig) = albedoocean &
+!                       + (albedosnow - albedoocean)*zqsurf(ig,iice)/snowlayer
+!               endif
+
+            else
+
+               pdtsurf_hyd(ig) = -hicebis(ig)*RLFTT*rhowater/pcapcal(ig)/ptimestep                
+               albedo(ig)      = alb_ocean
+
+            endif
+
+            zqsurf(ig,iliq) = zqsurf(ig,iliq)-(hice(ig)*rhowater-zqsurf(ig,iice))
+            zqsurf(ig,iice) = hice(ig)*rhowater
+
+          endif!(ok_slab_ocean)
+
+
+!     Continent
+!     ---------
+         elseif (nint(rnat(ig)).eq.1) then
+
+!     melt the snow
+            if(ztsurf(ig).gt.T_h2O_ice_liq)then
+               if(zqsurf(ig,iice).gt.1.0e-8)then
+
+                  a     = (ztsurf(ig)-T_h2O_ice_liq)*pcapcal(ig)/RLFTT
+                  b     = zqsurf(ig,iice)
+                  fsnoi = min(a,b)
+
+                  zqsurf(ig,iice) = zqsurf(ig,iice) - fsnoi
+                  zqsurf(ig,iliq) = zqsurf(ig,iliq) + fsnoi
+
+!                 thermal effects
+                  pdtsurf_hyd(ig) = -fsnoi*RLFTT/pcapcal(ig)/ptimestep  
+
+               endif
+            else
+
+!     freeze the water
+               if(zqsurf(ig,iliq).gt.1.0e-8)then
+
+                  a     = -(ztsurf(ig)-T_h2O_ice_liq)*pcapcal(ig)/RLFTT
+                  b     = zqsurf(ig,iliq)
+                  
+                  fsnoi = min(a,b)
+
+                  zqsurf(ig,iice) = zqsurf(ig,iice) + fsnoi
+                  zqsurf(ig,iliq) = zqsurf(ig,iliq) - fsnoi
+
+!                 thermal effects
+                  pdtsurf_hyd(ig) = +fsnoi*RLFTT/pcapcal(ig)/ptimestep  
+
+               endif
+            endif
+            
+!     deal with runoff
+            if(activerunoff)then
+
+               runoff(ig) = max(zqsurf(ig,iliq) - mx_eau_sol, 0.0)
+               if(ngrid.gt.1)then ! runoff only exists in 3D
+                  if(runoff(ig).ne.0.0)then
+                     zqsurf(ig,iliq) = mx_eau_sol
+!                    runoff is added to ocean at end
+                  endif
+               end if
+
+            endif
+
+!     re-calculate continental albedo
+            albedo(ig) = albedo0(ig) ! albedo0 = base values
+            if (zqsurf(ig,iice).ge.snowlayer) then
+               albedo(ig) = albedosnow
+            else
+               albedo(ig) = albedo0(ig) &
+                    + (albedosnow - albedo0(ig))*zqsurf(ig,iice)/snowlayer
+            endif
+
+         else
+
+            print*,'Surface type not recognised in hydrol.F!'
+            print*,'Exiting...'
+            call abort
+
+         endif
+
+      end do ! ig=1,ngrid
+
+!     perform crude bulk averaging of temperature in ocean
+!     ----------------------------------------------------
+      if(oceanbulkavg)then
+
+         oceanarea2=0.       
+         DO ig=1,ngrid
+            if((nint(rnat(ig)).eq.0).and.(hice(ig).eq.0.))then
+               oceanarea2=oceanarea2+area(ig)*pcapcal(ig)
+            end if
+         END DO
+       
+         tsea=0.
+         DO ig=1,ngrid
+            if((nint(rnat(ig)).eq.0).and.(hice(ig).eq.0.))then       
+               tsea=tsea+ztsurf(ig)*area(ig)*pcapcal(ig)/oceanarea2
+            end if
+         END DO
+
+         DO ig=1,ngrid
+            if((nint(rnat(ig)).eq.0).and.(hice(ig).eq.0))then
+               pdtsurf_hyd(ig) = pdtsurf_hyd(ig) + (tsea-ztsurf(ig))/oceantime
+            end if
+         END DO
+
+         print*,'Mean ocean temperature               = ',tsea,' K'
+
+      endif
+
+!     shove all the runoff water into the ocean
+!     -----------------------------------------
+      if(activerunoff)then
+
+         totalrunoff=0.
+         do ig=1,ngrid
+            if (nint(rnat(ig)).eq.1) then
+               totalrunoff = totalrunoff + area(ig)*runoff(ig)
+            endif
+         enddo
+         
+         do ig=1,ngrid
+            if (nint(rnat(ig)).eq.0) then
+               zqsurf(ig,iliq) = zqsurf(ig,iliq) + &
+                    totalrunoff/oceanarea
+            endif
+         enddo
+
+      endif         
+
+
+!     Re-add the albedo effects of CO2 ice if necessary
+!     -------------------------------------------------
+      if(co2cond)then
+
+         icap=1
+         do ig=1,ngrid
+            if (qsurf(ig,igcm_co2_ice).gt.0) then
+               albedo(ig) = albedice(icap)
+            endif
+         enddo
+         
+      endif
+
+
+      do ig=1,ngrid
+         dqs_hyd(ig,iliq)=(zqsurf(ig,iliq) - qsurf(ig,iliq))/ptimestep
+         dqs_hyd(ig,iice)=(zqsurf(ig,iice) - qsurf(ig,iice))/ptimestep
+      enddo
+
+      if (activerunoff) then
+        call writediagfi(ngrid,'runoff','Runoff amount',' ',2,runoff)
+      endif
+
+      return
+    end subroutine hydrol
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ini_archive.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ini_archive.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ini_archive.F	(revision 222)
@@ -0,0 +1,530 @@
+c=======================================================================
+      subroutine ini_archive(nid,idayref,phis,ith,tab_cntrl_fi,
+     &                       tab_cntrl_dyn)
+c=======================================================================
+c
+c
+c   Date:    01/1997
+c   ----
+c
+c   Objet:  ecriture de l'entete du fichier "start_archive"
+c   -----
+c
+c	 Proche de iniwrite.F
+c
+c	 On ajoute dans le tableau "tab_cntrl" (dynamique), a partir de 51, 
+c	 les valeurs de tab_cntrl_fi (les 38 parametres de controle physiques
+c	 du RUN + ptotal et cotoicetotal)
+c
+c			tab_cntrl(50+l)=tab_cntrl_fi(l)
+c
+c   Arguments:
+c   ---------
+c
+c	Inputs:
+c   ------
+c
+c       nid            unite logique du fichier "start_archive"
+c       idayref        Valeur du jour initial a mettre dans
+c                      l'entete du fichier "start_archive"
+c       phis           geopotentiel au sol
+c       ith            soil thermal inertia
+c       tab_cntrl_fi   tableau des param physiques
+c
+
+c=======================================================================
+
+      USE comsoil_h
+!      use control_mod
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "serre.h"
+!#include "control.h"
+
+#include "netcdf.inc"
+
+c-----------------------------------------------------------------------
+c   Declarations
+c-----------------------------------------------------------------------
+
+c   Local:
+c   ------
+      INTEGER	length,l
+      parameter (length = 100)
+      REAL		tab_cntrl(length) ! tableau des parametres du run
+      INTEGER	loop
+      INTEGER	ierr, setvdim, putvdim, putdat, setname,cluvdb
+      INTEGER	setdim
+      INTEGER	ind1,indlast
+
+c   Arguments:
+c   ----------
+      INTEGER*4	idayref
+      REAL		phis(ip1jmp1)
+      real ith(ip1jmp1,nsoilmx)
+      REAL		tab_cntrl_fi(length)
+      REAL tab_cntrl_dyn(length)
+
+!Mars --------Ajouts-----------
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3) !, dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_llmp1,idim_llm
+      INTEGER idim_tim
+      INTEGER idim_nsoilmx ! "subsurface_layers" dimension ID #
+      INTEGER nid,nvarid
+      real sig_s(llm),s(llm)
+
+      pi  = 2. * ASIN(1.)
+
+
+c-----------------------------------------------------------------------
+c   Remplissage du tableau des parametres de controle du RUN  (dynamique)
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+         tab_cntrl(l)=0.
+      ENDDO
+      
+      tab_cntrl(1:50)=tab_cntrl_dyn(1:50)
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!      tab_cntrl(1)  = FLOAT(iim) ! nombre de points en longitude
+!      tab_cntrl(2)  = FLOAT(jjm) ! nombre de points en latitude
+!      tab_cntrl(3)  = FLOAT(llm) ! nombre de couches
+!      tab_cntrl(4)  = FLOAT(idayref) ! jour 0
+!      tab_cntrl(5)  = rad ! rayon de mars(m) ~3397200
+!      tab_cntrl(6)  = omeg ! vitesse de rotation (rad.s-1)
+!      tab_cntrl(7)  = g   ! gravite (m.s-2) ~3.72
+!      tab_cntrl(8)  = cpp 
+!      tab_cntrl(8)  = 43.49 !mars temporaire Masse molaire de l''atm (g.mol-1) ~43.49
+!      tab_cntrl(9)  = kappa ! = r/cp  ~0.256793 (=rcp dans physique)
+!      tab_cntrl(10) = daysec ! duree du sol (s)  ~88775
+!      tab_cntrl(11) = dtvr ! pas de temps de la dynamique (s)
+!      tab_cntrl(12) = etot0 ! energie totale    !
+!      tab_cntrl(13) = ptot0 ! pression totalei   !    variables
+!      tab_cntrl(14) = ztot0 ! enstrophie totale   !  de controle
+!      tab_cntrl(15) = stot0 ! enthalpie totale   !    globales
+!      tab_cntrl(16) = ang0 ! moment cinetique  !
+!      tab_cntrl(17) = pa
+!      tab_cntrl(18) = preff
+
+c    .....    parametres  pour le zoom      ......   
+
+!      tab_cntrl(19)  = clon ! longitude en degres du centre du zoom
+!      tab_cntrl(20)  = clat ! latitude en degres du centre du zoom
+!      tab_cntrl(21)  = grossismx ! facteur de grossissement du zoom,selon longitude
+!      tab_cntrl(22)  = grossismy ! facteur de grossissement du zoom ,selon latitude
+
+!      IF ( fxyhypb )   THEN
+!       tab_cntrl(23) = 1.
+!       tab_cntrl(24) = dzoomx ! extension en longitude  de la zone du zoom
+!       tab_cntrl(25) = dzoomy ! extension en latitude  de la zone du zoom
+!      ELSE
+!       tab_cntrl(23) = 0.
+!       tab_cntrl(24) = dzoomx ! extension en longitude  de la zone du zoom
+!       tab_cntrl(25) = dzoomy ! extension en latitude  de la zone du zoom
+!       tab_cntrl(26) = 0.
+!       IF ( ysinus)  tab_cntrl(26) = 1.
+!      ENDIF
+
+c-----------------------------------------------------------------------
+c   Copie du tableau des parametres de controle du RUN  (physique)
+c		dans le tableau tab_cntrl
+c-----------------------------------------------------------------------
+
+      DO l=1,50
+         tab_cntrl(50+l)=tab_cntrl_fi(l)
+      ENDDO
+
+c=======================================================================
+c	Ecriture NetCDF de l''entete du fichier "start_archive"
+c=======================================================================
+
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 21,
+     &                       "Fichier start_archive")
+c
+c Definir les dimensions du fichiers:
+c
+c     CHAMPS AJOUTES POUR LA VISUALISATION T,ps, etc... avec Grads ou ferret:
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid,"subsurface_layers",nsoilmx,idim_nsoilmx)
+
+      ierr = NF_DEF_DIM (nid,"index", length, idim_index)
+      ierr = NF_DEF_DIM (nid,"rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid,"rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid,"interlayer", llmp1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid,"Time", NF_UNLIMITED, idim_tim)
+
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+
+c-----------------------------------------------------------------------
+c  Ecriture du tableau des parametres du run
+c-----------------------------------------------------------------------
+
+      call def_var(nid,"Time","Time","days since 00:00:00",1,
+     .            idim_tim,nvarid,ierr)
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture des longitudes et latitudes
+c-----------------------------------------------------------------------
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture des niveaux verticaux
+c-----------------------------------------------------------------------
+
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_llmp1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_llmp1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Coef A: niveaux pression hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_llmp1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_llmp1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 35,
+     .                       "Coefficient B niveaux sigma hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aps",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aps",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 36,
+     .      "Coef AS: hybrid pressure in midlayers")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bps",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bps",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 30,
+     .      "Coef BS: hybrid sigma midlayers")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+c
+c ----------------------
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c ------------------------------------------------------------------
+c  Variable uniquement pour visualisation avec Grads ou Ferret
+c ------------------------------------------------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"latitude",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"latitude",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c----------------------
+       ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c--------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1,
+     .       idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1,
+     .       idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",10,"pseudo-alt")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif
+
+!-------------------------------
+! (soil) depth variable mlayer() (known from comsoil.h)
+!-------------------------------
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"soildepth",NF_DOUBLE,1,idim_nsoilmx,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"soildepth",NF_FLOAT,1,idim_nsoilmx,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 20,
+     .                        "Soil mid-layer depth")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",1,"m")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"positive",4,"down")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,mlayer)
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,mlayer)
+#endif
+
+!---------------------
+! soil thermal inertia
+!---------------------
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      dims3(1)=idim_rlonv
+      dims3(2)=idim_rlatu
+      dims3(3)=idim_nsoilmx
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"inertiedat",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"inertiedat",NF_FLOAT,3,dims3,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 20,
+     &                        "Soil thermal inertia")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",15,
+     &                        "J.s-1/2.m-2.K-1")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,ith)
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,ith)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture aire et coefficients de passage cov. <-> contra. <--> naturel
+c-----------------------------------------------------------------------
+
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture du geopentiel au sol
+c-----------------------------------------------------------------------
+
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+
+      PRINT*,'ini_archive: iim,jjm,llm,idayref',iim,jjm,llm,idayref
+      PRINT*,'ini_archive: rad,omeg,g,mugaz,kappa',
+     s rad,omeg,g,tab_cntrl_fi(8),kappa
+      PRINT*,'ini_archive: daysec,dtvr',daysec,dtvr
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniaerosol.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniaerosol.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniaerosol.F	(revision 222)
@@ -0,0 +1,74 @@
+      SUBROUTINE iniaerosol()
+
+
+      use radinc_h, only: naerkind
+      use aerosol_mod
+
+      IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Initialization related to aerosols 
+c   (CO2 aerosols, dust, water, chemical species, ice...)   
+c
+c   author: Laura Kerber, S. Guerlet
+c   ------
+c        
+c=======================================================================
+
+
+#include "callkeys.h"
+      integer ia
+
+      ia=0
+      if (aeroco2) then
+         ia=ia+1
+         iaero_co2=ia
+      endif
+      write(*,*) '--- CO2 aerosol = ', iaero_co2
+ 
+      if (aeroh2o) then
+         ia=ia+1
+         iaero_h2o=ia
+      endif
+      write(*,*) '--- H2O aerosol = ', iaero_h2o
+
+      if (dusttau.gt.0) then
+         ia=ia+1
+         iaero_dust=ia
+      endif
+      write(*,*) '--- Dust aerosol = ', iaero_dust
+
+      if (aeroh2so4) then
+         ia=ia+1
+         iaero_h2so4=ia
+      endif
+      write(*,*) '--- H2SO4 aerosol = ', iaero_h2so4
+      
+      if (aeroback2lay) then
+         ia=ia+1
+         iaero_back2lay=ia
+      endif
+      write(*,*) '--- Two-layer aerosol = ', iaero_back2lay
+
+      write(*,*) '=== Number of aerosols= ', ia
+      
+! For the zero aerosol case, we currently make a dummy co2 aerosol which is zero everywhere.
+! (See aeropacity.F90 for how this works). A better solution would be to turn off the 
+! aerosol machinery in the no aerosol case, but this would be complicated. LK
+
+      if (ia.eq.0) then  !For the zero aerosol case. 
+         ia = 1
+         noaero = .true.
+         iaero_co2=ia
+      endif
+
+      if (ia.ne.naerkind) then
+          print*, 'Aerosols counted not equal to naerkind'
+          print*, 'Compile with tag -s',ia,'to run'
+          print*, 'or change options in callphys.def'
+          print*, 'Abort in iniaerosol.F'
+          call abort
+      endif
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/inifis.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/inifis.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/inifis.F	(revision 222)
@@ -0,0 +1,718 @@
+      SUBROUTINE inifis(ngrid,nlayer,nq,
+     $           day_ini,pdaysec,ptimestep,
+     $           plat,plon,parea,
+     $           prad,pg,pr,pcpp)
+
+      use radinc_h, only : naerkind
+      use datafile_mod, only: datadir
+      use comdiurn_h, only: sinlat, coslat, sinlon, coslon
+      use comgeomfi_h, only: long, lati, area, totarea, totarea_planet
+      use comsoil_h, only: ini_comsoil_h
+      use control_mod, only: ecritphy
+      use planetwide_mod, only: planetwide_sumval
+
+!=======================================================================
+!
+!   purpose:
+!   -------
+!
+!   Initialisation for the physical parametrisations of the LMD 
+!   Generic Model.
+!
+!   author: Frederic Hourdin 15 / 10 /93
+!   -------
+!   modified: Sebastien Lebonnois 11/06/2003 (new callphys.def)
+!             Ehouarn Millour (oct. 2008) tracers are now identified
+!              by their names and may not be contiguously
+!              stored in the q(:,:,:,:) array
+!             E.M. (june 2009) use getin routine to load parameters
+!
+!
+!   arguments:
+!   ----------
+!
+!   input:
+!   ------
+!
+!    ngrid                 Size of the horizontal grid.
+!                          All internal loops are performed on that grid.
+!    nlayer                Number of vertical layers.
+!    pdayref               Day of reference for the simulation
+!    pday                  Number of days counted from the North. Spring
+!                          equinoxe.
+!
+!=======================================================================
+!
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+      use datafile_mod, only: datadir
+! to use  'getin'
+      USE ioipsl_getincom 
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "dimphys.h"
+#include "planete.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+
+      REAL,INTENT(IN) :: prad,pg,pr,pcpp,pdaysec,ptimestep
+ 
+      INTEGER,INTENT(IN) :: ngrid,nlayer,nq
+      REAL,INTENT(IN) :: plat(ngrid),plon(ngrid),parea(ngrid)
+      integer day_ini
+      INTEGER ig,ierr
+ 
+      EXTERNAL iniorbit,orbite
+      EXTERNAL SSUM
+      REAL SSUM
+ 
+      CHARACTER ch1*12
+      CHARACTER ch80*80
+
+      logical chem, h2o
+      logical :: parameter, doubleq=.false.
+
+      real psurf,pN2 ! added by RW for Gliese 581d N2+CO2
+
+      rad=prad
+      daysec=pdaysec
+      dtphys=ptimestep
+      cpp=pcpp
+      g=pg
+      r=pr
+      rcp=r/cpp
+
+      avocado = 6.02214179e23   ! added by RW
+
+! --------------------------------------------------------
+!     The usual Tests
+!     --------------
+      IF (nlayer.NE.nlayermx) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'nlayermx   = ',nlayermx
+         STOP
+      ENDIF
+
+      ! read in 'ecritphy' (frequency of calls to physics, in dynamical steps)
+      ! (also done in dyn3d/defrun_new but not in LMDZ.COMMON)
+      call getin("ecritphy",ecritphy)
+
+! --------------------------------------------------------------
+!  Reading the "callphys.def" file controlling some key options
+! --------------------------------------------------------------
+     
+      ! check that 'callphys.def' file is around
+      OPEN(99,file='callphys.def',status='old',form='formatted'
+     &     ,iostat=ierr)
+      CLOSE(99)
+      
+      IF(ierr.EQ.0) THEN
+         PRINT*
+         PRINT*
+         PRINT*,'--------------------------------------------'
+         PRINT*,' inifis: Parametres pour la physique (callphys.def)'
+         PRINT*,'--------------------------------------------'
+
+         write(*,*) "Directory where external input files are:"
+         ! default 'datadir' is set in "datadir_mod"
+         call getin("datadir",datadir) ! default path
+         write(*,*) " datadir = ",trim(datadir)
+
+         write(*,*) "Run with or without tracer transport ?"
+         tracer=.false. ! default value
+         call getin("tracer",tracer)
+         write(*,*) " tracer = ",tracer
+
+         write(*,*) "Run with or without atm mass update ",
+     &      " due to tracer evaporation/condensation?"
+         mass_redistrib=.false. ! default value
+         call getin("mass_redistrib",mass_redistrib)
+         write(*,*) " mass_redistrib = ",mass_redistrib
+
+         write(*,*) "Diurnal cycle ?"
+         write(*,*) "(if diurnal=false, diurnal averaged solar heating)"
+         diurnal=.true. ! default value
+         call getin("diurnal",diurnal)
+         write(*,*) " diurnal = ",diurnal
+
+         write(*,*) "Seasonal cycle ?"
+         write(*,*) "(if season=false, Ls stays constant, to value ",
+     &   "set in 'start'"
+         season=.true. ! default value
+         call getin("season",season)
+         write(*,*) " season = ",season
+
+         write(*,*) "Tidally resonant rotation ?"
+         tlocked=.false. ! default value
+         call getin("tlocked",tlocked)
+         write(*,*) "tlocked = ",tlocked
+
+         write(*,*) "Saturn ring shadowing ?"
+         rings_shadow = .false.
+         call getin("rings_shadow", rings_shadow)
+         write(*,*) "rings_shadow = ", rings_shadow
+         
+         write(*,*) "Compute latitude-dependent gravity field?"
+         oblate = .false.
+         call getin("oblate", oblate)
+         write(*,*) "oblate = ", oblate
+
+         write(*,*) "Flattening of the planet (a-b)/a "
+         flatten = 0.0
+         call getin("flatten", flatten)
+         write(*,*) "flatten = ", flatten
+         
+
+         write(*,*) "Needed if oblate=.true.: J2"
+         J2 = 0.0
+         call getin("J2", J2)
+         write(*,*) "J2 = ", J2
+         
+         write(*,*) "Needed if oblate=.true.: Planet mass (*1e24 kg)"
+         MassPlanet = 0.0
+         call getin("MassPlanet", MassPlanet)
+         write(*,*) "MassPlanet = ", MassPlanet         
+
+         write(*,*) "Needed if oblate=.true.: Planet mean radius (m)"
+         Rmean = 0.0
+         call getin("Rmean", Rmean)
+         write(*,*) "Rmean = ", Rmean
+         
+! Test of incompatibility:
+! if tlocked, then diurnal should be false
+         if (tlocked.and.diurnal) then
+           print*,'If diurnal=true, we should turn off tlocked.'
+           stop
+         endif
+
+         write(*,*) "Tidal resonance ratio ?"
+         nres=0          ! default value
+         call getin("nres",nres)
+         write(*,*) "nres = ",nres
+
+         write(*,*) "Write some extra output to the screen ?"
+         lwrite=.false. ! default value
+         call getin("lwrite",lwrite)
+         write(*,*) " lwrite = ",lwrite
+
+         write(*,*) "Save statistics in file stats.nc ?"
+         callstats=.true. ! default value
+         call getin("callstats",callstats)
+         write(*,*) " callstats = ",callstats
+
+         write(*,*) "Test energy conservation of model physics ?"
+         enertest=.false. ! default value
+         call getin("enertest",enertest)
+         write(*,*) " enertest = ",enertest
+
+         write(*,*) "Check to see if cpp values used match gases.def ?"
+         check_cpp_match=.true. ! default value
+         call getin("check_cpp_match",check_cpp_match)
+         write(*,*) " check_cpp_match = ",check_cpp_match
+
+         write(*,*) "call radiative transfer ?"
+         callrad=.true. ! default value
+         call getin("callrad",callrad)
+         write(*,*) " callrad = ",callrad
+
+         write(*,*) "call correlated-k radiative transfer ?"
+         corrk=.true. ! default value
+         call getin("corrk",corrk)
+         write(*,*) " corrk = ",corrk
+
+         write(*,*) "prohibit calculations outside corrk T grid?"
+         strictboundcorrk=.true. ! default value
+         call getin("strictboundcorrk",strictboundcorrk)
+         write(*,*) "strictboundcorrk = ",strictboundcorrk
+
+         write(*,*) "call gaseous absorption in the visible bands?",
+     &              "(matters only if callrad=T)"
+         callgasvis=.false. ! default value
+         call getin("callgasvis",callgasvis)
+         write(*,*) " callgasvis = ",callgasvis
+        
+         write(*,*) "call continuum opacities in radiative transfer ?",
+     &              "(matters only if callrad=T)"
+         continuum=.true. ! default value
+         call getin("continuum",continuum)
+         write(*,*) " continuum = ",continuum
+
+         write(*,*) "use analytic function for H2O continuum ?"
+         H2Ocont_simple=.false. ! default value
+         call getin("H2Ocont_simple",H2Ocont_simple)
+         write(*,*) " H2Ocont_simple = ",H2Ocont_simple
+ 
+         write(*,*) "call turbulent vertical diffusion ?"
+         calldifv=.true. ! default value
+         call getin("calldifv",calldifv)
+         write(*,*) " calldifv = ",calldifv
+
+         write(*,*) "use turbdiff instead of vdifc ?"
+         UseTurbDiff=.true. ! default value
+         call getin("UseTurbDiff",UseTurbDiff)
+         write(*,*) " UseTurbDiff = ",UseTurbDiff
+
+         write(*,*) "call convective adjustment ?"
+         calladj=.true. ! default value
+         call getin("calladj",calladj)
+         write(*,*) " calladj = ",calladj
+
+         write(*,*) "call CO2 condensation ?"
+         co2cond=.false. ! default value
+         call getin("co2cond",co2cond)
+         write(*,*) " co2cond = ",co2cond
+! Test of incompatibility
+         if (co2cond.and.(.not.tracer)) then
+            print*,'We need a CO2 ice tracer to condense CO2'
+            call abort
+         endif 
+ 
+         write(*,*) "CO2 supersaturation level ?"
+         co2supsat=1.0 ! default value
+         call getin("co2supsat",co2supsat)
+         write(*,*) " co2supsat = ",co2supsat
+
+         write(*,*) "Radiative timescale for Newtonian cooling ?"
+         tau_relax=30. ! default value
+         call getin("tau_relax",tau_relax)
+         write(*,*) " tau_relax = ",tau_relax
+         tau_relax=tau_relax*24*3600 ! convert Earth days --> seconds
+
+         write(*,*)"call thermal conduction in the soil ?"
+         callsoil=.true. ! default value
+         call getin("callsoil",callsoil)
+         write(*,*) " callsoil = ",callsoil
+         
+         write(*,*)"Rad transfer is computed every iradia",
+     &             " physical timestep"
+         iradia=1 ! default value
+         call getin("iradia",iradia)
+         write(*,*)" iradia = ",iradia
+       
+         write(*,*)"Rayleigh scattering ?"
+         rayleigh=.false.
+         call getin("rayleigh",rayleigh)
+         write(*,*)" rayleigh = ",rayleigh
+
+         write(*,*) "Use blackbody for stellar spectrum ?"
+         stelbbody=.false. ! default value
+         call getin("stelbbody",stelbbody)
+         write(*,*) " stelbbody = ",stelbbody
+
+         write(*,*) "Stellar blackbody temperature ?"
+         stelTbb=5800.0 ! default value
+         call getin("stelTbb",stelTbb)
+         write(*,*) " stelTbb = ",stelTbb
+
+         write(*,*)"Output mean OLR in 1D?"
+         meanOLR=.false.
+         call getin("meanOLR",meanOLR)
+         write(*,*)" meanOLR = ",meanOLR
+
+         write(*,*)"Output spectral OLR in 3D?"
+         specOLR=.false.
+         call getin("specOLR",specOLR)
+         write(*,*)" specOLR = ",specOLR
+
+         write(*,*)"Operate in kastprof mode?"
+         kastprof=.false.
+         call getin("kastprof",kastprof)
+         write(*,*)" kastprof = ",kastprof
+
+         write(*,*)"Uniform absorption in radiative transfer?"
+         graybody=.false.
+         call getin("graybody",graybody)
+         write(*,*)" graybody = ",graybody
+
+! Slab Ocean 
+         write(*,*) "Use slab-ocean ?"
+         ok_slab_ocean=.false.         ! default value
+         call getin("ok_slab_ocean",ok_slab_ocean)
+         write(*,*) "ok_slab_ocean = ",ok_slab_ocean
+
+         write(*,*) "Use slab-sea-ice ?"
+         ok_slab_sic=.true.         ! default value
+         call getin("ok_slab_sic",ok_slab_sic)
+         write(*,*) "ok_slab_sic = ",ok_slab_sic
+
+         write(*,*) "Use heat transport for the ocean ?"
+         ok_slab_heat_transp=.true.   ! default value
+         call getin("ok_slab_heat_transp",ok_slab_heat_transp)
+         write(*,*) "ok_slab_heat_transp = ",ok_slab_heat_transp
+
+
+
+! Test of incompatibility:
+! if kastprof used, we must be in 1D
+         if (kastprof.and.(ngrid.gt.1)) then
+           print*,'kastprof can only be used in 1D!'
+           call abort
+         endif
+
+         write(*,*)"Stratospheric temperature for kastprof mode?"
+         Tstrat=167.0
+         call getin("Tstrat",Tstrat)
+         write(*,*)" Tstrat = ",Tstrat
+
+         write(*,*)"Remove lower boundary?"
+         nosurf=.false.
+         call getin("nosurf",nosurf)
+         write(*,*)" nosurf = ",nosurf
+
+! Tests of incompatibility:
+         if (nosurf.and.callsoil) then
+           print*,'nosurf not compatible with soil scheme!'
+           print*,'... got to make a choice!'
+           call abort
+         endif
+
+         write(*,*)"Add an internal heat flux?",
+     .             "... matters only if callsoil=F"
+         intheat=0.
+         call getin("intheat",intheat)
+         write(*,*)" intheat = ",intheat
+
+         write(*,*)"Use Newtonian cooling for radiative transfer?"
+         newtonian=.false.
+         call getin("newtonian",newtonian)
+         write(*,*)" newtonian = ",newtonian
+
+! Tests of incompatibility:
+         if (newtonian.and.corrk) then
+           print*,'newtonian not compatible with correlated-k!'
+           call abort
+         endif
+         if (newtonian.and.calladj) then
+           print*,'newtonian not compatible with adjustment!'
+           call abort
+         endif
+         if (newtonian.and.calldifv) then
+           print*,'newtonian not compatible with a boundary layer!'
+           call abort
+         endif
+
+         write(*,*)"Test physics timescale in 1D?"
+         testradtimes=.false.
+         call getin("testradtimes",testradtimes)
+         write(*,*)" testradtimes = ",testradtimes
+
+! Test of incompatibility:
+! if testradtimes used, we must be in 1D
+         if (testradtimes.and.(ngrid.gt.1)) then
+           print*,'testradtimes can only be used in 1D!'
+           call abort
+         endif
+
+         write(*,*)"Default planetary temperature?"
+         tplanet=215.0
+         call getin("tplanet",tplanet)
+         write(*,*)" tplanet = ",tplanet
+
+         write(*,*)"Which star?"
+         startype=1 ! default value = Sol
+         call getin("startype",startype)
+         write(*,*)" startype = ",startype
+
+         write(*,*)"Value of stellar flux at 1 AU?"
+         Fat1AU=1356.0 ! default value = Sol today
+         call getin("Fat1AU",Fat1AU)
+         write(*,*)" Fat1AU = ",Fat1AU
+
+
+! TRACERS:
+
+         write(*,*)"Varying H2O cloud fraction?"
+         CLFvarying=.false.     ! default value
+         call getin("CLFvarying",CLFvarying)
+         write(*,*)" CLFvarying = ",CLFvarying
+
+         write(*,*)"Value of fixed H2O cloud fraction?"
+         CLFfixval=1.0                ! default value
+         call getin("CLFfixval",CLFfixval)
+         write(*,*)" CLFfixval = ",CLFfixval
+
+         write(*,*)"fixed radii for Cloud particles?"
+         radfixed=.false. ! default value
+         call getin("radfixed",radfixed)
+         write(*,*)" radfixed = ",radfixed
+
+         if(kastprof)then
+            radfixed=.true.
+         endif  
+
+	 write(*,*)"Number mixing ratio of CO2 ice particles:"
+         Nmix_co2=1.e6 ! default value
+         call getin("Nmix_co2",Nmix_co2)
+         write(*,*)" Nmix_co2 = ",Nmix_co2
+
+!         write(*,*)"Number of radiatively active aerosols:"
+!         naerkind=0. ! default value
+!         call getin("naerkind",naerkind)
+!         write(*,*)" naerkind = ",naerkind
+
+         write(*,*)"Opacity of dust (if used):"
+         dusttau=0. ! default value
+         call getin("dusttau",dusttau)
+         write(*,*)" dusttau = ",dusttau
+
+         write(*,*)"Radiatively active CO2 aerosols?"
+         aeroco2=.false.     ! default value
+         call getin("aeroco2",aeroco2)
+         write(*,*)" aeroco2 = ",aeroco2
+
+         write(*,*)"Fixed CO2 aerosol distribution?"
+         aerofixco2=.false.     ! default value
+         call getin("aerofixco2",aerofixco2)
+         write(*,*)" aerofixco2 = ",aerofixco2
+
+         write(*,*)"Radiatively active water ice?"
+         aeroh2o=.false.     ! default value
+         call getin("aeroh2o",aeroh2o)
+         write(*,*)" aeroh2o = ",aeroh2o
+
+         write(*,*)"Fixed H2O aerosol distribution?"
+         aerofixh2o=.false.     ! default value
+         call getin("aerofixh2o",aerofixh2o)
+         write(*,*)" aerofixh2o = ",aerofixh2o
+
+         write(*,*)"Radiatively active sulfuric acid aersols?"
+         aeroh2so4=.false.     ! default value
+         call getin("aeroh2so4",aeroh2so4)
+         write(*,*)" aeroh2so4 = ",aeroh2so4
+	 
+!=================================
+
+	 write(*,*)"Radiatively active two-layer aersols?"
+         aeroback2lay=.false.     ! default value
+         call getin("aeroback2lay",aeroback2lay)
+         write(*,*)" aeroback2lay = ",aeroback2lay
+
+         write(*,*)"TWOLAY AEROSOL: total optical depth ",
+     &              "in the tropospheric layer (visible)"
+         obs_tau_col_tropo=8.D0
+         call getin("obs_tau_col_tropo",obs_tau_col_tropo)
+         write(*,*)" obs_tau_col_tropo = ",obs_tau_col_tropo
+
+         write(*,*)"TWOLAY AEROSOL: total optical depth ",
+     &              "in the stratospheric layer (visible)"
+         obs_tau_col_strato=0.08D0
+         call getin("obs_tau_col_strato",obs_tau_col_strato)
+         write(*,*)" obs_tau_col_strato = ",obs_tau_col_strato
+
+         write(*,*)"TWOLAY AEROSOL: pres_bottom_tropo? in pa"
+         pres_bottom_tropo=66000.0
+         call getin("pres_bottom_tropo",pres_bottom_tropo)
+         write(*,*)" pres_bottom_tropo = ",pres_bottom_tropo
+
+         write(*,*)"TWOLAY AEROSOL: pres_top_tropo? in pa"
+         pres_top_tropo=18000.0
+         call getin("pres_top_tropo",pres_top_tropo)
+         write(*,*)" pres_top_tropo = ",pres_top_tropo
+
+         write(*,*)"TWOLAY AEROSOL: pres_bottom_strato? in pa"
+         pres_bottom_strato=2000.0
+         call getin("pres_bottom_strato",pres_bottom_strato)
+         write(*,*)" pres_bottom_strato = ",pres_bottom_strato
+
+         write(*,*)"TWOLAY AEROSOL: pres_top_strato? in pa"
+         pres_top_strato=100.0
+         call getin("pres_top_strato",pres_top_strato)
+         write(*,*)" pres_top_strato = ",pres_top_strato
+
+         write(*,*)"TWOLAY AEROSOL: particle size in the ",
+     &              "tropospheric layer, in meters"
+         size_tropo=2.e-6
+         call getin("size_tropo",size_tropo)
+         write(*,*)" size_tropo = ",size_tropo
+
+         write(*,*)"TWOLAY AEROSOL: particle size in the ",
+     &              "stratospheric layer, in meters"
+         size_strato=1.e-7
+         call getin("size_strato",size_strato)
+         write(*,*)" size_strato = ",size_strato
+
+!=================================
+
+         write(*,*)"Cloud pressure level (with kastprof only):"
+         cloudlvl=0. ! default value
+         call getin("cloudlvl",cloudlvl)
+         write(*,*)" cloudlvl = ",cloudlvl
+
+         write(*,*)"Is the variable gas species radiatively active?"
+         Tstrat=167.0
+         varactive=.false.
+         call getin("varactive",varactive)
+         write(*,*)" varactive = ",varactive
+
+         write(*,*)"Is the variable gas species distribution set?"
+         varfixed=.false.
+         call getin("varfixed",varfixed)
+         write(*,*)" varfixed = ",varfixed
+
+         write(*,*)"What is the saturation % of the variable species?"
+         satval=0.8
+         call getin("satval",satval)
+         write(*,*)" satval = ",satval
+
+
+! Test of incompatibility:
+! if varactive, then varfixed should be false
+         if (varactive.and.varfixed) then
+           print*,'if varactive, varfixed must be OFF!'
+           stop
+         endif
+
+         write(*,*) "Gravitationnal sedimentation ?"
+         sedimentation=.false. ! default value
+         call getin("sedimentation",sedimentation)
+         write(*,*) " sedimentation = ",sedimentation
+
+         write(*,*) "Compute water cycle ?"
+         water=.false. ! default value
+         call getin("water",water)
+         write(*,*) " water = ",water
+         
+! Test of incompatibility:
+! if water is true, there should be at least a tracer
+         if (water.and.(.not.tracer)) then
+           print*,'if water is ON, tracer must be ON too!'
+           stop
+         endif
+
+         write(*,*) "Include water condensation ?"
+         watercond=.false. ! default value
+         call getin("watercond",watercond)
+         write(*,*) " watercond = ",watercond
+
+! Test of incompatibility:
+! if watercond is used, then water should be used too
+         if (watercond.and.(.not.water)) then
+           print*,'if watercond is used, water should be used too'
+           stop
+         endif
+
+         write(*,*) "Include water precipitation ?"
+         waterrain=.false. ! default value
+         call getin("waterrain",waterrain)
+         write(*,*) " waterrain = ",waterrain
+
+         write(*,*) "Include surface hydrology ?"
+         hydrology=.false. ! default value
+         call getin("hydrology",hydrology)
+         write(*,*) " hydrology = ",hydrology
+
+         write(*,*) "Evolve surface water sources ?"
+         sourceevol=.false. ! default value
+         call getin("sourceevol",sourceevol)
+         write(*,*) " sourceevol = ",sourceevol
+
+         write(*,*) "Ice evolution timestep ?"
+         icetstep=100.0 ! default value
+         call getin("icetstep",icetstep)
+         write(*,*) " icetstep = ",icetstep
+
+         write(*,*) "Snow albedo ?"
+         albedosnow=0.5         ! default value
+         call getin("albedosnow",albedosnow)
+         write(*,*) " albedosnow = ",albedosnow
+
+         write(*,*) "Maximum ice thickness ?"
+         maxicethick=2.0         ! default value
+         call getin("maxicethick",maxicethick)
+         write(*,*) " maxicethick = ",maxicethick
+
+         write(*,*) "Freezing point of seawater ?"
+         Tsaldiff=-1.8          ! default value
+         call getin("Tsaldiff",Tsaldiff)
+         write(*,*) " Tsaldiff = ",Tsaldiff
+
+         write(*,*) "Does user want to force cpp and mugaz?"
+         force_cpp=.false. ! default value
+         call getin("force_cpp",force_cpp)
+         write(*,*) " force_cpp = ",force_cpp
+
+         if (force_cpp) then
+           mugaz = -99999.
+           PRINT *,'MEAN MOLECULAR MASS in g mol-1 ?'
+           call getin("mugaz",mugaz)
+           IF (mugaz.eq.-99999.) THEN
+               PRINT *, "mugaz must be set if force_cpp = T"
+               STOP
+           ELSE
+               write(*,*) "mugaz=",mugaz
+           ENDIF
+           cpp = -99999.
+           PRINT *,'SPECIFIC HEAT CAPACITY in J K-1 kg-1 ?'
+           call getin("cpp",cpp)
+           IF (cpp.eq.-99999.) THEN
+               PRINT *, "cpp must be set if force_cpp = T"
+               STOP
+           ELSE
+               write(*,*) "cpp=",cpp
+           ENDIF
+!         else
+!           mugaz=8.314*1000./pr
+         endif
+         call su_gases
+         call calc_cpp_mugaz
+
+         PRINT*,'--------------------------------------------'
+         PRINT*
+         PRINT*
+      ELSE
+         write(*,*)
+         write(*,*) 'Cannot read file callphys.def. Is it here ?'
+         stop
+      ENDIF
+
+8000  FORMAT(t5,a12,l8)
+8001  FORMAT(t5,a12,i8)
+
+      PRINT*
+      PRINT*,'inifis: daysec',daysec
+      PRINT*
+      PRINT*,'inifis: The radiative transfer is computed:'
+      PRINT*,'           each ',iradia,' physical time-step'
+      PRINT*,'        or each ',iradia*dtphys,' seconds'
+      PRINT*
+
+
+!-----------------------------------------------------------------------
+!     Some more initialization:
+!     ------------------------
+
+      ! ALLOCATE ARRAYS IN comgeomfi_h
+      IF (.not. ALLOCATED(lati)) ALLOCATE(lati(ngrid))
+      IF (.not. ALLOCATED(long)) ALLOCATE(long(ngrid))
+      IF (.not. ALLOCATED(area)) ALLOCATE(area(ngrid))
+
+      CALL SCOPY(ngrid,plon,1,long,1)
+      CALL SCOPY(ngrid,plat,1,lati,1)
+      CALL SCOPY(ngrid,parea,1,area,1)
+      totarea=SSUM(ngrid,area,1)
+      call planetwide_sumval(area,totarea_planet)
+
+      !! those are defined in comdiurn_h.F90
+      IF (.not.ALLOCATED(sinlat)) ALLOCATE(sinlat(ngrid))
+      IF (.not.ALLOCATED(coslat)) ALLOCATE(coslat(ngrid))
+      IF (.not.ALLOCATED(sinlon)) ALLOCATE(sinlon(ngrid))
+      IF (.not.ALLOCATED(coslon)) ALLOCATE(coslon(ngrid))
+
+      DO ig=1,ngrid
+         sinlat(ig)=sin(plat(ig))
+         coslat(ig)=cos(plat(ig))
+         sinlon(ig)=sin(plon(ig))
+         coslon(ig)=cos(plon(ig))
+      ENDDO
+
+      pi=2.*asin(1.) ! NB: pi is a common in comcstfi.h
+
+      ! allocate "comsoil_h" arrays
+      call ini_comsoil_h(ngrid)
+      
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniorbit.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniorbit.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniorbit.F	(revision 222)
@@ -0,0 +1,121 @@
+      SUBROUTINE iniorbit
+     $     (papoastr,pperiastr,pyear_day,pperi_day,pobliq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:
+c   -------
+c     Frederic Hourdin      22 Fevrier 1991
+c
+c   Objet:
+c   ------
+c    Initialisation du sous programme orbite qui calcule
+c    a une date donnee de l'annee de duree year_day commencant
+c    a l'equinoxe de printemps et dont le periastre se situe
+c    a la date peri_day, la distance au soleil et la declinaison.
+c
+c   Interface:
+c   ----------
+c   - Doit etre appele avant d'utiliser orbite.
+c   - initialise une partie du common planete.h
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   apoastr       \   apoastron and periastron of the orbit in AU
+c   periastr      /   
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "comcstfi.h"
+
+c   Arguments:
+c   ----------
+
+      REAL papoastr,pperiastr,pyear_day,pperi_day,pobliq
+
+c   Local:
+c   ------
+
+      REAL zxref,zanom,zz,zx0,zdx
+      INTEGER iter
+
+c-----------------------------------------------------------------------
+
+      pi=2.*asin(1.)
+
+      apoastr =papoastr
+      periastr=pperiastr
+      year_day=pyear_day
+      obliquit=pobliq
+      peri_day=pperi_day
+
+
+      !!!! SPARADRAP TEMPORAIRE !!!!
+      !!!! SPARADRAP TEMPORAIRE !!!!
+      !!!! We hope that all cases are above 25 Mkm [OK with Gliese 581d]
+      IF ( apoastr .gt. 25.) THEN
+        PRINT*,'!!!!! WARNING !!!!!'
+        PRINT*,'!!!!! YOU ARE ABOUT TO WITNESS A DIRT HACK !!!!!'
+        PRINT*,'This must be an old start file.'
+        PRINT*,'The code changed 19/03/2012: we now use AU.'
+        PRINT*,'So I am assuming units are in Mkm here'
+        PRINT*,'and I am performing a conversion towards AU.'
+        periastr = periastr / 149.598 ! Mkm to AU
+        apoastr = apoastr / 149.598 ! Mkm to AU
+      ENDIF
+      !!!! SPARADRAP TEMPORAIRE !!!!
+      !!!! SPARADRAP TEMPORAIRE !!!!
+
+ 
+      PRINT*,'Periastron in AU  ',periastr
+      PRINT*,'Apoastron in AU  ',apoastr 
+      PRINT*,'Obliquity in degrees  :',obliquit
+
+
+      e_elips=(apoastr-periastr)/(periastr+apoastr)
+      p_elips=0.5*(periastr+apoastr)*(1-e_elips*e_elips)
+
+      print*,'e_elips',e_elips
+      print*,'p_elips',p_elips
+
+c-----------------------------------------------------------------------
+c calcul de l'angle polaire et de la distance au soleil :
+c -------------------------------------------------------
+
+c  calcul de l'zanomalie moyenne
+
+      zz=(year_day-pperi_day)/year_day
+      zanom=2.*pi*(zz-nint(zz))
+      zxref=abs(zanom)
+      PRINT*,'zanom  ',zanom
+
+c  resolution de l'equation horaire  zx0 - e * sin (zx0) = zxref
+c  methode de Newton
+
+      zx0=zxref+e_elips*sin(zxref)
+      DO 110 iter=1,100
+         zdx=-(zx0-e_elips*sin(zx0)-zxref)/(1.-e_elips*cos(zx0))
+         if(abs(zdx).le.(1.e-12)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+      PRINT*,'zx0   ',zx0
+
+c zteta est la longitude solaire
+
+      timeperi=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+      PRINT*,'Solar longitude of periastron timeperi = ',timeperi
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniphysiq.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniphysiq.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniphysiq.F90	(revision 222)
@@ -0,0 +1,78 @@
+subroutine iniphysiq(ngrid,nlayer, punjours, pdayref,ptimestep,          &
+                     plat,plon,parea,pcu,pcv,                            &
+                     prad,pg,pr,pcpp,iflag_phys)
+
+use dimphy, only : klev ! number of atmospheric levels
+use mod_grid_phy_lmdz, only : klon_glo ! number of atmospheric columns
+                                       ! (on full grid)
+use mod_phys_lmdz_para, only : klon_omp, & ! number of columns (on local omp grid)
+                               klon_omp_begin, & ! start index of local omp subgrid
+                               klon_omp_end, & ! end index of local omp subgrid
+                               klon_mpi_begin, & ! start indes of columns (on local mpi grid)
+                               klon_mpi
+use comgeomphy, only : airephy, & ! physics grid area (m2)
+                       cuphy, & ! cu coeff. (u_covariant = cu * u)
+                       cvphy, & ! cv coeff. (v_covariant = cv * v)
+                       rlond, & ! longitudes
+                       rlatd ! latitudes
+use infotrac, only : nqtot ! number of advected tracers
+
+implicit none
+
+real,intent(in) :: prad ! radius of the planet (m)
+real,intent(in) :: pg ! gravitational acceleration (m/s2)
+real,intent(in) :: pr ! ! reduced gas constant R/mu
+real,intent(in) :: pcpp ! specific heat Cp
+real,intent(in) :: punjours ! length (in s) of a standard day
+integer,intent(in) :: ngrid ! number of horizontal grid points in the physics (full grid)
+integer,intent(in) :: nlayer ! number of atmospheric layers
+real,intent(in) :: plat(klon_mpi) ! latitudes of the physics grid
+real,intent(in) :: plon(klon_mpi) ! longitudes of the physics grid
+real,intent(in) :: parea(klon_mpi) ! area (m2)
+real,intent(in) :: pcu(klon_mpi) ! cu coeff. (u_covariant = cu * u)
+real,intent(in) :: pcv(klon_mpi) ! cv coeff. (v_covariant = cv * v)
+integer,intent(in) :: pdayref ! reference day of for the simulation
+real,intent(in) :: ptimestep !physics time step (s)
+integer,intent(in) :: iflag_phys ! type of physics to be called
+
+integer :: ibegin,iend,offset
+character(len=20) :: modname='iniphysiq'
+character(len=80) :: abort_message
+
+IF (nlayer.NE.klev) THEN
+  write(*,*) 'STOP in ',trim(modname)
+  write(*,*) 'Problem with dimensions :'
+  write(*,*) 'nlayer     = ',nlayer
+  write(*,*) 'klev   = ',klev
+  abort_message = ''
+  CALL abort_gcm (modname,abort_message,1)
+ENDIF
+
+IF (ngrid.NE.klon_glo) THEN
+  write(*,*) 'STOP in ',trim(modname)
+  write(*,*) 'Problem with dimensions :'
+  write(*,*) 'ngrid     = ',ngrid
+  write(*,*) 'klon   = ',klon_glo
+  abort_message = ''
+  CALL abort_gcm (modname,abort_message,1)
+ENDIF
+
+!$OMP PARALLEL PRIVATE(ibegin,iend) 
+!$OMP+         SHARED(parea,pcu,pcv,plon,plat)
+      
+offset=0
+airephy(1:klon_omp)=parea(offset+klon_omp_begin:offset+klon_omp_end)
+cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end)
+cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end)
+rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end)
+rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end)
+
+! copy some fundamental parameters to physics 
+! and do some initializations 
+call inifis(klon_omp,nlayer,nqtot,pdayref,punjours,ptimestep, &
+            rlatd,rlond,airephy,prad,pg,pr,pcpp)
+
+!$OMP END PARALLEL
+
+
+end subroutine iniphysiq
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniphysiq.F90.orig
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniphysiq.F90.orig	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniphysiq.F90.orig	(revision 222)
@@ -0,0 +1,77 @@
+subroutine iniphysiq(ngrid,nlayer, punjours, pdayref,ptimestep,          &
+                     plat,plon,parea,pcu,pcv,                            &
+                     prad,pg,pr,pcpp,iflag_phys)
+
+use dimphy, only : klev ! number of atmospheric levels
+use mod_grid_phy_lmdz, only : klon_glo ! number of atmospheric columns
+                                       ! (on full grid)
+use mod_phys_lmdz_para, only : klon_omp, & ! number of columns (on local omp grid)
+                               klon_omp_begin, & ! start index of local omp subgrid
+                               klon_omp_end, & ! end index of local omp subgrid
+                               klon_mpi_begin ! start indes of columns (on local mpi grid)
+use comgeomphy, only : airephy, & ! physics grid area (m2)
+                       cuphy, & ! cu coeff. (u_covariant = cu * u)
+                       cvphy, & ! cv coeff. (v_covariant = cv * v)
+                       rlond, & ! longitudes
+                       rlatd ! latitudes
+use infotrac, only : nqtot ! number of advected tracers
+
+implicit none
+
+real,intent(in) :: prad ! radius of the planet (m)
+real,intent(in) :: pg ! gravitational acceleration (m/s2)
+real,intent(in) :: pr ! ! reduced gas constant R/mu
+real,intent(in) :: pcpp ! specific heat Cp
+real,intent(in) :: punjours ! length (in s) of a standard day
+integer,intent(in) :: ngrid ! number of horizontal grid points in the physics (full grid)
+integer,intent(in) :: nlayer ! number of atmospheric layers
+real,intent(in) :: plat(ngrid) ! latitudes of the physics grid
+real,intent(in) :: plon(ngrid) ! longitudes of the physics grid
+real,intent(in) :: parea(klon_glo) ! area (m2)
+real,intent(in) :: pcu(klon_glo) ! cu coeff. (u_covariant = cu * u)
+real,intent(in) :: pcv(klon_glo) ! cv coeff. (v_covariant = cv * v)
+integer,intent(in) :: pdayref ! reference day of for the simulation
+real,intent(in) :: ptimestep !physics time step (s)
+integer,intent(in) :: iflag_phys ! type of physics to be called
+
+integer :: ibegin,iend,offset
+character(len=20) :: modname='iniphysiq'
+character(len=80) :: abort_message
+
+IF (nlayer.NE.klev) THEN
+  write(*,*) 'STOP in ',trim(modname)
+  write(*,*) 'Problem with dimensions :'
+  write(*,*) 'nlayer     = ',nlayer
+  write(*,*) 'klev   = ',klev
+  abort_message = ''
+  CALL abort_gcm (modname,abort_message,1)
+ENDIF
+
+IF (ngrid.NE.klon_glo) THEN
+  write(*,*) 'STOP in ',trim(modname)
+  write(*,*) 'Problem with dimensions :'
+  write(*,*) 'ngrid     = ',ngrid
+  write(*,*) 'klon   = ',klon_glo
+  abort_message = ''
+  CALL abort_gcm (modname,abort_message,1)
+ENDIF
+
+!$OMP PARALLEL PRIVATE(ibegin,iend) 
+!$OMP+         SHARED(parea,pcu,pcv,plon,plat)
+      
+offset=klon_mpi_begin-1
+airephy(1:klon_omp)=parea(offset+klon_omp_begin:offset+klon_omp_end)
+cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end)
+cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end)
+rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end)
+rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end)
+
+! copy some fundamental parameters to physics 
+! and do some initializations 
+call inifis(klon_omp,nlayer,nqtot,pdayref,punjours,ptimestep, &
+            rlatd,rlond,airephy,prad,pg,pr,pcpp)
+
+!$OMP END PARALLEL
+
+
+end subroutine iniphysiq
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/inistats.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/inistats.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/inistats.F	(revision 222)
@@ -0,0 +1,118 @@
+      subroutine inistats(ierr)
+
+      use mod_phys_lmdz_para, only : is_master
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+      integer,intent(out) :: ierr
+      integer :: nid
+      integer :: l,nsteppd
+      real, dimension(llm) ::  sig_s
+      integer :: idim_lat,idim_lon,idim_llm,idim_llmp1,idim_time
+      real, dimension(istime) :: lt
+      integer :: nvarid
+
+      write (*,*) 
+      write (*,*) '                        || STATS ||'
+      write (*,*) 
+      write (*,*) 'daysec',daysec
+      write (*,*) 'dtphys',dtphys
+      nsteppd=nint(daysec/dtphys)
+      write (*,*) 'nsteppd=',nsteppd
+      if (abs(float(nsteppd)-daysec/dtphys).gt.1.e-8*daysec)
+     &   stop'Dans Instat:  1jour .ne. n pas physiques'
+
+      if(mod(nsteppd,istime).ne.0)
+     &   stop'Dans Instat:  1jour .ne. n*istime pas physiques'
+
+      istats=nsteppd/istime
+      write (*,*) 'istats=',istats
+      write (*,*) 'Storing ',istime,'times per day'
+      write (*,*) 'thus every ',istats,'physical timestep '
+      write (*,*) 
+
+      do l= 1, llm
+         sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+         pseudoalt(l)=-10.*log(presnivs(l)/preff)   
+      enddo
+
+      if (is_master) then
+      ! only the master needs do this
+
+      ierr = NF_CREATE("stats.nc",IOR(NF_CLOBBER,NF_64BIT_OFFSET),nid)
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_lat)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_lon)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid, "llmp1", llm+1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_time)
+
+      ierr = NF_ENDDEF(nid)
+      call def_var_stats(nid,"Time","Time",
+     &            "days since 0000-00-0 00:00:00",1,
+     &            idim_time,nvarid,ierr)
+! Time is initialised later by mkstats subroutine
+
+      call def_var_stats(nid,"latitude","latitude",
+     &            "degrees_north",1,idim_lat,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+      call def_var_stats(nid,"longitude","East longitude",
+     &            "degrees_east",1,idim_lon,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+
+! Niveaux verticaux, aps et bps
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"altitude", NF_DOUBLE, 1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"altitude", NF_FLOAT, 1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",8,"altitude")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif 
+      call def_var_stats(nid,"aps","hybrid pressure at midlayers"
+     & ," ",1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+
+      call def_var_stats(nid,"bps","hybrid sigma at midlayers"
+     & ," ",1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else 
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+
+      ierr=NF_CLOSE(nid)
+
+      endif ! of if (is_master)
+      end subroutine inistats
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/init_phys_lmdz.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/init_phys_lmdz.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/init_phys_lmdz.F90	(revision 222)
@@ -0,0 +1,27 @@
+!
+! $Id$
+!
+SUBROUTINE init_phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
+  USE mod_phys_lmdz_omp_data, only: klon_omp
+  USE mod_grid_phy_lmdz, only: nbp_lev
+  USE mod_phys_lmdz_para, only: init_phys_lmdz_para
+  USE mod_grid_phy_lmdz, only: init_grid_phy_lmdz
+  USE dimphy, ONLY : init_dimphy
+
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: llm
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+
+    CALL init_grid_phy_lmdz(iim,jjp1,sum(distrib),llm)
+    CALL init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL init_dimphy(klon_omp,nbp_lev)
+
+!$OMP END PARALLEL
+ 
+END SUBROUTINE init_phys_lmdz  
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/init_phys_lmdz.F90.orig
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/init_phys_lmdz.F90.orig	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/init_phys_lmdz.F90.orig	(revision 222)
@@ -0,0 +1,27 @@
+!
+! $Id$
+!
+SUBROUTINE init_phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
+  USE mod_phys_lmdz_omp_data, only: klon_omp
+  USE mod_grid_phy_lmdz, only: nbp_lev
+  USE mod_phys_lmdz_para, only: init_phys_lmdz_para
+  USE mod_grid_phy_lmdz, only: init_grid_phy_lmdz
+  USE dimphy, ONLY : init_dimphy
+
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: llm
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+
+    CALL init_grid_phy_lmdz(iim,jjp1,llm)
+    CALL init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL init_dimphy(klon_omp,nbp_lev)
+
+!$OMP END PARALLEL
+ 
+END SUBROUTINE init_phys_lmdz  
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/initracer.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/initracer.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/initracer.F	(revision 222)
@@ -0,0 +1,348 @@
+      SUBROUTINE initracer(ngrid,nq,nametrac)
+
+      use surfdat_h
+      USE comgeomfi_h
+      USE tracer_h
+      IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Initialization related to tracer 
+c   (transported dust, water, chemical species, ice...)
+c
+c   Name of the tracer
+c
+c   Test of dimension :
+c   Initialize COMMON tracer in tracer.h, using tracer names provided
+c   by the argument nametrac
+c
+c   author: F.Forget
+c   ------
+c            Ehouarn Millour (oct. 2008) identify tracers by their names
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+      integer :: ngrid,nq
+
+!      real qsurf(ngrid,nq)       ! tracer on surface (e.g.  kg.m-2)
+!      real co2ice(ngrid)           ! co2 ice mass on surface (e.g.  kg.m-2)
+      character(len=20) :: txt ! to store some text
+      integer iq,ig,count
+      real r0_lift , reff_lift
+!      logical :: oldnames ! =.true. if old tracer naming convention (q01,...)
+
+      character*20 nametrac(nq)   ! name of the tracer from dynamics
+
+
+c-----------------------------------------------------------------------
+c  radius(nq)      ! aerosol particle radius (m)
+c  rho_q(nq)       ! tracer densities (kg.m-3)
+c  qext(nq)        ! Single Scat. Extinction coeff at 0.67 um
+c  alpha_lift(nq)  ! saltation vertical flux/horiz flux ratio (m-1)
+c  alpha_devil(nq) ! lifting coeeficient by dust devil
+c  rho_dust          ! Mars dust density
+c  rho_ice           ! Water ice density
+c  doubleq           ! if method with mass (iq=1) and number(iq=2) mixing ratio
+c  varian            ! Characteristic variance of log-normal distribution
+c-----------------------------------------------------------------------
+
+       !! we allocate once for all arrays in common in tracer_h.F90
+       !! (supposedly those are not used before call to initracer)
+       IF (.NOT.ALLOCATED(noms)) ALLOCATE(noms(nq))
+       ALLOCATE(mmol(nq))
+       ALLOCATE(radius(nq))
+       ALLOCATE(rho_q(nq))
+       ALLOCATE(qext(nq))
+       ALLOCATE(alpha_lift(nq))
+       ALLOCATE(alpha_devil(nq))
+       ALLOCATE(qextrhor(nq))
+       ALLOCATE(igcm_dustbin(nq))
+       !! initialization
+       alpha_lift(:)=0.
+       alpha_devil(:)=0.
+
+! Initialization: get tracer names from the dynamics and check if we are
+!                 using 'old' tracer convention ('q01',q02',...)
+!                 or new convention (full tracer names)
+      ! check if tracers have 'old' names
+
+! copy tracer names from dynamics
+        do iq=1,nq
+          noms(iq)=nametrac(iq)
+        enddo
+
+
+! Identify tracers by their names: (and set corresponding values of mmol)
+      ! 0. initialize tracer indexes to zero:
+      ! NB: igcm_* indexes are commons in 'tracer.h'
+      do iq=1,nq
+        igcm_dustbin(iq)=0
+      enddo
+      igcm_dust_mass=0
+      igcm_dust_number=0
+      igcm_h2o_vap=0
+      igcm_h2o_ice=0
+      igcm_co2=0
+      igcm_co=0
+      igcm_o=0
+      igcm_o1d=0
+      igcm_o2=0
+      igcm_o3=0
+      igcm_h=0
+      igcm_h2=0
+      igcm_oh=0
+      igcm_ho2=0
+      igcm_h2o2=0
+      igcm_n2=0
+      igcm_ar=0
+      igcm_ar_n2=0
+      igcm_co2_ice=0
+
+      write(*,*) 'initracer: noms() ', noms
+
+
+      !print*,'Setting dustbin = 0 in initracer.F'
+      !dustbin=0
+
+      ! 1. find dust tracers
+      count=0
+!      if (dustbin.gt.0) then
+!        do iq=1,nq
+!          txt=" "
+!          write(txt,'(a4,i2.2)')'dust',count+1   
+!          if (noms(iq).eq.txt) then
+!            count=count+1
+!            igcm_dustbin(count)=iq
+!            mmol(iq)=100.
+!          endif
+!        enddo !do iq=1,nq
+!      endif ! of if (dustbin.gt.0)
+
+
+!      if (doubleq) then
+!        do iq=1,nq
+!          if (noms(iq).eq."dust_mass") then
+!            igcm_dust_mass=iq
+!            count=count+1
+!          endif
+!          if (noms(iq).eq."dust_number") then
+!            igcm_dust_number=iq
+!            count=count+1
+!          endif
+!        enddo
+!      endif ! of if (doubleq)
+      ! 2. find chemistry and water tracers
+      do iq=1,nq
+        if (noms(iq).eq."co2") then
+          igcm_co2=iq
+          mmol(igcm_co2)=44.
+          count=count+1
+!          write(*,*) 'co2: count=',count
+        endif
+        if (noms(iq).eq."co2_ice") then
+          igcm_co2_ice=iq
+          mmol(igcm_co2_ice)=44.
+          count=count+1
+!          write(*,*) 'co2_ice: count=',count
+        endif
+        if (noms(iq).eq."h2o_vap") then
+          igcm_h2o_vap=iq
+          mmol(igcm_h2o_vap)=18.
+          count=count+1
+!          write(*,*) 'h2o_vap: count=',count
+        endif
+        if (noms(iq).eq."h2o_ice") then
+          igcm_h2o_ice=iq
+          mmol(igcm_h2o_ice)=18.
+          count=count+1
+!          write(*,*) 'h2o_ice: count=',count
+        endif
+      enddo ! of do iq=1,nq
+      
+      ! check that we identified all tracers:
+      if (count.ne.nq) then
+        write(*,*) "initracer: found only ",count," tracers"
+        write(*,*) "               expected ",nq
+        do iq=1,count
+          write(*,*)'      ',iq,' ',trim(noms(iq))
+        enddo
+!        stop
+      else
+        write(*,*) "initracer: found all expected tracers, namely:"
+        do iq=1,nq
+          write(*,*)'      ',iq,' ',trim(noms(iq))
+        enddo
+      endif
+
+
+c------------------------------------------------------------
+c     Initialisation tracers ....
+c------------------------------------------------------------
+      call zerophys(nq,rho_q)
+
+      rho_dust=2500.  ! Mars dust density (kg.m-3)
+      rho_ice=920.    ! Water ice density (kg.m-3)
+      rho_co2=1620.   ! CO2 ice density (kg.m-3)
+
+
+
+c$$$      if (doubleq) then
+c$$$c       "doubleq" technique 
+c$$$c       -------------------
+c$$$c      (transport of mass and number mixing ratio)
+c$$$c       iq=1: Q mass mixing ratio, iq=2: N number mixing ratio
+c$$$
+c$$$        if( (nq.lt.2).or.(water.and.(nq.lt.3)) ) then
+c$$$          write(*,*)'initracer: nq is too low : nq=', nq
+c$$$          write(*,*)'water= ',water,' doubleq= ',doubleq   
+c$$$        end if
+c$$$
+c$$$        varian=0.637    ! Characteristic variance    
+c$$$        qext(igcm_dust_mass)=3.04   ! reference extinction at 0.67 um for ref dust
+c$$$        qext(igcm_dust_number)=3.04 ! reference extinction at 0.67 um for ref dust
+c$$$        rho_q(igcm_dust_mass)=rho_dust
+c$$$        rho_q(igcm_dust_number)=rho_dust
+c$$$
+c$$$c       Intermediate calcul for computing geometric mean radius r0
+c$$$c       as a function of mass and number mixing ratio Q and N
+c$$$c       (r0 = (r3n_q * Q/ N)
+c$$$        r3n_q = exp(-4.5*varian**2)*(3./4.)/(pi*rho_dust)
+c$$$
+c$$$c       Intermediate calcul for computing effective radius reff
+c$$$c       from geometric mean radius r0
+c$$$c       (reff = ref_r0 * r0)
+c$$$        ref_r0 = exp(2.5*varian**2)
+c$$$        
+c$$$c       lifted dust :
+c$$$c       '''''''''''
+c$$$        reff_lift = 3.e-6      !  Effective radius of lifted dust (m)
+c$$$        alpha_devil(igcm_dust_mass)=9.e-9   !  dust devil lift mass coeff
+c$$$        alpha_lift(igcm_dust_mass)=3.0e-15  !  Lifted mass coeff
+c$$$
+c$$$        r0_lift = reff_lift/ref_r0
+c$$$        alpha_devil(igcm_dust_number)=r3n_q*
+c$$$     &                        alpha_devil(igcm_dust_mass)/r0_lift**3
+c$$$        alpha_lift(igcm_dust_number)=r3n_q*
+c$$$     &                        alpha_lift(igcm_dust_mass)/r0_lift**3
+c$$$
+c$$$c       Not used:
+c$$$        radius(igcm_dust_mass) = 0.
+c$$$        radius(igcm_dust_number) = 0.
+c$$$
+c$$$      else
+
+
+c$$$       if (dustbin.gt.1) then
+c$$$        print*,'ATTENTION:',
+c$$$     $   ' properties of dust need input in initracer !!!'
+c$$$        stop
+c$$$
+c$$$       else if (dustbin.eq.1) then
+c$$$
+c$$$c       This will be used for 1 dust particle size:
+c$$$c       ------------------------------------------
+c$$$        radius(igcm_dustbin(1))=3.e-6
+c$$$        Qext(igcm_dustbin(1))=3.04
+c$$$        alpha_lift(igcm_dustbin(1))=0.0e-6
+c$$$        alpha_devil(igcm_dustbin(1))=7.65e-9
+c$$$        qextrhor(igcm_dustbin(1))=(3./4.)*Qext(igcm_dustbin(1))
+c$$$     &                         /(rho_dust*radius(igcm_dustbin(1)))
+c$$$        rho_q(igcm_dustbin(1))=rho_dust
+c$$$
+c$$$       endif
+c$$$!      end if    ! (doubleq)
+
+c     Initialization for water vapor
+c     ------------------------------
+      if(water) then
+         radius(igcm_h2o_vap)=0.
+         Qext(igcm_h2o_vap)=0.
+         alpha_lift(igcm_h2o_vap) =0.
+         alpha_devil(igcm_h2o_vap)=0.
+	 qextrhor(igcm_h2o_vap)= 0.
+
+c       "Dryness coefficient" controlling the evaporation and
+c        sublimation from the ground water ice (close to 1)
+c        HERE, the goal is to correct for the fact
+c        that the simulated permanent water ice polar caps
+c        is larger than the actual cap and the atmospheric
+c        opacity not always realistic.
+
+
+!         if(ngrid.eq.1)
+
+
+!     to be modified for BC+ version?
+
+         !! this is defined in surfdat_h.F90
+         IF (.not.ALLOCATED(dryness)) ALLOCATE(dryness(ngrid))
+         IF (.not.ALLOCATED(watercaptag)) ALLOCATE(watercaptag(ngrid))
+
+         do ig=1,ngrid
+           if (ngrid.ne.1) watercaptag(ig)=.false.
+           dryness(ig) = 1.
+         enddo
+
+
+
+
+!         IF (caps) THEN
+c Perennial H20 north cap defined by watercaptag=true (allows surface to be
+c hollowed by sublimation in vdifc).
+!         do ig=1,ngrid
+!           if (lati(ig)*180./pi.gt.84) then
+!             if (ngrid.ne.1) watercaptag(ig)=.true.
+!             dryness(ig) = 1.
+c Use the following cap definition for high spatial resolution (latitudinal bin <= 5 deg)
+c	      if (lati(ig)*180./pi.lt.85.and.long(ig).ge.0) then
+c	        if (ngrid.ne.1) watercaptag(ig)=.true.
+c               dryness(ig) = 1.
+c	      endif
+c             if (lati(ig)*180./pi.ge.85) then
+c               if (ngrid.ne.1) watercaptag(ig)=.true.
+c               dryness(ig) = 1.
+c	      endif
+!           endif  ! (lati>80 deg)
+!         end do ! (ngrid)
+!        ENDIF ! (caps)
+
+!         if(iceparty.and.(nq.ge.2)) then
+
+           radius(igcm_h2o_ice)=3.e-6
+           rho_q(igcm_h2o_ice)=rho_ice
+           Qext(igcm_h2o_ice)=0.
+!           alpha_lift(igcm_h2o_ice) =0.
+!           alpha_devil(igcm_h2o_ice)=0.
+           qextrhor(igcm_h2o_ice)= (3./4.)*Qext(igcm_h2o_ice) 
+     $       / (rho_ice*radius(igcm_h2o_ice))
+
+
+
+!         elseif(iceparty.and.(nq.lt.2)) then
+!            write(*,*) 'nq is too low : nq=', nq
+!            write(*,*) 'water= ',water,' iceparty= ',iceparty
+!         endif
+
+      end if  ! (water)
+
+c     Output for records:
+c     ~~~~~~~~~~~~~~~~~~
+      write(*,*)
+      Write(*,*) '******** initracer : dust transport parameters :'
+      write(*,*) 'alpha_lift = ', alpha_lift
+      write(*,*) 'alpha_devil = ', alpha_devil
+      write(*,*) 'radius  = ', radius
+!      if(doubleq) then
+!        write(*,*) 'reff_lift (um) =  ', reff_lift
+!        write(*,*) 'size distribution variance  = ', varian
+!        write(*,*) 'r3n_q , ref_r0 : ', r3n_q , ref_r0
+!      end if
+      write(*,*) 'Qext  = ', qext 
+      write(*,*)
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite.F	(revision 222)
@@ -0,0 +1,356 @@
+      SUBROUTINE iniwrite(nid,idayref,phis)
+
+      use comsoil_h, only: mlayer, nsoilmx
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  L. Fairhead  ,  P. Le Van, Y. Wanherdrick, F. Forget
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   'Initialize' the diagfi.nc file: write down dimensions as well
+c   as time-independent fields (e.g: geopotential, mesh area, ...)
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comcstfi.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+
+      integer,intent(in) :: nid        ! NetCDF file ID
+      INTEGER*4,intent(in) :: idayref  ! date (initial date for this run)
+      real,intent(in) :: phis(ip1jmp1) ! surface geopotential
+
+c   Local:
+c   ------
+      INTEGER length,l
+      parameter (length = 100)
+      REAL tab_cntrl(length) ! run parameters are stored in this array
+      INTEGER ierr
+
+      integer :: nvarid,idim_index,idim_rlonu,idim_rlonv
+      integer :: idim_rlatu,idim_rlatv,idim_llmp1,idim_llm
+      integer :: idim_nsoilmx ! "subsurface_layers" dimension ID #
+      integer, dimension(2) :: id  
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+         tab_cntrl(l)=0.
+      ENDDO
+      tab_cntrl(1)  = real(iim)
+      tab_cntrl(2)  = real(jjm)
+      tab_cntrl(3)  = real(llm)
+      tab_cntrl(4)  = real(idayref)
+      tab_cntrl(5)  = rad
+      tab_cntrl(6)  = omeg
+      tab_cntrl(7)  = g
+      tab_cntrl(8)  = mugaz
+      tab_cntrl(9)  = rcp
+      tab_cntrl(10) = daysec
+      tab_cntrl(11) = dtphys
+      tab_cntrl(12) = etot0
+      tab_cntrl(13) = ptot0
+      tab_cntrl(14) = ztot0
+      tab_cntrl(15) = stot0
+      tab_cntrl(16) = ang0
+c
+c    ..........    P.Le Van  ( ajout le 8/04/96 )    .........
+c         .....        parametres  pour le zoom          ......   
+      tab_cntrl(17)  = clon
+      tab_cntrl(18)  = clat
+      tab_cntrl(19)  = grossismx
+      tab_cntrl(20)  = grossismy
+c
+c     .....   ajout  le 6/05/97 et le 15/10/97  .......
+c
+      IF ( fxyhypb )   THEN
+        tab_cntrl(21) = 1.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+      ELSE
+        tab_cntrl(21) = 0.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+        tab_cntrl(24) = 0.
+        IF( ysinus )  tab_cntrl(24) = 1.
+      ENDIF
+
+c    .........................................................
+
+! Define dimensions
+    
+      ierr = NF_REDEF (nid)
+
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "interlayer", (llm+1), idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid,"subsurface_layers",nsoilmx,idim_nsoilmx)
+c
+      ierr = NF_ENDDEF(nid)
+
+c  Contol parameters for this run
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, 
+     .       idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, 
+     .       idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                       "Control parameters")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c --------------------------
+c  longitudes and latitudes
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rlonu", NF_DOUBLE, 1, idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rlonu", NF_FLOAT, 1, idim_rlonu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                       "Longitudes at u nodes")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid, "latitude", NF_DOUBLE, 1, idim_rlatu,nvarid)
+#else
+      ierr =NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1, 
+     .       idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1, 
+     .       idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",10,"pseudo-alt")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rlatv", NF_DOUBLE, 1, idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rlatv", NF_FLOAT, 1, idim_rlatv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                       "Latitudes at v nodes")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv/pi*180)
+#endif
+c
+c --------------------------
+c  Vertical levels
+      call def_var(nid,"aps","hybrid pressure at midlayers ","Pa",
+     .            1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+
+      call def_var(nid,"bps","hybrid sigma at midlayers"," ",
+     .            1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+
+      call def_var(nid,"ap","hybrid pressure at interlayers","Pa",
+     .            1,idim_llmp1,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+
+      call def_var(nid,"bp","hybrid sigma at interlayers"," ",
+     .            1,idim_llmp1,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+
+!-------------------------------
+! (soil) depth variable mlayer() (known from comsoil_h)
+!-------------------------------
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"soildepth",NF_DOUBLE,1,idim_nsoilmx,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"soildepth",NF_FLOAT,1,idim_nsoilmx,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 20,
+     .                        "Soil mid-layer depth")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",1,"m")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"positive",4,"down")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,mlayer)
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,mlayer)
+#endif
+
+c
+c --------------------------
+c  Mesh area and conversion coefficients cov. <-> contra. <--> natural
+
+      id(1)=idim_rlonu
+      id(2)=idim_rlatu
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "cu", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "cu", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 40,
+     .             "Conversion coefficients cov <--> natural")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      id(1)=idim_rlonv
+      id(2)=idim_rlatv
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "cv", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "cv", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 40,
+     .             "Conversion coefficients cov <--> natural")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+      id(1)=idim_rlonv
+      id(2)=idim_rlatu
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "aire", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "aire", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Mesh area")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c  Surface geopotential
+      id(1)=idim_rlonv
+      id(2)=idim_rlatu
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "phisinit", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "phisinit", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 27,
+     .                       "Geopotential at the surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+
+      write(*,*)'iniwrite: iim,jjm,llm,idayref',iim,jjm,llm,idayref
+      write(*,*)'iniwrite: rad,omeg,g,mugaz,rcp',
+     s rad,omeg,g,mugaz,rcp
+      write(*,*)'iniwrite: daysec,dtphys',daysec,dtphys
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite_specIR.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite_specIR.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite_specIR.F	(revision 222)
@@ -0,0 +1,241 @@
+      SUBROUTINE iniwrite_specIR(nid,idayref)
+
+      use radinc_h, only: L_NSPECTI
+      use radcommon_h, only: WNOI,DWNI
+!      use comsoil_h
+
+      implicit none
+
+c=======================================================================
+c
+c   Auteur:  L. Fairhead  ,  P. Le Van, Y. Wanherdrick, F. Forget
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   'Initialize' the diagfi_spec.nc file: write down dimensions as well
+c   as time-independent fields (e.g: geopotential, mesh area, ...)
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+!include "comconst.h"
+#include "comcstfi.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "serre.h"
+#include"dimphys.h"
+
+c   Arguments:
+c   ----------
+
+      integer,intent(in) :: nid        ! NetCDF file ID
+      INTEGER*4,intent(in) :: idayref  ! date (initial date for this run)
+
+c   Local:
+c   ------
+      INTEGER length,l
+      parameter (length = 100)
+      REAL tab_cntrl(length) ! run parameters are stored in this array
+      INTEGER ierr
+
+      integer :: nvarid,idim_index,idim_rlonu,idim_rlonv
+      integer :: idim_rlatu,idim_rlatv,idim_llmp1,idim_llm
+ !     integer :: idim_nsoilmx ! "subsurface_layers" dimension ID #
+      integer :: idim_bandsIR ! "IR Wavenumber" dimension ID #
+      integer, dimension(2) :: id  
+
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+         tab_cntrl(l)=0.
+      ENDDO
+      tab_cntrl(1)  = FLOAT(iim)
+      tab_cntrl(2)  = FLOAT(jjm)
+      tab_cntrl(3)  = FLOAT(llm)
+      tab_cntrl(4)  = FLOAT(idayref)
+      tab_cntrl(5)  = rad
+      tab_cntrl(6)  = omeg
+      tab_cntrl(7)  = g
+      tab_cntrl(8)  = mugaz
+      tab_cntrl(9)  = rcp
+      tab_cntrl(10) = daysec
+      tab_cntrl(11) = dtphys
+      tab_cntrl(12) = etot0
+      tab_cntrl(13) = ptot0
+      tab_cntrl(14) = ztot0
+      tab_cntrl(15) = stot0
+      tab_cntrl(16) = ang0
+c
+c    ..........    P.Le Van  ( ajout le 8/04/96 )    .........
+c         .....        parametres  pour le zoom          ......   
+      tab_cntrl(17)  = clon
+      tab_cntrl(18)  = clat
+      tab_cntrl(19)  = grossismx
+      tab_cntrl(20)  = grossismy
+c
+c     .....   ajout  le 6/05/97 et le 15/10/97  .......
+c
+      IF ( fxyhypb )   THEN
+        tab_cntrl(21) = 1.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+      ELSE
+        tab_cntrl(21) = 0.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+        tab_cntrl(24) = 0.
+        IF( ysinus )  tab_cntrl(24) = 1.
+      ENDIF
+
+c    .........................................................
+
+! Define dimensions
+    
+      ierr = NF_REDEF (nid)
+
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "IR Wavenumber",L_NSPECTI,idim_bandsIR)
+
+      ierr = NF_ENDDEF(nid)
+
+c  Contol parameters for this run
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, 
+     .       idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, 
+     .       idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                       "Control parameters")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c --------------------------
+c  longitudes and latitudes
+
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid, "latitude", NF_DOUBLE, 1, idim_rlatu,nvarid)
+#else
+      ierr =NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c
+
+!-------------------------------
+! Number of bands in the IR
+!-------------------------------
+
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"IR Wavenumber",NF_DOUBLE,1,
+     .				idim_bandsIR,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"IR Wavenumber",NF_FLOAT,1,
+     .				idim_bandsIR,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 34,
+     .                        "Band mid frequency in the infrared")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",5,"cm^-1")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,dble(WNOI))
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,real(WNOI))
+#endif
+
+!-------------------------------
+! Width of bands in the IR
+!-------------------------------
+
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"IR Bandwidth",NF_DOUBLE,1,
+     .				idim_bandsIR,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"IR Bandwidth",NF_FLOAT,1,
+     .				idim_bandsIR,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 25,
+     .                        "Bandwidth in the infrared")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",5,"cm^-1")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,dble(DWNI))
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,real(DWNI))
+#endif
+c
+c --------------------------
+c  Mesh area and conversion coefficients cov. <-> contra. <--> natural
+
+
+      id(1)=idim_rlonv
+      id(2)=idim_rlatu
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "aire", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "aire", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Mesh area")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite_specVI.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite_specVI.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwrite_specVI.F	(revision 222)
@@ -0,0 +1,242 @@
+      SUBROUTINE iniwrite_specVI(nid,idayref)
+
+      use radinc_h, only: L_NSPECTV
+      use radcommon_h, only: WNOV,DWNV
+      use comsoil_h
+
+      implicit none
+
+c=======================================================================
+c
+c   Auteur:  L. Fairhead  ,  P. Le Van, Y. Wanherdrick, F. Forget
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   'Initialize' the diagfi_spec.nc file: write down dimensions as well
+c   as time-independent fields (e.g: geopotential, mesh area, ...)
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+!include "comconst.h"
+#include "comcstfi.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "serre.h"
+#include"dimphys.h"
+
+c   Arguments:
+c   ----------
+
+      integer nid        ! NetCDF file ID
+      INTEGER*4 idayref  ! date (initial date for this run)
+
+c   Local:
+c   ------
+      INTEGER length,l
+      parameter (length = 100)
+      REAL tab_cntrl(length) ! run parameters are stored in this array
+      INTEGER ierr
+
+      integer :: nvarid,idim_index,idim_rlonu,idim_rlonv
+      integer :: idim_rlatu,idim_rlatv,idim_llmp1,idim_llm
+ !     integer :: idim_nsoilmx ! "subsurface_layers" dimension ID #
+      integer :: idim_bandsVI ! "VI Wavenumber" dimension ID #
+      integer, dimension(2) :: id  
+
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+         tab_cntrl(l)=0.
+      ENDDO
+      tab_cntrl(1)  = FLOAT(iim)
+      tab_cntrl(2)  = FLOAT(jjm)
+      tab_cntrl(3)  = FLOAT(llm)
+      tab_cntrl(4)  = FLOAT(idayref)
+      tab_cntrl(5)  = rad
+      tab_cntrl(6)  = omeg
+      tab_cntrl(7)  = g
+      tab_cntrl(8)  = mugaz
+      tab_cntrl(9)  = rcp
+      tab_cntrl(10) = daysec
+      tab_cntrl(11) = dtphys
+      tab_cntrl(12) = etot0
+      tab_cntrl(13) = ptot0
+      tab_cntrl(14) = ztot0
+      tab_cntrl(15) = stot0
+      tab_cntrl(16) = ang0
+c
+c    ..........    P.Le Van  ( ajout le 8/04/96 )    .........
+c         .....        parametres  pour le zoom          ......   
+      tab_cntrl(17)  = clon
+      tab_cntrl(18)  = clat
+      tab_cntrl(19)  = grossismx
+      tab_cntrl(20)  = grossismy
+c
+c     .....   ajout  le 6/05/97 et le 15/10/97  .......
+c
+      IF ( fxyhypb )   THEN
+        tab_cntrl(21) = 1.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+      ELSE
+        tab_cntrl(21) = 0.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+        tab_cntrl(24) = 0.
+        IF( ysinus )  tab_cntrl(24) = 1.
+      ENDIF
+
+c    .........................................................
+
+! Define dimensions
+    
+      ierr = NF_REDEF (nid)
+
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "VI Wavenumber",L_NSPECTV,idim_bandsVI)
+
+      ierr = NF_ENDDEF(nid)
+
+c  Contol parameters for this run
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, 
+     .       idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, 
+     .       idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                       "Control parameters")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c --------------------------
+c  longitudes and latitudes
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid, "latitude", NF_DOUBLE, 1, idim_rlatu,nvarid)
+#else
+      ierr =NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c
+
+!-------------------------------
+! Number of bands in the IR
+!-------------------------------
+
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"VI Wavenumber",NF_DOUBLE,1,
+     .				idim_bandsVI,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"VI Wavenumber",NF_FLOAT,1,
+     .				idim_bandsVI,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 33,
+     .                        "Band mid frequency in the visible")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",5,"cm^-1")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,dble(WNOV))
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,real(WNOV))
+#endif
+
+c
+!-------------------------------
+! Width of bands in the Visible
+!-------------------------------
+
+      ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode
+      ! define variable
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"VI Bandwidth",NF_DOUBLE,1,
+     .				idim_bandsVI,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"VI Bandwidth",NF_FLOAT,1,
+     .				idim_bandsVI,nvarid)
+#endif
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 24,
+     .                        "Bandwidth in the visible")
+      ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",5,"cm^-1")
+      ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode
+      ! write variable
+#ifdef NC_DOUBLE
+      ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,dble(DWNV))
+#else
+      ierr=NF_PUT_VAR_REAL (nid,nvarid,real(DWNV))
+#endif
+c
+c --------------------------
+c   Mesh area
+c --------------------------
+
+      id(1)=idim_rlonv
+      id(2)=idim_rlatu
+
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "aire", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "aire", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Mesh area")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+
+
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwritesoil.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwritesoil.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iniwritesoil.F90	(revision 222)
@@ -0,0 +1,273 @@
+subroutine iniwritesoil(nid,ngrid)
+
+! initialization routine for 'writediagoil'. Here we create/define
+! dimensions (longitude, latitude, depth and time) and other fixed
+! (time-independent) parameters.
+
+use comsoil_h, only: mlayer, inertiedat, nsoilmx
+
+implicit none
+
+#include"dimensions.h"
+#include"paramet.h"
+#include"comcstfi.h"
+#include"comgeom.h"
+#include"netcdf.inc"
+
+! Arguments:
+integer,intent(in) :: ngrid
+integer,intent(in) :: nid ! NetCDF output file ID
+
+! Local variables:
+
+! NetCDF stuff:
+integer :: ierr ! NetCDF routines return code
+integer :: idim_rlatu ! ID of the 'latitude' dimension
+integer :: idim_rlonv ! ID of the 'longitude' dimension
+integer :: idim_depth ! ID of the 'depth' dimension
+integer :: idim_time  ! ID of the 'time' dimension
+integer :: varid ! to store NetCDF ID of a variable
+integer,dimension(3) :: dimids ! to store IDs of dimensions of a variable
+character(len=60) :: text ! to store some text
+real,dimension(iip1,jjp1,nsoilmx) :: data3 ! to store 3D data
+integer :: i,j,l,ig0
+
+! 1. Define the dimensions
+! Switch to NetCDF define mode
+ierr=NF_REDEF(nid)
+
+! Define the dimensions
+ierr=NF_DEF_DIM(nid,"longitude",iip1,idim_rlonv)
+! iip1 known from paramet.h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define longitude dimension"
+endif
+ierr=NF_DEF_DIM(nid,"latitude",jjp1,idim_rlatu)
+! jjp1 known from paramet.h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define latitude dimension"
+endif
+ierr=NF_DEF_DIM(nid,"depth",nsoilmx,idim_depth)
+! nsoilmx known from dimphys.h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define depth dimension"
+endif
+ierr=NF_DEF_DIM(nid,"time",NF_UNLIMITED,idim_time)
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define time dimension"
+endif
+
+! Switch out of NetCDF define mode
+ierr=NF_ENDDEF(nid)
+
+! 2. Define (as variables) and write dimensions, as well as their attributes
+! 2.1. Longitude
+ierr=NF_REDEF(nid) ! switch to NetCDF define mode
+
+! Define the variable
+#ifdef NC_DOUBLE
+ierr=NF_DEF_VAR(nid,"longitude",NF_DOUBLE,1,idim_rlonv,varid)
+#else
+ierr=NF_DEF_VAR(nid,"longitude",NF_FLOAT,1,idim_rlonv,varid)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define longitude variable"
+endif
+
+! Longitude attributes
+text="East longitude"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"long_name",len_trim(text),text)
+text="degrees_east"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"units",len_trim(text),text)
+
+! Write longitude to file
+ierr=NF_ENDDEF(nid) ! switch out of NetCDF define mode
+! Write
+#ifdef NC_DOUBLE
+ierr=NF_PUT_VAR_DOUBLE(nid,varid,rlonv*(180./pi))
+#else
+ierr=NF_PUT_VAR_REAL(nid,varid,rlonv*(180./pi))
+#endif
+! Note: rlonv is known from comgeom.h and pi from comcstfi.h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not write longitude variable"
+endif
+
+! 2.2. Latitude
+ierr=NF_REDEF(nid) ! switch to NetCDF define mode
+
+! Define the variable
+#ifdef NC_DOUBLE
+ierr=NF_DEF_VAR(nid,"latitude",NF_DOUBLE,1,idim_rlatu,varid)
+#else
+ierr=NF_DEF_VAR(nid,"latitude",NF_FLOAT,1,idim_rlatu,varid)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define latitude variable"
+endif
+
+! Latitude attributes
+text="North latitude"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"long_name",len_trim(text),text)
+text="degrees_north"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"units",len_trim(text),text)
+
+! Write latitude to file
+ierr=NF_ENDDEF(nid) ! switch out of NetCDF define mode
+! Write
+#ifdef NC_DOUBLE
+ierr=NF_PUT_VAR_DOUBLE(nid,varid,rlatu*(180./pi))
+#else
+ierr=NF_PUT_VAR_REAL(nid,varid,rlatu*(180./pi))
+#endif
+! Note: rlatu is known from comgeom.h and pi from comcstfi.h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not write longitude variable"
+endif
+
+! 2.3. Depth
+ierr=NF_REDEF(nid) ! switch to NetCDF define mode
+
+! Define the variable
+#ifdef NC_DOUBLE
+ierr=NF_DEF_VAR(nid,"depth",NF_DOUBLE,1,idim_depth,varid)
+#else
+ierr=NF_DEF_VAR(nid,"depth",NF_FLOAT,1,idim_depth,varid)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define depth variable"
+endif
+
+! Depth attributes
+text="Soil mid-layer depth"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"long_name",len_trim(text),text)
+text="m"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"units",len_trim(text),text)
+text="down"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"positive",len_trim(text),text)
+
+! Write depth to file
+ierr=NF_ENDDEF(nid) ! switch out of NetCDF define mode
+! Write
+#ifdef NC_DOUBLE
+ierr=NF_PUT_VAR_DOUBLE(nid,varid,mlayer)
+#else
+ierr=NF_PUT_VAR_REAL(nid,varid,mlayer)
+#endif
+! Note mlayer(0:nsoilmx-1) known from comsoil_h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not write depth variable"
+endif
+
+! 2.4. Time
+ierr=NF_REDEF(nid) ! switch to NetCDF define mode
+
+! Define the variable
+#ifdef NC_DOUBLE
+ierr=NF_DEF_VAR(nid,"time",NF_DOUBLE,1,idim_time,varid)
+#else
+ierr=NF_DEF_VAR(nid,"time",NF_FLOAT,1,idim_time,varid)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define depth variable"
+endif
+
+! time attributes
+text="Time"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"long_name",len_trim(text),text)
+text="days since 0000-01-01 00:00:00"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"units",len_trim(text),text)
+
+ierr=NF_ENDDEF(nid) ! switch out of NetCDF define mode
+! Note no need to write time variable here; it is done in writediagsoil.
+
+! 3. Other variables to be included
+
+! 3.1 mesh area surrounding each horizontal point
+ierr=NF_REDEF(nid) ! switch to NetCDF define mode
+
+! Define the variable
+dimids(1)=idim_rlonv ! ID of the 'longitude' dimension
+dimids(2)=idim_rlatu ! ID of the 'latitude' dimension
+#ifdef NC_DOUBLE
+ierr=NF_DEF_VAR(nid,"area",NF_DOUBLE,2,dimids,varid)
+#else
+ierr=NF_DEF_VAR(nid,"area",NF_FLOAT,2,dimids,varid)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define area variable"
+endif
+
+! Area attributes
+text="Mesh area"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"long_name",len_trim(text),text)
+text="m2"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"units",len_trim(text),text)
+
+! Write area to file
+ierr=NF_ENDDEF(nid) ! switch out of NetCDF define mode
+! Write
+#ifdef NC_DOUBLE
+ierr=NF_PUT_VAR_DOUBLE(nid,varid,aire)
+#else
+ierr=NF_PUT_VAR_REAL(nid,varid,aire)
+#endif
+! Note: aire is known from comgeom.h
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not write area variable"
+endif
+
+! 3.2 Thermal inertia
+ierr=NF_REDEF(nid) ! switch to NetCDF define mode
+
+! Define the variable
+dimids(1)=idim_rlonv ! ID of the 'longitude' dimension
+dimids(2)=idim_rlatu ! ID of the 'latitude' dimension
+dimids(3)=idim_depth ! ID of the 'depth' dimension
+#ifdef NC_DOUBLE
+ierr=NF_DEF_VAR(nid,"th_inertia",NF_DOUBLE,3,dimids,varid)
+#else
+ierr=NF_DEF_VAR(nid,"th_inertia",NF_FLOAT,3,dimids,varid)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not define th_inertia variable"
+endif
+
+! Attributes
+text="Thermal inertia"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"long_name",len_trim(text),text)
+text="J.s-1/2.m-2.K-1"
+ierr=NF_PUT_ATT_TEXT(nid,varid,"units",len_trim(text),text)
+
+! Recast data along 'dynamics' grid
+! Note: inertiedat is known from comsoil_h
+
+do l=1,nsoilmx
+  ! handle the poles
+  do i=1,iip1
+    data3(i,1,l)=inertiedat(1,l)
+    data3(i,jjp1,l)=inertiedat(ngrid,l)
+  enddo
+  ! rest of the grid
+  do j=2,jjm
+    ig0=1+(j-2)*iim
+    do i=1,iim
+      data3(i,j,l)=inertiedat(ig0+i,l)
+    enddo
+    data3(iip1,j,l)=data3(1,j,l) ! extra (modulo) longitude
+  enddo
+enddo ! of do l=1,nsoilmx
+
+! Write data2 to file
+ierr=NF_ENDDEF(nid) ! switch out of NetCDF define mode
+! Write
+#ifdef NC_DOUBLE
+ierr=NF_PUT_VAR_DOUBLE(nid,varid,data3)
+#else
+ierr=NF_PUT_VAR_REAL(nid,varid,data3)
+#endif
+if (ierr.ne.NF_NOERR) then
+  write(*,*)"iniwritesoil: Error, could not write th_inertia variable"
+endif
+
+end subroutine iniwritesoil
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interp_line.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interp_line.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interp_line.F	(revision 222)
@@ -0,0 +1,55 @@
+      subroutine interp_line(x1,y1,len1,x2,y2,len2)
+      implicit none
+!-----------------------------------------------------------------------
+!
+!  Purpose: Do a series of linear interpolations
+!  Data sets are organized as vectors (see below)
+!  If x2(:), and abscissa at which interpolation is requiered, lies
+!  outside of the interval covered by x1(:), instead of doing an
+!  extrapolation, y2() is set to the value y1() corresponding to
+!  the nearby x1(:) point
+!  
+c-----------------------------------------------------------------------
+!  arguments
+!  ---------
+!  inputs:
+      real x1(len1) ! ordered list of abscissas
+      real y1(len1) ! values at x1(:)
+      integer len1  ! length of x1(:) and y1(:)
+      real x2(len2) !ordered list of abscissas at which interpolation is done
+      integer len2  ! length of x2(:) and y2(:)
+!  outputs:
+      real y2(len2) ! interpolated values
+!-----------------------------------------------------------------------
+
+! local variables:
+      integer i,j
+      
+
+      do i=1,len2
+        ! check if x2(i) lies outside of the interval covered by x1()
+        if(((x2(i).le.x1(1)).and.(x2(i).le.x1(len1))).or.
+     &     ((x2(i).ge.x1(1)).and.(x2(i).ge.x1(len1)))) then
+	  ! set y2(i) to y1(1) or y1(len1)
+	  if (abs(x2(i)-x1(1)).lt.abs(x2(i)-x1(len1))) then
+	    ! x2(i) lies closest to x1(1)
+	    y2(i)=y1(1)
+	  else
+	    ! x2(i) lies closest to x1(len1)
+	    y2(i)=y1(len1)
+	  endif
+
+	else
+        ! find the nearest neigbours and do a linear interpolation
+	 do j=1,len1-1
+          if(((x2(i).ge.x1(j)).and.(x2(i).le.x1(j+1))).or.
+     &       ((x2(i).le.x1(j)).and.(x2(i).ge.x1(j+1)))) then
+	    y2(i)=((x2(i)-x1(j))/(x1(j+1)-x1(j)))*y1(j+1)+
+     &            ((x2(i)-x1(j+1))/(x1(j)-x1(j+1)))*y1(j)
+	  endif
+	 enddo
+	endif
+
+      enddo
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2H2.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2H2.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2H2.F90	(revision 222)
@@ -0,0 +1,125 @@
+     subroutine interpolateH2H2(wn,temp,pres,abcoef,firstcall,ind)
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates the H2-H2 CIA opacity, using a lookup table from
+!     HITRAN (2011)
+!
+!     Authors
+!     -------
+!     R. Wordsworth (2011)
+!     
+!==================================================================
+
+      use datafile_mod, only: datadir
+
+      implicit none
+
+      ! input
+      double precision wn                 ! wavenumber             (cm^-1)
+      double precision temp               ! temperature            (Kelvin)
+      double precision pres               ! pressure               (Pascals)
+
+      ! output
+      double precision abcoef             ! absorption coefficient (m^-1)
+
+      integer nS,nT
+      parameter(nS=2428)
+      parameter(nT=10)
+
+      double precision, parameter :: losch = 2.6867774e19
+      ! Loschmit's number (molecule cm^-3 at STP) 
+      ! converts cm^5 molecule^-2 --> cm^-1 amagat^-2
+      ! see Richard et al. 2011, JQSRT for details
+
+      double precision amagat
+      double precision wn_arr(nS)
+      double precision temp_arr(nT)
+      double precision abs_arr(nS,nT)
+
+      integer k,iT
+      logical firstcall
+
+      save wn_arr, temp_arr, abs_arr
+
+      character*100 dt_file
+      integer strlen,ios
+
+      character(LEN=*), parameter :: fmat1 = "(A20,F10.3,F10.3,I7,F7.1,E10.3,F5.3)"
+
+      character*20 bleh
+      double precision blah, Ttemp
+      integer nres
+
+      integer ind
+
+      if(temp.gt.400)then
+         print*,'Your temperatures are too high for this H2-H2 CIA dataset. If you '
+         print*,'really want to run simulations with hydrogen at T > 400 K, contact'
+         print*,'Robin Wordsworth [rwordsworth@uchicago.edu].'
+         stop
+      endif
+
+      amagat = (273.15/temp)*(pres/101325.0)
+
+      if(firstcall)then ! called by sugas_corrk only
+         print*,'----------------------------------------------------'
+         print*,'Initialising H2-H2 continuum from HITRAN database...'
+
+!     1.1 Open the ASCII files
+         dt_file=TRIM(datadir)//'/continuum_data/H2-H2_norm_2011.cia'
+
+         open(33,file=dt_file,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from interpolateH2H2'
+           write(*,*) 'Data file ',trim(dt_file),' not found.'
+           write(*,*) 'Check that your path to datagcm:',trim(datadir)
+           write(*,*) 'is correct. You can change it in callphys.def with:'
+           write(*,*) 'datadir = /absolute/path/to/datagcm'
+           write(*,*) 'Also check that the continuum data continuum_data/H2-H2_norm_2011.cia is there.'
+           call abort
+         else
+
+            do iT=1,nT
+
+               read(33,fmat1) bleh,blah,blah,nres,Ttemp
+               if(nS.ne.nres)then
+                  print*,'Resolution given in file: ',trim(dt_file)
+                  print*,'is ',nres,', which does not match nS.'
+                  print*,'Please adjust nS value in interpolateH2H2.F90'
+                  stop
+               endif
+               temp_arr(iT)=Ttemp
+
+               do k=1,nS
+                  read(33,*) wn_arr(k),abs_arr(k,it)
+               end do
+
+            end do
+      
+         endif
+         close(33)
+
+         print*,'interpolateH2H2: At wavenumber ',wn,' cm^-1'
+         print*,'   temperature ',temp,' K'
+         print*,'   pressure ',pres,' Pa'
+
+      endif
+
+         call bilinearbig(nS,nT,wn_arr,temp_arr,abs_arr,wn,temp,abcoef,ind)
+
+         !print*,'the absorption is ',abcoef,' cm^5 molecule^-2'
+         !print*,'or ',abcoef*losch**2,' cm^-1 amagat^-2'
+
+         abcoef=abcoef*losch**2*100.0*amagat**2 ! convert to m^-1
+
+         !print*,'We have ',amagat,' amagats of H2'
+         !print*,'So the absorption is ',abcoef,' m^-1'
+
+         ! unlike for Rayleigh scattering, we do not currently weight by the BB function
+         ! however our bands are normally thin, so this is no big deal.
+
+      return
+    end subroutine interpolateH2H2
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2He.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2He.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2He.F90	(revision 222)
@@ -0,0 +1,129 @@
+     subroutine interpolateH2He(wn,temp,presH2,presHe,abcoef,firstcall,ind)
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates the H2-He CIA opacity, using a lookup table from
+!     HITRAN (2011)
+!
+!     Authors
+!     -------
+!     R. Wordsworth (2011)
+!     
+!==================================================================
+
+      use datafile_mod, only: datadir
+
+      implicit none
+
+      ! input
+      double precision wn                 ! wavenumber             (cm^-1)
+      double precision temp               ! temperature            (Kelvin)
+      double precision presH2             ! H2 partial pressure    (Pascals)
+      double precision presHe             ! He partial pressure    (Pascals)
+
+      ! output
+      double precision abcoef             ! absorption coefficient (m^-1)
+
+      integer nS,nT
+      parameter(nS=2428)
+      parameter(nT=10)
+
+      double precision, parameter :: losch = 2.6867774e19
+      ! Loschmit's number (molecule cm^-3 at STP) 
+      ! converts cm^5 molecule^-2 --> cm^-1 amagat^-2
+      ! see Richard et al. 2011, JQSRT for details
+
+      double precision amagatH2
+      double precision amagatHe
+      double precision wn_arr(nS)
+      double precision temp_arr(nT)
+      double precision abs_arr(nS,nT)
+
+      integer k,iT
+      logical firstcall
+
+      save wn_arr, temp_arr, abs_arr
+
+      character*100 dt_file
+      integer strlen,ios
+
+      character(LEN=*), parameter :: fmat1 = "(A20,F10.3,F10.3,I7,F7.1,E10.3,F5.3)"
+
+      character*20 bleh
+      double precision blah, Ttemp
+      integer nres
+
+      integer ind
+ 
+      if(temp.gt.400)then
+         print*,'Your temperatures are too high for this H2-He CIA dataset.'
+         print*,'Please run mixed H2-He atmospheres below T = 400 K.'      
+         stop
+      endif
+
+      amagatH2 = (273.15/temp)*(presH2/101325.0)
+      amagatHe = (273.15/temp)*(presHe/101325.0)
+
+      if(firstcall)then ! called by sugas_corrk only
+         print*,'----------------------------------------------------'
+         print*,'Initialising H2-He continuum from HITRAN database...'
+
+!     1.1 Open the ASCII files
+         dt_file=TRIM(datadir)//'/continuum_data/H2-He_norm_2011.cia'
+
+         open(33,file=dt_file,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from interpolateH2He'
+           write(*,*) 'Data file ',trim(dt_file),' not found.'
+           write(*,*) 'Check that your path to datagcm:',trim(datadir)
+           write(*,*) 'is correct. You can change it in callphys.def with:'
+           write(*,*) 'datadir = /absolute/path/to/datagcm'
+           write(*,*) 'Also check that the continuum data continuum_data/H2-He_norm_2011.cia is there.'
+           call abort
+         else
+
+            do iT=1,nT
+
+               read(33,fmat1) bleh,blah,blah,nres,Ttemp
+               if(nS.ne.nres)then
+                  print*,'Resolution given in file: ',trim(dt_file)
+                  print*,'is ',nres,', which does not match nS.'
+                  print*,'Please adjust nS value in interpolateH2He.F90'
+                  stop
+               endif
+               temp_arr(iT)=Ttemp
+
+               do k=1,nS
+                  read(33,*) wn_arr(k),abs_arr(k,it)
+               end do
+
+            end do
+      
+         endif
+         close(33)
+
+         print*,'interpolateH2He: At wavenumber ',wn,' cm^-1'
+         print*,'   temperature                 ',temp,' K'
+         print*,'   H2 partial pressure         ',presH2,' Pa'
+         print*,'   and He partial pressure     ',presHe,' Pa'
+
+      endif
+
+         call bilinearbig(nS,nT,wn_arr,temp_arr,abs_arr,wn,temp,abcoef,ind)
+
+         !print*,'the absorption is ',abcoef,' cm^5 molecule^-2'
+         !print*,'or ',abcoef*losch**2,' cm^-1 amagat^-2'
+
+         abcoef=abcoef*losch**2*100.0*amagatH2*amagatHe ! convert to m^-1
+
+         !print*,'We have ',amagatH2,' amagats of H2'
+         !print*,'and     ',amagatHe,' amagats of He'
+         !print*,'So the absorption is ',abcoef,' m^-1'
+
+         ! unlike for Rayleigh scattering, we do not currently weight by the BB function
+         ! however our bands are normally thin, so this is no big deal.
+
+      return
+    end subroutine interpolateH2He
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2Ocont_CKD.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2Ocont_CKD.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2Ocont_CKD.F90	(revision 222)
@@ -0,0 +1,167 @@
+     subroutine interpolateH2Ocont_CKD(wn,temp,presS,presF,abcoef,firstcall,ind)
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates the H2O continuum opacity, using a lookup table from
+!     Clough (2005).
+!
+!     Authors
+!     -------
+!     R. Wordsworth (2011)
+!     
+!==================================================================
+
+      use datafile_mod, only: datadir
+      implicit none
+
+      ! input
+      double precision wn                 ! wavenumber             (cm^-1)
+      double precision temp               ! temperature            (Kelvin)
+      double precision presS              ! self-pressure          (Pascals)
+      double precision presF              ! foreign (air) pressure (Pascals)
+
+      ! output
+      double precision abcoef             ! absorption coefficient (m^-1)
+
+      integer nS,nT
+      parameter(nS=1001)
+      parameter(nT=11)
+
+      double precision kB
+      parameter(kB=1.3806488e-23)
+
+      double precision amagatS, amagatF, abcoefS, abcoefF, Nmolec
+      double precision wn_arr(nS)
+      double precision temp_arr(nT)
+      double precision abs_arrS(nS,nT)
+      double precision abs_arrF(nS,nT)
+      double precision data_tmp(nT)
+
+      integer k,ind
+      logical firstcall
+
+      save wn_arr, temp_arr, abs_arrS, abs_arrF
+
+      character*100 dt_file
+      integer strlen,ios
+
+      amagatS=(273.15/temp)*(presS/101325.0)
+      amagatF=(273.15/temp)*(presF/101325.0)
+
+      if(firstcall)then ! called by sugas_corrk only
+         print*,'----------------------------------------------------'
+         print*,'Initialising H2O continuum from MT_CKD data...'
+
+!     1.1 Open the ASCII files
+
+         ! nu array
+         dt_file=TRIM(datadir)//'/continuum_data/H2O_CONT_NU.dat'
+         open(33,file=dt_file,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from interpolateH2O_cont'
+           write(*,*) 'Data file ',trim(dt_file),' not found.'
+           write(*,*)'Check that your path to datagcm:',trim(datadir)
+           write(*,*)' is correct. You can change it in callphys.def with:'
+           write(*,*)' datadir = /absolute/path/to/datagcm'
+           write(*,*)' Also check that there is a continuum_data/H2O_CONT_NU.dat there.'
+           call abort
+         else
+            do k=1,nS
+               read(33,*) wn_arr(k)
+            enddo
+         endif
+         close(33)
+
+         ! self broadening
+         dt_file=TRIM(datadir)//'/continuum_data/H2O_CONT_SELF.dat'
+         open(34,file=dt_file,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from interpolateH2O_cont'
+           write(*,*) 'Data file ',trim(dt_file),' not found.'
+           write(*,*)'Check that your path to datagcm:',trim(datadir)
+           write(*,*)' is correct. You can change it in callphys.def with:'
+           write(*,*)' datadir = /absolute/path/to/datagcm'
+           write(*,*)' Also check that there is a continuum_data/H2O_CONT_SELF.dat there.'
+           call abort
+         else
+            do k=1,nS
+               read(34,*) data_tmp
+               abs_arrS(k,1:nT)=data_tmp(1:nT)
+            end do
+         endif
+         close(34)
+
+         ! foreign (N2+O2+Ar) broadening
+         dt_file=TRIM(datadir)//'/continuum_data/H2O_CONT_FOREIGN.dat'
+         open(35,file=dt_file,form='formatted',status='old',iostat=ios)
+         if (ios.ne.0) then        ! file not found
+           write(*,*) 'Error from interpolateH2O_cont'
+           write(*,*) 'Data file ',trim(dt_file),' not found.'
+           write(*,*)'Check that your path to datagcm:',trim(datadir)
+           write(*,*)' is correct. You can change it in callphys.def with:'
+           write(*,*)' datadir = /absolute/path/to/datagcm'
+           write(*,*)' Also check that there is a continuum_data/H2O_CONT_FOREIGN.dat there.'
+           call abort
+         else
+            do k=1,nS
+               read(35,*) data_tmp
+               abs_arrF(k,1:nT)=data_tmp(1:nT)
+            end do
+         endif
+         close(35)
+
+         temp_arr(1)  = 200.
+         temp_arr(2)  = 250.
+         temp_arr(3)  = 300.
+         temp_arr(4)  = 350.
+         temp_arr(5)  = 400.
+         temp_arr(6)  = 450.
+         temp_arr(7)  = 500.
+         temp_arr(8)  = 550.
+         temp_arr(9)  = 600.
+         temp_arr(10) = 650.
+         temp_arr(11) = 700.
+
+         print*,'interpolateH2Ocont: At wavenumber ',wn,' cm^-1'
+         print*,'   temperature ',temp,' K'
+         print*,'   H2O pressure ',presS,' Pa'
+         print*,'   air pressure ',presF,' Pa'
+	 
+      endif
+
+      call bilinearbig(nS,nT,wn_arr,temp_arr,abs_arrS,wn,temp,abcoefS,ind)
+!      print*,'the self absorption is ',abcoefS,' cm^2 molecule^-1'
+
+      call bilinearbig(nS,nT,wn_arr,temp_arr,abs_arrF,wn,temp,abcoefF,ind)
+!      print*,'the foreign absorption is ',abcoefF,' cm^2 molecule^-1'
+
+!      print*,'We have ',amagatS,' amagats of H2O vapour'
+!      print*,'and ',amagatF,' amagats of air'
+
+      abcoef = abcoefS*amagatS + abcoefF*amagatF ! Eq. (15) in Clough (1989)
+      abcoef = abcoef*(presS/(presF+presS))      ! take H2O mixing ratio into account
+                                                    ! abs coeffs are given per molecule of H2O
+
+      Nmolec = (presS+presF)/(kB*temp)           ! assume ideal gas
+!      print*,'Total number of molecules per m^3 is',Nmolec
+
+      abcoef = abcoef*Nmolec/(100.0**2)          ! convert to m^-1
+!      print*,'So the total absorption is ',abcoef,' m^-1'
+!      print*,'And optical depth / km : ',1000.0*abcoef
+
+
+      if(wn.gt.500 .and. wn.lt.1400)then
+      elseif(wn.gt.2100 .and. wn.lt.3000)then
+      else
+         abcoef = 0.0
+      endif
+
+      ! unlike for Rayleigh scattering, we do not currently weight by the BB function
+      ! however our bands are normally thin, so this is no big deal.
+
+
+      return
+    end subroutine interpolateH2Ocont_CKD
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2Ocont_PPC.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2Ocont_PPC.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateH2Ocont_PPC.F90	(revision 222)
@@ -0,0 +1,84 @@
+     subroutine interpolateH2Ocont_PPC(wn,temp,presS,presF,abcoef,firstcall)
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates the H2O continuum opacity, using the formulae
+!     provided in Pierrehumbert, PPC (2010). As this is based on
+!     the CKD continuum, it provides a useful check for the 
+!     implementation of the more general interpolateH2Ocont_CKD.F90.
+!
+!     Authors
+!     -------
+!     R. Wordsworth (2012)
+!     
+!==================================================================
+
+      use watercommon_h, only: mH2O
+      use datafile_mod, only: datadir
+      implicit none
+
+      ! input
+      double precision wn                 ! wavenumber             (cm^-1)
+      double precision temp               ! temperature            (Kelvin)
+      double precision presS              ! self-pressure          (Pascals)
+      double precision presF              ! foreign (air) pressure (Pascals)
+
+      ! parameters
+      double precision, parameter :: T0 = 296.0
+      double precision, parameter :: p0 = 1.D+4
+
+      ! variables
+      double precision rho_w, x
+
+      ! output
+      double precision abcoef             ! absorption coefficient (m^-1)
+
+      logical firstcall
+
+      x = wn - 2500.
+
+      if(firstcall)then ! called by sugas_corrk only
+         print*,'----------------------------------------------------'
+         print*,'Testing H2O continuum...'
+
+         print*,'interpolateH2Ocont: At wavenumber ',wn,' cm^-1'
+         print*,'   temperature ',temp,' K'
+         print*,'   H2O pressure ',presS,' Pa'
+
+         rho_w = presS/((8.31446/(mH2O/1000.))*temp)
+
+         if(wn.gt.500 .and. wn.lt.1400)then
+            abcoef = exp(12.167 - 0.050898*wn + 8.3207e-5*wn**2 - 7.0748e-8*wn**3 + 2.3261e-11*wn**4)*(T0/temp)**4.25*(presS/p0)
+         elseif(wn.gt.2100 .and. wn.lt.3000)then
+            abcoef = exp(-6.0055 - 0.0021363*x + 6.4723e-7*x**2 - 1.493e-8*x**3 + 2.5621e-11*x**4 + 7.328e-14*x**5)*(T0/temp)**4.25*(presS/p0)
+         else
+            abcoef = 0.0
+         endif
+         abcoef = abcoef*rho_w
+
+         print*,'The self absorption is ',abcoef,' m^-1'
+         print*,'And optical depth / km : ',1000.0*abcoef
+
+      else
+
+         rho_w = presS/((8.31446/(mH2O/1000.))*temp)
+
+         if(wn.gt.500 .and. wn.lt.1400)then
+            abcoef = exp(12.167 - 0.050898*wn + 8.3207e-5*wn**2 - 7.0748e-8*wn**3 + 2.3261e-11*wn**4)*(T0/temp)**4.25*(presS/p0)
+         elseif(wn.gt.2100 .and. wn.lt.3000)then
+            abcoef = exp(-6.0055 - 0.0021363*x + 6.4723e-7*x**2 - 1.493e-8*x**3 + 2.5621e-11*x**4 + 7.328e-14*x**5)*(T0/temp)**4.25*(presS/p0)
+         else
+            abcoef = 0.0
+         endif
+         abcoef = abcoef*rho_w
+
+         ! unlike for Rayleigh scattering, we do not currently weight by the BB function
+         ! however our bands are normally thin, so this is no big deal.
+
+      endif
+
+      return
+    end subroutine interpolateH2Ocont_PPC
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateN2H2.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateN2H2.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateN2H2.F90	(revision 222)
@@ -0,0 +1,130 @@
+subroutine interpolateN2H2(wn,temp,presN2,presH2,abcoef,firstcall,ind)
+
+  !==================================================================
+  !     
+  !     Purpose
+  !     -------
+  !     Calculates the N2-H2 CIA opacity, using a lookup table from
+  !     HITRAN (2011)
+  !
+  !     Authors
+  !     -------
+  !     R. Wordsworth (2011)
+  !     
+  !==================================================================
+
+  use datafile_mod, only: datadir
+  implicit none
+
+  ! input
+  double precision wn                 ! wavenumber             (cm^-1)
+  double precision temp               ! temperature            (Kelvin)
+  double precision presN2             ! N2 partial pressure    (Pascals)
+  double precision presH2             ! H2 partial pressure    (Pascals)
+
+  ! output
+  double precision abcoef             ! absorption coefficient (m^-1)
+
+  integer nS,nT
+  parameter(nS=1914)
+  parameter(nT=10)
+
+  double precision, parameter :: losch = 2.6867774e19
+  ! Loschmit's number (molecule cm^-3 at STP) 
+  ! converts cm^5 molecule^-2 --> cm^-1 amagat^-2
+  ! see Richard et al. 2011, JQSRT for details
+
+  double precision amagatN2
+  double precision amagatH2
+  double precision wn_arr(nS)
+  double precision temp_arr(nT)
+  double precision abs_arr(nS,nT)
+
+  integer k,iT
+  logical firstcall
+
+  save wn_arr, temp_arr, abs_arr
+
+  character*100 dt_file
+  integer strlen,ios
+
+  character(LEN=*), parameter :: fmat1 = "(A20,F10.3,F10.3,I7,F7.1,E10.3,F5.3)"
+
+  character*20 bleh
+  double precision blah, Ttemp
+  integer nres
+  integer ind
+
+  if(temp.gt.400)then
+     print*,'Your temperatures are too high for this N2-H2 CIA dataset.'
+     print*,'Please run mixed N2-H2 atmospheres below T = 400 K.'      
+     stop
+  endif
+
+  amagatN2 = (273.15/temp)*(presN2/101325.0)
+  amagatH2 = (273.15/temp)*(presH2/101325.0)
+
+  if(firstcall)then ! called by sugas_corrk only
+     print*,'----------------------------------------------------'
+     print*,'Initialising N2-H2 continuum from HITRAN database...'
+
+     !     1.1 Open the ASCII files
+     dt_file=TRIM(datadir)//'/continuum_data/N2-H2_2011.cia'
+
+     open(33,file=dt_file,form='formatted',status='old',iostat=ios)
+     if (ios.ne.0) then        ! file not found
+        write(*,*) 'Error from interpolateN2H2'
+        write(*,*) 'Data file ',trim(dt_file),' not found.'
+        write(*,*) 'Check that your path to datagcm:',trim(datadir)
+        write(*,*) 'is correct. You can change it in callphys.def with:'
+        write(*,*) 'datadir = /absolute/path/to/datagcm'
+        write(*,*) 'Also check that the continuum data continuum_data/N2-H2_2011.cia is there.'
+        call abort
+     else
+
+        do iT=1,nT
+
+           read(33,fmat1) bleh,blah,blah,nres,Ttemp
+           if(nS.ne.nres)then
+              print*,'Resolution given in file: ',trim(dt_file)
+              print*,'is ',nres,', which does not match nS.'
+              print*,'Please adjust nS value in interpolateN2H2.F90'
+              stop
+           endif
+           temp_arr(iT)=Ttemp
+
+           do k=1,nS
+              read(33,*) wn_arr(k),abs_arr(k,it)
+           end do
+
+        end do
+
+     endif
+     close(33)
+
+     print*,'interpolateN2H2: At wavenumber ',wn,' cm^-1'
+     print*,'   temperature                 ',temp,' K'
+     print*,'   N2 partial pressure         ',presN2,' Pa'
+     print*,'   and H2 partial pressure     ',presH2,' Pa'
+
+  endif
+
+  call bilinearbig(nS,nT,wn_arr,temp_arr,abs_arr,wn,temp,abcoef,ind)
+
+!     print*,'the absorption is ',abcoef,' cm^5 molecule^-2'
+!     print*,'or ',abcoef*losch**2,' cm^-1 amagat^-2'
+
+  abcoef=abcoef*losch**2*100.0*amagatN2*amagatH2 ! convert to m^-1
+
+!     print*,'We have ',amagatN2,' amagats of N2'
+!     print*,'and     ',amagatH2,' amagats of H2'
+!     print*,'So the absorption is ',abcoef,' m^-1'
+
+
+!  unlike for Rayleigh scattering, we do not currently weight by the BB function
+!  however our bands are normally thin, so this is no big deal.
+
+
+  return
+end subroutine interpolateN2H2
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateN2N2.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateN2N2.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/interpolateN2N2.F90	(revision 222)
@@ -0,0 +1,125 @@
+subroutine interpolateN2N2(wn,temp,pres,abcoef,firstcall,ind)
+
+  !==================================================================
+  !     
+  !     Purpose
+  !     -------
+  !     Calculates the N2-N2 CIA opacity, using a lookup table from
+  !     HITRAN (2011)
+  !
+  !     Authors
+  !     -------
+  !     R. Wordsworth (2011)
+  !     
+  !==================================================================
+
+  use datafile_mod, only: datadir
+  implicit none
+
+  ! input
+  double precision wn                 ! wavenumber             (cm^-1)
+  double precision temp               ! temperature            (Kelvin)
+  double precision pres               ! pressure               (Pascals)
+  integer :: ind
+
+  ! output
+  double precision abcoef             ! absorption coefficient (m^-1)
+
+  integer nS,nT
+  parameter(nS=582)
+  parameter(nT=10)
+
+  double precision, parameter :: losch = 2.6867774e19
+  ! Loschmit's number (molecule cm^-3 at STP) 
+  ! converts cm^5 molecule^-2 --> cm^-1 amagat^-2
+  ! see Richard et al. 2011, JQSRT for details
+
+  double precision amagat
+  double precision wn_arr(nS)
+  double precision temp_arr(nT)
+  double precision abs_arr(nS,nT)
+
+  integer k,iT
+  logical firstcall
+
+  save wn_arr, temp_arr, abs_arr
+
+  character*100 dt_file
+  integer strlen,ios
+
+  character(LEN=*), parameter :: fmat1 = "(A20,F10.3,F10.3,I7,F7.1,E10.3,F5.3)"
+
+  character*20 bleh
+  double precision blah, Ttemp
+  integer nres
+
+
+  if(temp.gt.400)then
+     print*,'Your temperatures are too high for this N2-N2 CIA dataset.'
+     print*,'Currently, HITRAN provides data for this pair in the range 40-400 K.'
+     stop
+  endif
+
+  amagat = (273.15/temp)*(pres/101325.0)
+
+  if(firstcall)then ! called by sugas_corrk only
+     print*,'----------------------------------------------------'
+     print*,'Initialising N2-N2 continuum from HITRAN database...'
+
+     !     1.1 Open the ASCII files
+     dt_file=TRIM(datadir)//'/continuum_data/N2-N2_2011.cia'
+
+     open(33,file=dt_file,form='formatted',status='old',iostat=ios)
+     if (ios.ne.0) then        ! file not found
+        write(*,*) 'Error from interpolateN2N2'
+        write(*,*) 'Data file ',trim(dt_file),' not found.'
+        write(*,*) 'Check that your path to datagcm:',trim(datadir)
+        write(*,*) 'is correct. You can change it in callphys.def with:'
+        write(*,*) 'datadir = /absolute/path/to/datagcm'
+        write(*,*) 'Also check that the continuum data continuum_data/N2-N2_norm_2011.cia is there.'
+        call abort
+     else
+
+        do iT=1,nT
+
+           read(33,fmat1) bleh,blah,blah,nres,Ttemp
+           if(nS.ne.nres)then
+              print*,'Resolution given in file: ',trim(dt_file)
+              print*,'is ',nres,', which does not match nS.'
+              print*,'Please adjust nS value in interpolateN2N2.F90'
+              stop
+           endif
+           temp_arr(iT)=Ttemp
+
+           do k=1,nS
+              read(33,*) wn_arr(k),abs_arr(k,it)
+           end do
+
+        end do
+
+     endif
+     close(33)
+
+     print*,'interpolateN2N2: At wavenumber ',wn,' cm^-1'
+     print*,'   temperature ',temp,' K'
+     print*,'   pressure ',pres,' Pa'
+
+  endif
+     call bilinearbig(nS,nT,wn_arr,temp_arr,abs_arr,wn,temp,abcoef,ind)
+
+!     print*,'the absorption is ',abcoef,' cm^5 molecule^-2'
+!     print*,'or ',abcoef*losch**2,' cm^-1 amagat^-2'
+
+     abcoef=abcoef*losch**2*100.0*amagat**2 ! convert to m^-1
+!     abcoef=0.
+
+!     print*,'We have ',amagat,' amagats of N2'
+!     print*,'So the absorption is ',abcoef,' m^-1'
+
+!     unlike for Rayleigh scattering, we do not currently weight by the BB function
+!     however our bands are normally thin, so this is no big deal.
+
+
+  return
+end subroutine interpolateN2N2
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iostart.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iostart.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/iostart.F90	(revision 222)
@@ -0,0 +1,1031 @@
+MODULE iostart
+
+    IMPLICIT NONE
+PRIVATE
+    INTEGER,SAVE :: nid_start ! NetCDF file identifier for startfi.nc file
+    INTEGER,SAVE :: nid_restart ! NetCDF file identifier for restartfi.nc file
+    
+    ! restartfi.nc file dimension identifiers: (see open_restartphy())
+    INTEGER,SAVE :: idim1 ! "index" dimension
+    INTEGER,SAVE :: idim2 ! "physical_points" dimension
+    INTEGER,SAVE :: idim3 ! "subsurface_layers" dimension
+    INTEGER,SAVE :: idim4 ! "nlayer_plus_1" dimension
+    INTEGER,SAVE :: idim5 ! "number_of_advected_fields" dimension
+    INTEGER,SAVE :: idim6 ! "nlayer" dimension
+    INTEGER,SAVE :: idim7 ! "Time" dimension
+    INTEGER,SAVE :: idim8 ! "ocean_layers" dimension
+    INTEGER,SAVE :: timeindex ! current time index (for time-dependent fields)
+    INTEGER,PARAMETER :: length=100 ! size of tab_cntrl array
+    
+    INTERFACE get_field
+      MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
+    END INTERFACE get_field
+    
+    INTERFACE get_var
+      MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
+    END INTERFACE get_var
+
+    INTERFACE put_field
+      MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
+    END INTERFACE put_field
+
+    INTERFACE put_var
+      MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
+    END INTERFACE put_var
+
+    PUBLIC nid_start, length
+    PUBLIC get_field,get_var,put_field,put_var
+    PUBLIC inquire_dimension, inquire_dimension_length
+    PUBLIC inquire_field, inquire_field_ndims
+    PUBLIC open_startphy,close_startphy,open_restartphy,close_restartphy
+    
+CONTAINS
+
+  SUBROUTINE open_startphy(filename)
+  USE netcdf, only: NF90_OPEN, NF90_NOERR, NF90_NOWRITE, nf90_strerror
+  USE mod_phys_lmdz_para, only: is_master, bcast
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: filename
+    INTEGER          :: ierr
+
+    IF (is_master) THEN
+      ierr = NF90_OPEN (filename, NF90_NOWRITE, nid_start)
+      IF (ierr.NE.NF90_NOERR) THEN
+        write(*,*)'open_startphy: problem opening file '//trim(filename)
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+    ENDIF
+    
+    CALL bcast(nid_start) ! tell all procs about nid_start
+  
+  END SUBROUTINE open_startphy
+
+  SUBROUTINE close_startphy
+  USE netcdf, only: NF90_CLOSE
+  USE mod_phys_lmdz_para, only: is_master
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_master) THEN
+        ierr = NF90_CLOSE (nid_start)
+    ENDIF
+
+  END SUBROUTINE close_startphy
+
+
+  FUNCTION inquire_field(Field_name)
+  ! check if a given field is present in the input file
+  USE netcdf, only: NF90_INQ_VARID, NF90_NOERR
+  USE mod_phys_lmdz_para, only: is_master, bcast
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: Field_name
+    LOGICAL :: inquire_field
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_master) THEN
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      IF (ierr==NF90_NOERR) THEN
+        Inquire_field=.TRUE.
+      ELSE
+        Inquire_field=.FALSE.
+      ENDIF
+    ENDIF
+
+    CALL bcast(inquire_field)
+
+  END FUNCTION inquire_field
+
+
+  FUNCTION inquire_field_ndims(Field_name)
+  ! give the number of dimensions of "Field_name" stored in the input file 
+  USE netcdf, only: nf90_inq_varid, nf90_inquire_variable, &
+                    NF90_NOERR, nf90_strerror
+  USE mod_phys_lmdz_para, only: is_master, bcast
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: Field_name
+    INTEGER :: inquire_field_ndims
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_master) THEN
+      ierr=nf90_inq_varid(nid_start,Field_name,varid)
+      ierr=nf90_inquire_variable(nid_start,varid,&
+                                  ndims=inquire_field_ndims)
+      IF (ierr.NE.NF90_NOERR) THEN
+        write(*,*)'inquire_field_ndims: problem obtaining ndims of '&
+                  //trim(field_name)
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+    ENDIF
+
+    CALL bcast(inquire_field_ndims)
+
+  END FUNCTION inquire_field_ndims
+
+
+  FUNCTION inquire_dimension(Field_name)
+  ! check if a given dimension is present in the input file
+  USE netcdf, only: nf90_inq_dimid, NF90_NOERR
+  USE mod_phys_lmdz_para, only: is_master, bcast
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: Field_name
+    LOGICAL :: inquire_dimension
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_master) THEN
+      ierr=NF90_INQ_DIMID(nid_start,Field_name,varid)
+      IF (ierr==NF90_NOERR) THEN
+        Inquire_dimension=.TRUE.
+      ELSE
+        Inquire_dimension=.FALSE.
+      ENDIF
+    ENDIF
+
+    CALL bcast(inquire_dimension)
+
+  END FUNCTION inquire_dimension
+
+  FUNCTION inquire_dimension_length(Field_name)
+  ! give the length of the "Field_name" dimension stored in the input file
+  USE netcdf, only: nf90_inquire_dimension, nf90_inq_dimid, &
+                    NF90_NOERR, nf90_strerror
+  USE mod_phys_lmdz_para, only: is_master, bcast
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: Field_name
+    INTEGER :: inquire_dimension_length
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_master) THEN
+      ierr=nf90_inq_dimid(nid_start,Field_name,varid)
+      ierr=nf90_inquire_dimension(nid_start,varid,&
+                                  len=inquire_dimension_length)
+      IF (ierr.NE.NF90_NOERR) THEN
+        write(*,*)'inquire_field_length: problem obtaining length of '&
+                  //trim(field_name)
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+    ENDIF
+
+    CALL bcast(inquire_dimension_length)
+
+  END FUNCTION inquire_dimension_length
+
+
+
+  SUBROUTINE Get_Field_r1(field_name,field,found,timeindex)
+  ! For a surface field
+  use mod_grid_phy_lmdz, only: klon_glo ! number of atmospheric columns (full grid)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+    INTEGER,INTENT(IN),OPTIONAL    :: timeindex ! time index of sought data
+
+    integer :: edges(4), corners(4)
+
+    edges(1)=klon_glo
+    edges(2:4)=1
+    corners(1:4)=1
+    if (PRESENT(timeindex)) then
+      corners(2)=timeindex
+    endif
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,1,corners,edges,found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,1,corners,edges)
+    ENDIF
+      
+  END SUBROUTINE Get_Field_r1
+  
+  SUBROUTINE Get_Field_r2(field_name,field,found,timeindex)
+  ! For a "3D" horizontal-vertical field
+  use mod_grid_phy_lmdz, only: klon_glo ! number of atmospheric columns (full grid)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+    INTEGER,INTENT(IN),OPTIONAL    :: timeindex ! time index of sought data
+
+    integer :: edges(4), corners(4)
+
+    edges(1)=klon_glo
+    edges(2)=size(field,2)
+    edges(3:4)=1
+    corners(1:4)=1
+    if (PRESENT(timeindex)) then
+      corners(3)=timeindex
+    endif
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,size(field,2),&
+                          corners,edges,found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,size(field,2),&
+                          corners,edges)
+    ENDIF
+
+      
+  END SUBROUTINE Get_Field_r2
+  
+  SUBROUTINE Get_Field_r3(field_name,field,found,timeindex)
+  ! for a "4D" field surf/alt/??
+  use mod_grid_phy_lmdz, only: klon_glo ! number of atmospheric columns (full grid)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+    INTEGER,INTENT(IN),OPTIONAL    :: timeindex ! time index of sought data
+
+    integer :: edges(4), corners(4)
+
+    edges(1)=klon_glo
+    edges(2)=size(field,2)
+    edges(3)=size(field,3)
+    edges(4)=1
+    corners(1:4)=1
+    if (PRESENT(timeindex)) then
+      corners(4)=timeindex
+    endif
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),&
+                          corners,edges,found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),&
+                          corners,edges)
+    ENDIF
+      
+  END SUBROUTINE Get_Field_r3
+  
+  SUBROUTINE Get_field_rgen(field_name,field,field_size, &
+                            corners,edges,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    INTEGER          :: field_size
+    REAL             :: field(klon,field_size)
+    INTEGER,INTENT(IN) :: corners(4)
+    INTEGER,INTENT(IN) :: edges(4)
+    LOGICAL,OPTIONAL :: found
+    
+    REAL    :: field_glo(klon_glo,field_size)
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_master) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        CALL body(field_glo)
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL scatter(field_glo,field)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'get_field_rgen: Field <'//field_name//'> not found'
+        CALL abort
+      ENDIF
+    ENDIF
+ 
+    
+    CONTAINS
+     
+     SUBROUTINE body(field_glo)
+       REAL :: field_glo(klon_glo*field_size)
+         ierr=NF90_GET_VAR(nid_start,varid,field_glo,corners,edges)
+         IF (ierr/=NF90_NOERR) THEN
+           ! La variable exist dans le fichier mais la lecture a echouee. 
+           PRINT*, 'get_field_rgen: Failed reading <'//field_name//'>'
+
+!           IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
+!              ! Essaye de lire le variable sur surface uniqument, comme fait avant
+!              field_glo(:)=0.
+!              ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
+!              IF (ierr/=NF90_NOERR) THEN
+!                 PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
+!                 CALL abort
+!              ELSE
+!                 PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
+!              END IF
+!           ELSE
+              CALL abort
+!           ENDIF
+         ENDIF
+
+     END SUBROUTINE body
+
+  END SUBROUTINE Get_field_rgen
+
+
+  SUBROUTINE get_var_r0(var_name,var,found)
+  ! Get a scalar from input file
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+
+    REAL                         :: varout(1)
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,varout,size(varout),found)
+    ELSE
+      CALL Get_var_rgen(var_name,varout,size(varout))
+    ENDIF
+    var=varout(1)
+ 
+  END SUBROUTINE get_var_r0
+
+  SUBROUTINE get_var_r1(var_name,var,found)
+  ! Get a vector from input file
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r1
+
+  SUBROUTINE get_var_r2(var_name,var,found)
+  ! Get a 2D field from input file
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(OUT)             :: var(:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r2
+
+  SUBROUTINE get_var_r3(var_name,var,found)
+  ! Get a 3D field frominput file
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:,:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r3
+
+  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: var_name
+    INTEGER          :: var_size
+    REAL             :: var(var_size)
+    LOGICAL,OPTIONAL :: found
+    
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        ierr=NF90_GET_VAR(nid_start,varid,var)
+        IF (ierr/=NF90_NOERR) THEN
+          PRINT*, 'phyetat0: Failed loading <'//trim(var_name)//'>'
+          CALL abort
+        ENDIF
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL bcast(var)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: Variable <'//trim(var_name)//'> not found'
+        CALL abort
+      ENDIF
+    ENDIF
+
+  END SUBROUTINE Get_var_rgen
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE open_restartphy(filename)
+  USE netcdf, only: NF90_CREATE, NF90_CLOBBER, NF90_64BIT_OFFSET, &
+                    NF90_NOERR, nf90_strerror, &
+                    NF90_PUT_ATT, NF90_GLOBAL, NF90_DEF_DIM, &
+                    NF90_UNLIMITED, NF90_ENDDEF, &
+                    NF90_WRITE, NF90_OPEN
+  USE mod_phys_lmdz_para, only: is_master
+  USE mod_grid_phy_lmdz, only: klon_glo
+  USE dimphy, only: klev, klevp1
+  USE infotrac, only: nqtot
+  USE comsoil_h, only: nsoilmx
+  USE slab_ice_h, only: noceanmx
+
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: filename
+    INTEGER                     :: ierr
+    LOGICAL,SAVE :: already_created=.false.
+    
+    IF (is_master) THEN
+      if (.not.already_created) then
+        ! At the very first call, create the file
+        ierr=NF90_CREATE(filename,IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), &
+                          nid_restart)
+        IF (ierr/=NF90_NOERR) THEN
+          write(*,*)'open_restartphy: problem creating file '//trim(filename)
+          write(*,*)trim(nf90_strerror(ierr))
+          CALL ABORT
+        ENDIF
+        already_created=.true.
+      else
+        ! Just open the file
+        ierr=NF90_OPEN(filename,NF90_WRITE,nid_restart)
+        IF (ierr/=NF90_NOERR) THEN
+          write(*,*)'open_restartphy: problem opening file '//trim(filename)
+          write(*,*)trim(nf90_strerror(ierr))
+          CALL ABORT
+        ENDIF
+        return
+      endif ! of if (.not.already_created)
+
+      ierr=NF90_PUT_ATT(nid_restart,NF90_GLOBAL,"title",&
+                        "Physics start file")
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem writing title '
+        write(*,*)trim(nf90_strerror(ierr))
+      ENDIF
+
+      ierr=NF90_DEF_DIM(nid_restart,"index",length,idim1)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining index dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+      
+      ierr=NF90_DEF_DIM(nid_restart,"physical_points",klon_glo,idim2)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining physical_points dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+      
+      ierr=NF90_DEF_DIM(nid_restart,"subsurface_layers",nsoilmx,idim3)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining subsurface_layers dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+      
+      ierr=NF90_DEF_DIM(nid_restart,"nlayer_plus_1",klevp1,idim4)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining nlayer_plus_1 dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+      
+      if (nqtot>0) then
+        ! only define a tracer dimension if there are tracers
+        ierr=NF90_DEF_DIM(nid_restart,"number_of_advected_fields",nqtot,idim5)
+        IF (ierr/=NF90_NOERR) THEN
+          write(*,*)'open_restartphy: problem defining number_of_advected_fields dimension '
+          write(*,*)trim(nf90_strerror(ierr))
+          CALL ABORT
+        ENDIF
+      endif
+
+      ierr=NF90_DEF_DIM(nid_restart,"nlayer",klev,idim6)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining nlayer dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+      
+      ierr=NF90_DEF_DIM(nid_restart,"Time",NF90_UNLIMITED,idim7)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining Time dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+
+      ierr=NF90_DEF_DIM(nid_restart,"ocean_layers",noceanmx,idim8)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem defining oceanic layer dimension '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+
+
+      ierr=NF90_ENDDEF(nid_restart)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'open_restartphy: problem ending definition mode '
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+    ENDIF
+
+  END SUBROUTINE open_restartphy
+
+  SUBROUTINE close_restartphy
+  USE netcdf, only: NF90_CLOSE
+  USE mod_phys_lmdz_para, only: is_master
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_master) THEN
+      ierr = NF90_CLOSE (nid_restart)
+    ENDIF
+ 
+  END SUBROUTINE close_restartphy
+
+  SUBROUTINE put_field_r1(field_name,title,field,time)
+  ! For a surface field
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:)
+  REAL,OPTIONAL,INTENT(IN)       :: time
+  
+  IF (present(time)) THEN
+    ! if timeindex is present, it is a time-dependent variable
+    CALL put_field_rgen(field_name,title,field,1,time)
+  ELSE
+    CALL put_field_rgen(field_name,title,field,1)
+  ENDIF
+  
+  END SUBROUTINE put_field_r1
+
+  SUBROUTINE put_field_r2(field_name,title,field,time)
+  ! For a "3D" horizontal-vertical field
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:)
+  REAL,OPTIONAL,INTENT(IN)       :: time
+  
+  IF (present(time)) THEN
+    ! if timeindex is present, it is a time-dependent variable
+    CALL put_field_rgen(field_name,title,field,size(field,2),time)
+  ELSE
+    CALL put_field_rgen(field_name,title,field,size(field,2))
+  ENDIF
+  
+  END SUBROUTINE put_field_r2
+
+  SUBROUTINE put_field_r3(field_name,title,field,time)
+  ! For a "4D" field surf/alt/??
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:,:)
+  REAL,OPTIONAL,INTENT(IN)       :: time
+  
+  IF (present(time)) THEN
+    ! if timeindex is present, it is a time-dependent variable
+    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3),&
+                        time)
+  ELSE  
+    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
+  ENDIF
+  
+  END SUBROUTINE put_field_r3
+  
+  SUBROUTINE put_field_rgen(field_name,title,field,field_size,time)
+  USE netcdf
+  USE dimphy
+  USE comsoil_h, only: nsoilmx
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE slab_ice_h, only: noceanmx
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  INTEGER,INTENT(IN)             :: field_size
+  REAL,INTENT(IN)                :: field(klon,field_size)
+  REAL,OPTIONAL,INTENT(IN)       :: time
+  
+  REAL                           :: field_glo(klon_glo,field_size)
+  INTEGER                        :: ierr
+  INTEGER                        :: nvarid
+  INTEGER                        :: idim
+   
+    CALL gather(field,field_glo)
+    
+    IF (is_master) THEN
+
+      IF (field_size==1) THEN
+        ! input is a 1D "surface field" array
+        if (.not.present(time)) then ! for a time-independent field
+          ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                            (/idim2/),nvarid)
+#else
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                            (/idim2/),nvarid)
+#endif
+          if (ierr.ne.NF90_NOERR) then
+            write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+            write(*,*)trim(nf90_strerror(ierr))
+          endif
+          IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+          ierr=NF90_ENDDEF(nid_restart)
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo)
+        else
+          ! check if the variable has already been defined:
+          ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
+          if (ierr/=NF90_NOERR) then ! variable not found, define it
+            ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                              (/idim2,idim7/),nvarid)
+#else
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                              (/idim2,idim7/),nvarid)
+#endif
+            if (ierr.ne.NF90_NOERR) then
+              write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+              write(*,*)trim(nf90_strerror(ierr))
+            endif
+            IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+            ierr=NF90_ENDDEF(nid_restart)
+          endif
+          ! Write the variable
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
+                            start=(/1,timeindex/))
+        endif ! of if (.not.present(timeindex))
+
+      ELSE IF (field_size==klev) THEN
+        ! input is a 2D "atmospheric field" array
+        if (.not.present(time)) then ! for a time-independent field
+          ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                            (/idim2,idim6/),nvarid)
+#else
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                            (/idim2,idim6/),nvarid)
+#endif
+          if (ierr.ne.NF90_NOERR) then
+            write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+            write(*,*)trim(nf90_strerror(ierr))
+          endif
+          IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+          ierr=NF90_ENDDEF(nid_restart)
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo)
+        else
+          ! check if the variable has already been defined:
+          ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
+          if (ierr/=NF90_NOERR) then ! variable not found, define it
+            ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                              (/idim2,idim6,idim7/),nvarid)
+#else
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                              (/idim2,idim6,idim7/),nvarid)
+#endif
+            if (ierr.ne.NF90_NOERR) then
+              write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+              write(*,*)trim(nf90_strerror(ierr))
+            endif
+            IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+            ierr=NF90_ENDDEF(nid_restart)
+          endif
+          ! Write the variable
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
+                            start=(/1,1,timeindex/))
+        endif ! of if (.not.present(time))
+
+      ELSE IF (field_size==klevp1) THEN
+        ! input is a 2D "interlayer atmospheric field" array
+        if (.not.present(time)) then ! for a time-independent field
+          ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                            (/idim2,idim4/),nvarid)
+#else
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                            (/idim2,idim4/),nvarid)
+#endif
+          if (ierr.ne.NF90_NOERR) then
+            write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+            write(*,*)trim(nf90_strerror(ierr))
+          endif
+          IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+          ierr = NF90_ENDDEF(nid_restart)
+          ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
+        else
+          ! check if the variable has already been defined:
+          ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
+          if (ierr/=NF90_NOERR) then ! variable not found, define it
+            ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                              (/idim2,idim4,idim7/),nvarid)
+#else
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                              (/idim2,idim4,idim7/),nvarid)
+#endif
+            if (ierr.ne.NF90_NOERR) then
+              write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+              write(*,*)trim(nf90_strerror(ierr))
+            endif
+            IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+            ierr=NF90_ENDDEF(nid_restart)
+          endif
+          ! Write the variable
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
+                            start=(/1,1,timeindex/))
+        endif ! of if (.not.present(timeindex))
+
+      ELSE IF (field_size==nsoilmx) THEN
+        ! input is a 2D "subsurface field" array
+        if (.not.present(time)) then ! for a time-independent field
+          ierr = NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                            (/idim2,idim3/),nvarid)
+#else
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                            (/idim2,idim3/),nvarid)
+#endif
+          if (ierr.ne.NF90_NOERR) then
+            write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+            write(*,*)trim(nf90_strerror(ierr))
+          endif
+          IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+          ierr = NF90_ENDDEF(nid_restart)
+          ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
+        else
+          ! check if the variable has already been defined:
+          ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
+          if (ierr/=NF90_NOERR) then ! variable not found, define it
+            ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                              (/idim2,idim3,idim7/),nvarid)
+#else
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                              (/idim2,idim3,idim7/),nvarid)
+#endif
+           if (ierr.ne.NF90_NOERR) then
+              write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+              write(*,*)trim(nf90_strerror(ierr))
+            endif
+            IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+            ierr=NF90_ENDDEF(nid_restart)
+          endif
+          ! Write the variable
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
+                            start=(/1,1,timeindex/))
+
+        endif ! of if (.not.present(time))
+
+      ELSE IF (field_size==noceanmx) THEN
+        ! input is a 2D "oceanic field" array
+        if (.not.present(time)) then ! for a time-independent field
+          ierr = NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                            (/idim2,idim8/),nvarid)
+#else
+          ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                            (/idim2,idim8/),nvarid)
+#endif
+          if (ierr.ne.NF90_NOERR) then
+            write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+            write(*,*)trim(nf90_strerror(ierr))
+          endif
+          IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+          ierr = NF90_ENDDEF(nid_restart)
+          ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
+        else
+          ! check if the variable has already been defined:
+          ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
+          if (ierr/=NF90_NOERR) then ! variable not found, define it
+            ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
+                              (/idim2,idim8,idim7/),nvarid)
+#else
+            ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
+                              (/idim2,idim8,idim7/),nvarid)
+#endif
+           if (ierr.ne.NF90_NOERR) then
+              write(*,*)"put_field_rgen error: failed to define "//trim(field_name)
+              write(*,*)trim(nf90_strerror(ierr))
+            endif
+            IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+            ierr=NF90_ENDDEF(nid_restart)
+          endif
+          ! Write the variable
+          ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
+                            start=(/1,1,timeindex/))
+
+        endif ! of if (.not.present(time))
+
+
+      ELSE
+        PRINT *, "Error phyredem(put_field_rgen) : wrong dimension for ",trim(field_name)
+        write(*,*) "  field_size =",field_size
+        CALL ABORT
+      ENDIF
+
+      ! Check the writting of field to file went OK
+      if (ierr.ne.NF90_NOERR) then
+        write(*,*) " Error phyredem(put_field_rgen) : failed writing ",trim(field_name)
+        write(*,*)trim(nf90_strerror(ierr))
+        call abort
+      endif
+
+    ENDIF ! of IF (is_master)
+    
+  END SUBROUTINE put_field_rgen  
+  
+  SUBROUTINE put_var_r0(var_name,title,var)
+  ! Put a scalar in file
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var
+     REAL                        :: varin(1)
+     
+     varin(1)=var
+     
+     CALL put_var_rgen(var_name,title,varin,size(varin))
+
+  END SUBROUTINE put_var_r0
+
+
+  SUBROUTINE put_var_r1(var_name,title,var)
+  ! Put a vector in file
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r1
+ 
+  SUBROUTINE put_var_r2(var_name,title,var)
+  ! Put a 2D field in file
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r2     
+  
+  SUBROUTINE put_var_r3(var_name,title,var)
+  ! Put a 3D field in file
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:,:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r3
+
+  SUBROUTINE put_var_rgen(var_name,title,var,var_size)
+  USE netcdf, only: NF90_REDEF, NF90_DEF_VAR, NF90_ENDDEF, NF90_PUT_VAR, &
+                    NF90_FLOAT, NF90_DOUBLE, &
+                    NF90_PUT_ATT, NF90_NOERR, nf90_strerror, &
+                    nf90_inq_dimid, nf90_inquire_dimension, NF90_INQ_VARID
+  USE comsoil_h, only: nsoilmx
+  USE mod_phys_lmdz_para, only: is_master
+  USE slab_ice_h, only: noceanmx
+  IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     INTEGER,INTENT(IN)          :: var_size
+     REAL,INTENT(IN)             :: var(var_size)
+     
+     INTEGER :: ierr
+     INTEGER :: nvarid
+     INTEGER :: idim1d
+     logical,save :: firsttime=.true.
+         
+    IF (is_master) THEN
+
+      IF (var_name=="Time") THEN
+        ! Very specific case of "Time" variable
+        if (firsttime) then
+          ! Create the "Time variable"
+          ierr=NF90_REDEF(nid_restart)
+#ifdef NC_DOUBLE
+          ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_DOUBLE,&
+                            (/idim7/),nvarid)
+#else
+          ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_FLOAT,&
+                            (/idim7/),nvarid)
+#endif
+          IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+          ierr=NF90_ENDDEF(nid_restart)
+          
+          firsttime=.false.
+        endif
+        ! Append "time" value
+        ! get current length of "Time" dimension
+        ierr=nf90_inq_dimid(nid_restart,var_name,idim1d)
+        ierr=nf90_inquire_dimension(nid_restart,idim1d,len=timeindex)
+        timeindex=timeindex+1
+        ierr=NF90_INQ_VARID(nid_restart,var_name,nvarid)
+        ierr=NF90_PUT_VAR(nid_restart,nvarid,var,&
+                           start=(/timeindex/))
+        IF (ierr/=NF90_NOERR) THEN
+          write(*,*)'put_var_rgen: problem writing Time'
+          write(*,*)trim(nf90_strerror(ierr))
+          CALL ABORT
+        ENDIF
+        return ! nothing left to do
+      ELSEIF (var_size==length) THEN
+        ! We know it is a "controle" kind of 1D array
+        idim1d=idim1
+      ELSEIF (var_size==nsoilmx) THEN
+        ! We know it is an  "mlayer" kind of 1D array
+        idim1d=idim3
+      ELSEIF (var_size==noceanmx) THEN
+        ! We know it is an  "mlayer" kind of 1D array
+        idim1d=idim8
+      ELSE 
+        PRINT *, "put_var_rgen error : wrong dimension"
+        write(*,*) "  var_size =",var_size
+        CALL abort
+
+      ENDIF ! of IF (var_size==length) THEN
+
+      ! Swich to NetCDF define mode
+      ierr=NF90_REDEF (nid_restart)
+      ! Define the variable
+#ifdef NC_DOUBLE
+      ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_DOUBLE,(/idim1d/),nvarid)
+#else
+      ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_FLOAT,(/idim1d/),nvarid)
+#endif
+      ! Add a "title" attribute
+      IF (LEN_TRIM(title)>0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
+      ! Swich out of define mode
+      ierr=NF90_ENDDEF(nid_restart)
+      ! Write variable to file
+      ierr=NF90_PUT_VAR(nid_restart,nvarid,var)
+      IF (ierr/=NF90_NOERR) THEN
+        write(*,*)'put_var_rgen: problem writing '//trim(var_name)
+        write(*,*)trim(nf90_strerror(ierr))
+        CALL ABORT
+      ENDIF
+    ENDIF ! of IF (is_master)
+    
+  END SUBROUTINE put_var_rgen     
+
+END MODULE iostart
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/kcm1d.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/kcm1d.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/kcm1d.F90	(revision 222)
@@ -0,0 +1,375 @@
+program kcm1d
+
+  use infotrac, only: nqtot
+  use radinc_h,      only: NAERKIND
+  use radcommon_h,   only: L_NSPECTI, L_NSPECTV, sigma
+  use watercommon_h, only: mH2O
+  use ioipsl_getincom, only: getin
+  use comsaison_h, only: mu0, fract, dist_star
+!  use control_mod
+
+  implicit none
+
+  !==================================================================
+  !     
+  !     Purpose
+  !     -------
+  !     Run the universal model radiative transfer once in a 1D column.
+  !     Useful for climate evolution studies etc.
+  !     
+  !     It can be compiled with a command like (e.g. for 25 layers):
+  !                                  "makegcm -p std -d 25 kcm1d"
+  !     It requires the files "callphys.def", "gases.def"
+  !     "traceur.def", and "run.def" with a line "INCLUDEDEF=callphys.def"
+  !
+  !     Authors
+  !     -------
+  !     R. Wordsworth
+  !
+  !==================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "planete.h"
+!#include "control.h"
+
+  ! --------------------------------------------------------------
+  !  Declarations
+  ! --------------------------------------------------------------
+
+  integer nlayer,nlevel,nq
+  integer ilay,ilev,iq,iw,iter
+  real play(nlayermx)     ! Pressure at the middle of the layers [Pa]
+  real zlay(nlayermx)     ! Altitude at middle of the layers [km]
+  real plev(nlayermx+1)   ! Intermediate pressure levels [Pa]
+  real temp(nlayermx)     ! temperature at the middle of the layers [K]
+  real,allocatable :: q(:,:)   ! tracer mixing ratio [kg/kg]
+  real,allocatable :: vmr(:,:) ! tracer mixing ratio [mol/mol]
+  real,allocatable :: qsurf(:)        ! tracer surface budget [kg/kg] ????
+  real psurf,psurf_n,tsurf      
+
+  real emis, albedo
+
+  real muvar(nlayermx+1)
+
+  real dtsw(nlayermx) ! heating rate (K/s) due to SW
+  real dtlw(nlayermx) ! heating rate (K/s) due to LW
+  real fluxsurf_lw   ! incident LW flux to surf (W/m2)
+  real fluxtop_lw    ! outgoing LW flux to space (W/m2)
+  real fluxsurf_sw   ! incident SW flux to surf (W/m2)
+  real fluxabs_sw    ! SW flux absorbed by planet (W/m2)
+  real fluxtop_dn    ! incident top of atmosphere SW flux (W/m2)
+
+  ! not used
+  real reffrad(nlayermx,naerkind)
+  real nueffrad(nlayermx,naerkind)
+  real cloudfrac(nlayermx)
+  real totcloudfrac
+  real tau_col
+
+  real dTstrat
+  real aerosol(nlayermx,naerkind) ! aerosol tau (kg/kg)
+  real OLR_nu(1,L_NSPECTI)
+  real OSR_nu(1,L_NSPECTV)
+  real Eatmtot
+
+  integer ierr
+  logical firstcall,lastcall,global1d
+
+  character*20,allocatable :: nametrac(:)   ! name of the tracer (no need for adv trac common)
+
+  ! --------------
+  ! Initialisation
+  ! --------------
+
+  pi=2.E+0*asin(1.E+0)
+
+  reffrad(:,:)  = 0.0
+  nueffrad(:,:) = 0.0
+  cloudfrac(:)  = 0.0
+  totcloudfrac  = 0.0
+
+
+  nlayer=nlayermx
+  nlevel=nlayer+1
+
+  !! this is defined in comsaison_h
+  ALLOCATE(mu0(1))
+  ALLOCATE(fract(1))
+
+
+
+  !  Load parameters from "run.def" 
+  ! -------------------------------
+
+  ! check if 'kcm1d.def' file is around (otherwise reading parameters
+  ! from callphys.def via getin() routine won't work.)
+  open(90,file='kcm1d.def',status='old',form='formatted',&
+       iostat=ierr)
+  if (ierr.ne.0) then
+     write(*,*) 'Cannot find required file "kcm1d.def"'
+     write(*,*) '  (which should contain some input parameters'
+     write(*,*) '   along with the following line:'
+     write(*,*) '   INCLUDEDEF=callphys.def'
+     write(*,*) '   )'
+     write(*,*) ' ... might as well stop here ...'
+     stop
+  else
+     close(90)
+  endif
+
+! now, run.def is needed anyway. so we create a dummy temporary one
+! for ioipsl to work. if a run.def is already here, stop the
+! program and ask the user to do a bit of cleaning
+  open(90,file='run.def',status='old',form='formatted',& 
+       iostat=ierr)
+  if (ierr.eq.0) then
+     close(90)
+     write(*,*) 'There is already a run.def file.'
+     write(*,*) 'This is not compatible with 1D runs.'
+     write(*,*) 'Please remove the file and restart the run.'
+     write(*,*) 'Runtime parameters are supposed to be in kcm1d.def'
+     stop
+  else
+     call system('touch run.def')
+     call system("echo 'INCLUDEDEF=callphys.def' >> run.def")
+     call system("echo 'INCLUDEDEF=kcm1d.def' >> run.def")
+  endif
+
+  global1d = .false. ! default value
+  call getin("global1d",global1d)
+  if(.not.global1d)then
+     print*,'Error, kcm1d must have global1d=.true. in kcm1d.def!'
+     stop
+  end if
+
+  psurf_n=100000. ! default value for psurf
+  print*,'Dry surface pressure (Pa)?'
+  call getin("psurf",psurf_n)
+  write(*,*) " psurf = ",psurf_n
+
+! OK. now that run.def has been read once -- any variable is in memory.
+! so we can dump the dummy run.def
+  call system("rm -rf run.def")
+
+  tsurf=300.0 ! default value for tsurf
+  print*,'Surface temperature (K)?'
+  call getin("tref",tsurf)
+  write(*,*) " tsurf = ",tsurf
+
+  g=10.0 ! default value for g
+  print*,'Gravity ?'
+  call getin("g",g)
+  write(*,*) " g = ",g
+
+  periastr = 1.0
+  apoastr  = 1.0
+  print*,'Periastron (AU)?'
+  call getin("periastr",periastr)
+  write(*,*) "periastron = ",periastr
+  dist_star = periastr 
+  fract     = 0.5
+  print*,'Apoastron (AU)?'
+  call getin("apoastr",apoastr)
+  write(*,*) "apoastron = ",apoastr
+
+  albedo=0.2 ! default value for albedo
+  print*,'Albedo of bare ground?'
+  call getin("albedo",albedo)
+  write(*,*) " albedo = ",albedo
+
+  emis=1.0 ! default value for emissivity
+  PRINT *,'Emissivity of bare ground ?'
+  call getin("emis",emis)
+  write(*,*) " emis = ",emis
+
+  pceil=100.0 ! Pascals
+  PRINT *,'Ceiling pressure (Pa) ?'
+  call getin("pceil",pceil)
+  write(*,*) " pceil = ", pceil
+
+  mugaz=0.
+  cpp=0.
+
+  check_cpp_match = .false.
+  call getin("check_cpp_match",check_cpp_match)
+  if (check_cpp_match) then
+     print*,"In 1D modeling, check_cpp_match is supposed to be F"
+     print*,"Please correct callphys.def"
+     stop
+  endif
+
+  call su_gases
+  call calc_cpp_mugaz
+
+  call inifis(1,llm,0,86400.0,1.0,0.0,0.0,1.0,rad,g,r,cpp)
+
+  ! Tracer initialisation
+  ! ---------------------
+  if (tracer) then
+     ! load tracer names from file 'traceur.def'
+     open(90,file='traceur.def',status='old',form='formatted',&
+          iostat=ierr)
+     if (ierr.eq.0) then
+        write(*,*) "kcm1d: Reading file traceur.def"
+        ! read number of tracers:
+        read(90,*,iostat=ierr) nq
+        if (ierr.ne.0) then
+           write(*,*) "kcm1d: error reading number of tracers"
+           write(*,*) "   (first line of traceur.def) "
+           stop
+        endif
+        nqtot=nq
+        ! allocate arrays which depend on number of tracers
+        allocate(nametrac(nq))
+        allocate(q(nlayermx,nq))
+        allocate(vmr(nlayermx,nq))
+        allocate(qsurf(nq))
+
+        do iq=1,nq
+           ! minimal version, just read in the tracer names, 1 per line
+           read(90,*,iostat=ierr) nametrac(iq)
+           if (ierr.ne.0) then
+              write(*,*) 'kcm1d: error reading tracer names...'
+              stop
+           endif
+        enddo !of do iq=1,nq
+     endif
+
+     call initracer(1,nq,nametrac)
+
+  endif
+
+
+  do iq=1,nq
+     do ilay=1,nlayer
+        q(ilay,iq) = 0.
+     enddo
+  enddo
+
+  do iq=1,nq
+     qsurf(iq) = 0.
+  enddo
+
+  firstcall = .true.
+  lastcall  = .false.
+
+  iter    = 1
+  Tstrat  = 150.0
+  dTstrat = 1000.0
+
+  ! ---------
+  ! Run model
+  ! ---------
+  !do
+     psurf = psurf_n
+
+     !    Create vertical profiles
+     call kcmprof_fn(psurf,qsurf(1),tsurf,    &
+          tstrat,play,plev,zlay,temp,q(:,1),muvar(1))
+
+     !    Run radiative transfer
+     call callcorrk(1,nlayer,q,nq,qsurf,      &
+          albedo,emis,mu0,plev,play,temp,                    &
+          tsurf,fract,dist_star,aerosol,muvar,         &
+          dtlw,dtsw,fluxsurf_lw,fluxsurf_sw,fluxtop_lw,    &
+          fluxabs_sw,fluxtop_dn,OLR_nu,OSR_nu,reffrad,nueffrad,tau_col,  &
+          cloudfrac,totcloudfrac,.false.,firstcall,lastcall)
+
+     !    Iterate stratospheric temperature
+     print*,'Tstrat = ',Tstrat
+     dTstrat = Tstrat
+     !Tstrat  = Tsurf*(0.2786*(psurf/100000.)**(-1.123))**0.25 
+     ! skin temperature (gray approx.) using analytic pure H2 expression
+     !Tstrat  = (fluxabs_sw/(2*sigma))**0.25 ! skin temperature (gray approx.)
+     Tstrat  = (fluxtop_lw/(2*sigma))**0.25 ! skin temperature (gray approx.)
+     dTstrat = dTstrat-Tstrat
+
+     !if(abs(dTstrat).lt.1.0)then
+     !   print*,'dTstrat = ',dTstrat
+     !   exit
+     !endif
+
+     !iter=iter+1
+     !if(iter.eq.100)then
+     !   print*,'Stratosphere failed to converge after'
+     !   print*,'100 iteration, aborting run.'
+     !   call abort
+     !endif
+
+  !end do
+
+  ! Run radiative transfer one last time to get OLR,OSR
+  firstcall=.false.
+  lastcall=.true.
+  call callcorrk(1,nlayer,q,nq,qsurf,      &
+       albedo,emis,mu0,plev,play,temp,                    &
+       tsurf,fract,dist_star,aerosol,muvar,         &
+       dtlw,dtsw,fluxsurf_lw,fluxsurf_sw,fluxtop_lw,    &
+       fluxabs_sw,fluxtop_dn,OLR_nu,OSR_nu,             &
+       reffrad,nueffrad,tau_col,  &
+       cloudfrac,totcloudfrac,.false.,firstcall,lastcall)
+
+
+  ! Calculate total atmospheric energy
+  Eatmtot=0.0
+  !  call calcenergy_kcm(tsurf,temp,play,plev,qsurf,&
+  !     q(:,1),muvar,Eatmtot)
+
+  ! ------------------------
+  ! Save data to ascii files
+  ! ------------------------
+
+  print*,'Saving profiles...'
+  open(115,file='profpres.out',form='formatted')
+  open(116,file='proftemp.out',form='formatted')
+  open(117,file='profztab.out',form='formatted')
+  open(118,file='profqvar.out',form='formatted')
+  open(119,file='profvvar.out',form='formatted')
+
+  write(115,*) psurf
+  write(116,*) tsurf
+  write(117,*) 0.0
+  write(118,*) qsurf(1)
+  write(119,*) qsurf(1)*(muvar(1)/mH2O)
+  do ilay=1,nlayer
+     vmr(ilay,1) = q(ilay,1)*(muvar(ilay+1)/mH2O)
+     write(115,*) play(ilay)
+     write(116,*) temp(ilay)
+     write(117,*) zlay(ilay)
+     write(118,*) q(ilay,1)
+     write(119,*) vmr(ilay,1)
+  enddo
+  close(115)
+  close(116)
+  close(117)
+  close(118)
+  close(119)
+
+  print*, tsurf,psurf,fluxtop_dn,fluxabs_sw,fluxtop_lw 
+
+  print*,'Saving scalars...'
+  open(116,file='surf_vals.out')
+  write(116,*) tsurf,psurf,fluxtop_dn,         &
+       fluxabs_sw,fluxtop_lw 
+  close(116)
+  open(111,file='ene_vals.out')
+  write(111,*) tsurf,psurf,Eatmtot,Tstrat
+  close(111)
+
+  print*,'Saving spectra...'
+  open(117,file='OLRnu.out')
+  do iw=1,L_NSPECTI
+     write(117,*) OLR_nu(1,iw)
+  enddo
+  close(117)
+
+  open(127,file='OSRnu.out')
+  do iw=1,L_NSPECTV
+     write(127,*) OSR_nu(1,iw)
+  enddo
+  close(127)  
+
+end program kcm1d
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/kcmprof_fn.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/kcmprof_fn.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/kcmprof_fn.F90	(revision 222)
@@ -0,0 +1,391 @@
+subroutine kcmprof_fn(psurf_rcm,qsurf_rcm,Tsurf_rcm,Tstra_rcm,P_rcm,Pl_rcm,z_rcm,T_rcm,q_rcm,m_rcm)
+
+use params_h
+use watercommon_h, only : mH2O
+use gases_h
+implicit none
+
+!     ----------------------------------------------------------------
+!     Purpose: create profiles of T, rho_v, rho_n, Pv and Pn following 
+!              Kasting 1988
+!     Authour: Adapted from a code by E. Marcq by R. Wordsworth (2011)
+!     ----------------------------------------------------------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+  integer ilay, nlay
+  parameter (nlay=10000) ! number of vertical layers
+
+  ! rcm inputs
+  real Tsurf_rcm,Tstra_rcm
+
+  ! rcm outputs
+  real psurf_rcm,qsurf_rcm
+  real P_rcm(1:nlayermx)
+  real Pl_rcm(1:nlayermx+1)
+  real z_rcm(1:nlayermx)
+  real T_rcm(1:nlayermx),q_rcm(1:nlayermx)
+  real m_rcm(1:nlayermx+1)
+
+  ! rcm for interpolation (should really use log coords?)
+  !double precision p1,p2,pnew,ilay_rcm
+
+  double precision lnp1,lnp2,lnpnew
+  real Dp_rcm, dlogp_rcm
+  integer ilay_rcm,ilev_rcm,ifinal_rcm
+
+  double precision Dz, Dp
+  double precision Ptop, dlogp, Psat_max
+  parameter (Ptop=1.0)                             ! Pressure at TOA [Pa]
+
+  double precision T(1:nlay)                       ! temperature [K]
+  double precision Ztab(1:nlay)                    ! altitude [m]
+  double precision Pv(1:nlay),Pn(1:nlay),P(1:nlay) ! pressure [Pa]
+  double precision rho_v(1:nlay), rho_n(1:nlay)    ! density [kg m^-3]
+  double precision a_v(1:nlay)                     ! = rho_v/rho_n [kg/kg]
+  double precision q_v(1:nlay)                     ! = rho_v/rho_tot [kg/kg]
+  double precision mtot(1:nlay)                    ! = (rho_v+rho_n)/(n_v+n_n) [g/mol]
+
+  integer profil_flag(1:nlay) ! 0 = dry, 1 = moist, 2 = isothermal
+
+  ! inputs
+  double precision Tsurf   ! surface temperature [K]
+  double precision Psurf_v ! surface par. pressure (variable species) [Pa]
+  double precision Psurf_n ! surface par. pressure (incondensible species)[Pa]
+  double precision Ttop    ! stratospheric temperature [K]
+
+  double precision dTdp        ! [K/Pa]
+  double precision dPvdp,dPndp ! [Pa/Pa]
+  double precision psat_v      ! local Psat_H2O value
+  double precision Tcrit       ! Critical temperature [K]
+  double precision rho_vTEMP,rho_nTEMP
+
+  double precision TCO2cond ! for CO2 condensation quasi-hack
+
+  ! variables necessary for steam.f90
+  double precision rhol,rhov,nul
+
+  ! for output
+  double precision vmr
+
+  logical verbose
+  parameter(verbose=.true.)
+
+  logical add_Pvar_to_total
+  parameter(add_Pvar_to_total=.true.)
+
+  ! initialise flags
+  profil_flag(:) = 0
+
+  !-------------------------------
+  ! assign input variables
+  m_n     = dble(mugaz/1000.)
+  cp_n    = cpp
+  ! modify/generalise later??
+
+  Psat_max = 1000000.0 ! maximum vapour pressure [Pa]
+                       ! set huge until further notice 
+
+  if(vgas.lt.1)then
+     if(psat_max.gt.0.0)then
+        print*,'Must have Psat_max=0 if no variable species'
+        psat_max=0.0
+        !stop
+     endif
+     print*, 'Assuming pure atmosphere'
+     m_v   = 1.0
+     tcrit = 1000.0
+  elseif(trim(gnom(vgas)).eq.'H2O')then
+     m_v   = dble(mH2O/1000.)
+     tcrit = 6.47d2
+  elseif(trim(gnom(vgas)).eq.'NH3')then
+     m_v   = 17.031/1000.
+     tcrit = 4.06d2
+  elseif(trim(gnom(vgas)).eq.'CH4')then
+     m_v   = 16.04/1000.
+     tcrit = 1.91d2
+     stop
+  else
+     print*,'Variable gas not recognised!'
+     call abort
+  endif
+
+  rmn     = rc/m_n
+  Ttop    = dble(Tstra_rcm)
+  Tsurf   = dble(Tsurf_rcm)
+
+  psat_v  = psat_max
+  if(vgas.gt.0)then
+     if(trim(gnom(vgas)).eq.'H2O')then
+        call Psat_H2O(tsurf,psat_v)
+     elseif(trim(gnom(vgas)).eq.'NH3')then
+        call Psat_NH3(tsurf,psat_v)
+     endif
+  endif
+
+  ! Moist adiabat unless greater than or equal to psat_max
+  if(psat_v*1d6.lt.psat_max)then
+    Psurf_v = Psat_v*1d6
+    profil_flag(1) = 1
+  else 
+    Psurf_v = psat_max
+    profil_flag(1) = 0
+  endif
+
+  if(add_Pvar_to_total)then
+    Psurf_n = dble(psurf_rcm)
+    psurf_rcm = real(Psurf_n+Psurf_v)
+  else
+    Psurf_n = dble(psurf_rcm) - Psurf_v
+  endif
+
+  ! include relative humidity option
+  !if(satval.lt.1.0)then
+  !   Psurf_v = Psurf_v*satval
+  !   profil_flag(1) = 0     
+  !endif
+
+  if(verbose)then
+     print*,'Psat_v  =',psat_v*1d6
+     print*,'Tsurf   =',Tsurf,' K'
+     print*,'Ttop    =',Ttop,' K'
+     print*,'Psurf_v =',Psurf_v,' Pa'
+     print*,'Psurf_n =',Psurf_n,' Pa'
+     print*,'m_n     =',m_n,' kg/mol'
+     print*,'m_v     =',m_v,' kg/mol'
+     print*,'rc      =',rc
+  endif
+
+  ! define fine pressure grid
+  dlogp_rcm = -(log(psurf_rcm)-log(ptop))/nlayermx
+
+  P_rcm(1)  = psurf_rcm*exp(dlogp_rcm)
+  do ilay_rcm=1,nlayermx-1
+     P_rcm(ilay_rcm+1) = P_rcm(ilay_rcm)*exp(dlogp_rcm)
+  enddo
+
+  Pl_rcm(1) = psurf_rcm
+  do ilev_rcm=2,nlayermx
+     ! log-linear interpolation
+     Pl_rcm(ilev_rcm) = exp( log( P_rcm(ilev_rcm)*P_rcm(ilev_rcm-1) )/2 )
+  enddo
+
+  !-------------------------------
+  ! Layer 1
+  T(1)     = Tsurf
+  Pv(1)    = Psurf_v
+  Pn(1)    = Psurf_n
+  rho_n(1) = m_n*Pn(1)/(Rc*Tsurf)
+  rho_v(1) = m_v*Pv(1)/(Rc*Tsurf)
+  a_v(1)   = rho_v(1)/rho_n(1)
+
+  ! log pressure grid spacing (constant)
+  dlogp = -(log(Pn(1)+Pv(1))-log(ptop))/(nlay-1)
+
+  call gradients_kcm(profil_flag(1),rho_v(1),rho_n(1),Tsurf,dTdp,dPvdp,dPndp)
+  if(verbose)then
+     print*, 'dT/dp ground [K/Pa] =',dTdp
+  endif
+
+  ! initial delta p, delta z
+  Dp = (Pn(1) + Pv(1))*(exp(dlogp) - 1d0)
+  Dz = -Dp/(  g*(rho_n(1) + rho_v(1))  )
+
+  !-------------------------------
+  ! Layer 2
+  T(2)     = tsurf + dTdp*Dp 
+  Pv(2)    = Pv(1) + dPvdp*Dp
+  Pn(2)    = Pn(1) + dPndp*Dp
+  rho_n(2) = m_n*Pn(2)/(Rc*T(2))
+  rho_v(2) = m_v*Pv(2)/(Rc*T(2))
+  a_v(2)   = rho_v(2)/rho_n(2)
+
+  !-------------------------------
+  ! start vertical ascent
+  Ztab(1) = 0.
+  do ilay=2,nlay-1
+
+     ! calculate altitude levels (for diagnostic only)
+     Dz         = -Dp/(  g*(rho_n(ilay) + rho_v(ilay))  )
+     Ztab(ilay) = Dz + Ztab(ilay-1)
+
+     ! 1st assume next layer same as last one
+     profil_flag(ilay) = profil_flag(ilay-1)
+  
+     ! update delta p
+     Dp = (Pn(ilay)+Pv(ilay))*(exp(dlogp) - 1d0)
+
+     ! intial gradients call to calculate temperature at next level
+     call gradients_kcm(profil_flag(ilay),rho_v(ilay),rho_n(ilay),&
+                        T(ilay),dTdp,dPvdp,dPndp)
+
+     T(ilay+1) = T(ilay) + dTdp*Dp
+
+     ! test for moist adiabat at next level
+     psat_v=psat_max
+
+     if(vgas.gt.0)then
+     if(trim(gnom(vgas)).eq.'H2O')then
+        call Psat_H2O(T(ilay+1),psat_v)
+     elseif(trim(gnom(vgas)).eq.'NH3')then
+        call Psat_NH3(T(ilay+1),psat_v)
+     endif
+     endif
+
+     if (psat_v*1d6 .lt. Pv(ilay)+dPvdp*Dp) then
+        profil_flag(ilay)=1
+        call gradients_kcm(profil_flag(ilay),rho_v(ilay),rho_n(ilay),&
+                         T(ilay),dTdp,dPvdp,dPndp)
+     endif
+
+     ! test for stratosphere at next level
+     if (T(ilay+1) .le. Ttop) then
+        profil_flag(ilay)=2
+        T(ilay+1)=Ttop
+     endif
+
+     ! calculate pressures at next level
+     Pn(ilay+1) = Pn(ilay) + dPndp*Dp
+     Pv(ilay+1) = Pv(ilay) + dPvdp*Dp
+
+     if(profil_flag(ilay) .eq. 1)then
+       
+        psat_v=psat_max 
+
+        if(vgas.gt.0)then
+        if(trim(gnom(vgas)).eq.'H2O')then
+           call Psat_H2O(T(ilay+1),psat_v)
+        elseif(trim(gnom(vgas)).eq.'NH3')then
+           call Psat_NH3(T(ilay+1),psat_v)
+        endif
+        endif
+
+        if(Pv(ilay+1) .lt. psat_v*1e6)then
+           Pv(ilay+1)=psat_v*1d6
+        endif
+
+     endif
+
+     ! calculate gas densities at next level (assume ideal)
+     rho_n(ilay+1) = m_n*Pn(ilay+1)/(rc*T(ilay+1)) 
+     select case(profil_flag(ilay)) 
+     case(2) ! isothermal
+        rho_v(ilay+1) = rho_v(ilay)/rho_n(ilay)*rho_n(ilay+1)
+     case(1) ! moist
+
+        ! dont think this is necessary
+        !call psat_est(T(ilay+1),psat_v)
+        ! modify for ammonia!!!
+
+        rho_v(ilay+1) = m_v*psat_v*1d6/(rc*T(ilay+1))
+     case(0) ! dry
+        rho_v(ilay+1) = m_v*Pv(ilay+1)/(rc*T(ilay+1)) 
+     end select
+
+  enddo
+
+  Ztab(nlay)=Ztab(nlay-1)+Dz
+
+  !-------------------------------
+  ! save to kcm1d variables 
+
+  ! surface quantities
+  psurf_rcm = Pn(1) + Pv(1)
+  qsurf_rcm = rho_v(1)/(rho_v(1) + rho_n(1))
+
+  ! create q_v, mtot for saving
+  do ilay=1,nlay
+     mtot(ilay) = 1d3*(rho_v(ilay) + rho_n(ilay)) / &
+                  (rho_v(ilay)/m_v + rho_n(ilay)/m_n)
+     q_v(ilay)  = rho_v(ilay)/(rho_v(ilay) + rho_n(ilay))
+     ! CHECK THIS
+  enddo
+
+
+  ! convert to rcm lower-res grid
+  z_rcm(:) = 0.0
+  T_rcm(:) = 0.0
+  q_rcm(:) = 0.0
+  m_rcm(:) = 0.0
+
+  m_rcm(1) = real( 1d3*(rho_v(1) + rho_n(1)) / &
+                  (rho_v(1)/m_v + rho_n(1)/m_n) )
+
+  ilay_rcm=1
+  do ilay=2,nlay
+
+     if(ilay_rcm.le.nlayermx)then
+     ! interpolate rcm variables
+
+        if(Pn(ilay)+Pv(ilay) .lt. P_rcm(ilay_rcm))then
+
+           if(ilay.eq.1)then
+              print*,'Error in create_profils: Psurf here less than Psurf in RCM!'
+              call abort
+           endif
+
+           lnp1   = log(Pn(ilay-1)+Pv(ilay-1))
+           lnp2   = log(Pn(ilay)+Pv(ilay))
+           lnpnew = dble(log(P_rcm(ilay_rcm)))
+
+           z_rcm(ilay_rcm) = real(Ztab(ilay-1)*(lnp2-lnpnew)/(lnp2-lnp1) &
+                             + Ztab(ilay)*(lnpnew-lnp1)/(lnp2-lnp1))
+           T_rcm(ilay_rcm) = real(T(ilay-1)*(lnp2-lnpnew)/(lnp2-lnp1) &
+                             + T(ilay)*(lnpnew-lnp1)/(lnp2-lnp1))
+           q_rcm(ilay_rcm) = real(q_v(ilay-1)*(lnp2-lnpnew)/(lnp2-lnp1) &
+                             + q_v(ilay)*(lnpnew-lnp1)/(lnp2-lnp1))
+
+           m_rcm(ilay_rcm+1) = real(mtot(ilay-1)*(lnp2-lnpnew)/(lnp2-lnp1) &
+                             + mtot(ilay)*(lnpnew-lnp1)/(lnp2-lnp1))
+
+           ilay_rcm = ilay_rcm+1
+        endif
+
+     endif
+  enddo
+
+  ifinal_rcm=ilay_rcm-1
+  if(ifinal_rcm.lt.nlayermx)then
+     if(verbose)then
+        print*,'Interpolation in kcmprof stopped at layer',ilay_rcm,'!'
+     endif
+
+     do ilay_rcm=ifinal_rcm+1,nlayermx
+
+        z_rcm(ilay_rcm) = z_rcm(ilay_rcm-1)
+        T_rcm(ilay_rcm) = T_rcm(ilay_rcm-1)
+        q_rcm(ilay_rcm) = q_rcm(ilay_rcm-1)
+        m_rcm(ilay_rcm+1) = m_rcm(ilay_rcm)
+
+     enddo
+  endif
+
+  do ilay=2,nlayermx
+     if(T_rcm(ilay).lt.Ttop)then
+        T_rcm(ilay)=Ttop
+     endif
+  enddo
+
+!    CO2 condensation 'haircut' of temperature profile if necessary
+  if(co2cond)then
+     print*,'CO2 condensation haircut - assumes CO2-dominated atmosphere!'
+     do ilay=2,nlayermx
+        if(P_rcm(ilay).lt.518000.)then
+           TCO2cond = (-3167.8)/(log(.01*P_rcm(ilay))-23.23) ! Fanale's formula
+        else
+           TCO2cond = 684.2-92.3*log(P_rcm(ilay))+4.32*log(P_rcm(ilay))**2 
+           ! liquid-vapour transition (based on CRC handbook 2003 data)
+        endif
+
+        print*,'p=',P_rcm(ilay),', T=',T_rcm(ilay),' Tcond=',TCO2cond
+        if(T_rcm(ilay).lt.TCO2cond)then
+           T_rcm(ilay)=TCO2cond
+        endif
+     enddo
+  endif
+
+  return
+end subroutine kcmprof_fn
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/lagrange.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/lagrange.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/lagrange.F	(revision 222)
@@ -0,0 +1,30 @@
+      subroutine lagrange(x, xi, yi, ans)
+
+C  Lagrange interpolation - Polynomial interpolation at point x 
+C  xi(1) <= x <= xi(4).  Yi(n) is the functional value at XI(n).
+
+      implicit none
+
+      real*8 x, xi(4), yi(4), ans
+      real*8 fm1, fm2, fm3, fm4
+
+C======================================================================!
+
+      fm1   = x - XI(1)
+      fm2   = x - XI(2)
+      fm3   = x - XI(3)
+      fm4   = x - XI(4)
+
+C  Get the answer at the requested X
+ 
+      ans = fm2*fm3*fm4*YI(1)/
+     *                ((XI(1)-XI(2))*(XI(1)-XI(3))*(XI(1)-XI(4)))  +
+     *      fm1*fm3*fm4*YI(2)/
+     *                ((XI(2)-XI(1))*(XI(2)-XI(3))*(XI(2)-XI(4)))  +
+     *      fm1*fm2*fm4*YI(3)/
+     *                ((XI(3)-XI(1))*(XI(3)-XI(2))*(XI(3)-XI(4)))  +
+     *      fm1*fm2*fm3*YI(4)/
+     *                ((XI(4)-XI(1))*(XI(4)-XI(2))*(XI(4)-XI(3))) 
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/largescale.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/largescale.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/largescale.F90	(revision 222)
@@ -0,0 +1,177 @@
+      subroutine largescale(ngrid,nq,ptimestep, pplev, pplay, pt, pq,   &
+                        pdt, pdq, pdtlsc, pdqvaplsc, pdqliqlsc, rneb)
+
+
+!     to use  'getin'
+      use ioipsl_getincom 
+      use watercommon_h, only : RLVTT, RCPD, RVTMP2,  &
+          T_h2O_ice_clouds,T_h2O_ice_liq,Psat_waterDP,Lcpdqsat_waterDP
+      USE tracer_h
+      IMPLICIT none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates large-scale (stratiform) H2O condensation.
+!     
+!     Authors
+!     -------
+!     Adapted from the LMDTERRE code by R. Wordsworth (2009)
+!     Original author Z. X. Li (1993)
+!     
+!==================================================================
+
+#include "dimensions.h" 
+#include "dimphys.h"
+#include "comcstfi.h"
+
+#include "callkeys.h"
+
+      INTEGER ngrid,nq
+
+!     Arguments
+      REAL ptimestep                 ! intervalle du temps (s)
+      REAL pplev(ngrid,nlayermx+1) ! pression a inter-couche
+      REAL pplay(ngrid,nlayermx)   ! pression au milieu de couche
+      REAL pt(ngrid,nlayermx)      ! temperature (K)
+      REAL pq(ngrid,nlayermx,nq) ! tracer mixing ratio (kg/kg)
+      REAL pdt(ngrid,nlayermx)     ! physical temperature tenedency (K/s)
+      REAL pdq(ngrid,nlayermx,nq)! physical tracer tenedency (K/s)
+      REAL pdtlsc(ngrid,nlayermx)  ! incrementation de la temperature (K)
+      REAL pdqvaplsc(ngrid,nlayermx) ! incrementation de la vapeur d'eau
+      REAL pdqliqlsc(ngrid,nlayermx) ! incrementation de l'eau liquide
+      REAL rneb(ngrid,nlayermx)    ! fraction nuageuse
+
+
+!     Options du programme
+      REAL, SAVE :: ratqs   ! determine largeur de la distribution de vapeur
+
+!     Variables locales
+      REAL CBRT
+      EXTERNAL CBRT
+      INTEGER i, k , nn
+      INTEGER,PARAMETER :: nitermax=5000
+      DOUBLE PRECISION,PARAMETER :: alpha=.1,qthreshold=1.d-8
+      ! JL13: if "careful, T<Tmin in psat water" appears often, you may want to stabilise the model by
+      !                   decreasing alpha and increasing nitermax accordingly
+      DOUBLE PRECISION zt(ngrid), zq(ngrid)
+      DOUBLE PRECISION zcond(ngrid),zcond_iter
+      DOUBLE PRECISION zdelq(ngrid)
+      DOUBLE PRECISION zqs(ngrid), zdqs(ngrid)
+      DOUBLE PRECISION local_p,psat_tmp,dlnpsat_tmp,Lcp
+      
+! evaporation calculations
+      REAL dqevap(ngrid,nlayermx),dtevap(ngrid,nlayermx)     
+      REAL qevap(ngrid,nlayermx,nq)
+      REAL tevap(ngrid,nlayermx)
+
+      DOUBLE PRECISION zx_q(ngrid)
+      LOGICAL,SAVE :: firstcall=.true.
+
+
+      IF (firstcall) THEN
+
+	 write(*,*) "value for ratqs? "
+         ratqs=0.2 ! default value
+         call getin("ratqs",ratqs)
+         write(*,*) " ratqs = ",ratqs
+
+         firstcall = .false.
+      ENDIF
+
+!     GCM -----> subroutine variables, initialisation of outputs
+
+      pdtlsc(1:ngrid,1:nlayermx)  = 0.0
+      pdqvaplsc(1:ngrid,1:nlayermx)  = 0.0
+      pdqliqlsc(1:ngrid,1:nlayermx) = 0.0
+      rneb(1:ngrid,1:nlayermx) = 0.0
+      Lcp=RLVTT/RCPD
+
+
+      ! Evaporate cloud water/ice
+      call evap(ngrid,nq,ptimestep,pt,pq,pdq,pdt,dqevap,dtevap,qevap,tevap)
+      ! note: we use qevap but not tevap in largescale/moistadj
+            ! otherwise is a big mess
+
+
+!  Boucle verticale (du haut vers le bas)
+   DO k = nlayermx, 1, -1
+
+      zt(1:ngrid)=pt(1:ngrid,k)+(pdt(1:ngrid,k)+dtevap(1:ngrid,k))*ptimestep
+      zq(1:ngrid)=qevap(1:ngrid,k,igcm_h2o_vap) !liquid water is included in qevap
+
+!     Calculer la vapeur d'eau saturante et 
+!     determiner la condensation partielle
+      DO i = 1, ngrid
+
+         local_p=pplay(i,k)
+         if(zt(i).le.15.) then
+	    print*,'in lsc',i,k,zt(i)
+!	    zt(i)=15.   ! check too low temperatures
+         endif
+         call Psat_waterDP(zt(i),local_p,psat_tmp,zqs(i))
+ 
+         zdelq(i) = MAX(MIN(ratqs * zq(i),1.-zq(i)),1.d-12)
+	 rneb(i,k) = (zq(i)+zdelq(i)-zqs(i)) / (2.0*zdelq(i))
+	 if (rneb(i,k).lt.0.) then  !no clouds
+
+	    rneb(i,k)=0.
+	    zcond(i)=0.
+
+	 else if ((rneb(i,k).gt.0.99).or.(ratqs.lt.1.e-6)) then    !complete cloud cover, we start without evaporating
+	    rneb(i,k)=1.
+            zt(i)=pt(i,k)+pdt(i,k)*ptimestep
+	    zx_q(i) = pq(i,k,igcm_h2o_vap)+pdq(i,k,igcm_h2o_vap)*ptimestep
+	    dqevap(i,k)=0.
+!           iterative process to stabilize the scheme when large water amounts JL12
+            zcond(i) = 0.0d0
+            Do nn=1,nitermax  
+               call Psat_waterDP(zt(i),local_p,psat_tmp,zqs(i))
+	       call Lcpdqsat_waterDP(zt(i),local_p,psat_tmp,zqs(i),zdqs(i),dlnpsat_tmp)
+               zcond_iter = alpha*(zx_q(i)-zqs(i))/(1.d0+zdqs(i))	   
+                  !zcond can be negative here
+               zx_q(i) = zx_q(i) - zcond_iter
+	       zcond(i) = zcond(i) + zcond_iter
+	       zt(i) = zt(i) + zcond_iter*Lcp
+	       if (ABS(zcond_iter/alpha/zqs(i)).lt.qthreshold) exit
+!	       if (ABS(zcond_iter/alpha).lt.qthreshold) exit
+	       if (nn.eq.nitermax) print*,'itermax in largescale'
+	    End do ! niter
+	    zcond(i)=MAX(zcond(i),-(pq(i,k,igcm_h2o_ice)+pdq(i,k,igcm_h2o_ice)*ptimestep))
+
+	 else   !standard case	    
+
+	    zx_q(i) = (zq(i)+zdelq(i)+zqs(i))/2.0d0 !water vapor in cloudy sky
+!           iterative process to stabilize the scheme when large water amounts JL12
+            zcond(i) = 0.0d0
+            Do nn=1,nitermax  
+	       call Lcpdqsat_waterDP(zt(i),local_p,psat_tmp,zqs(i),zdqs(i),dlnpsat_tmp)
+               zcond_iter = MAX(0.0d0,alpha*(zx_q(i)-zqs(i))/(1.d0+zdqs(i)))	   
+                  !zcond always postive! cannot evaporate clouds!
+                  !this is why we must reevaporate before largescale
+               zx_q(i) = zx_q(i) - zcond_iter
+	       zcond(i) = zcond(i) + zcond_iter
+	       if (ABS(zcond_iter/alpha/zqs(i)).lt.qthreshold) exit
+!	       if (ABS(zcond_iter/alpha).lt.qthreshold) exit
+	       zt(i) = zt(i) + zcond_iter*Lcp*rneb(i,k)
+               call Psat_waterDP(zt(i),local_p,psat_tmp,zqs(i))
+	       if (nn.eq.nitermax) print*,'itermax in largescale'
+	    End do ! niter
+
+	 Endif
+
+         zcond(i) = zcond(i)*rneb(i,k)/ptimestep ! JL12
+
+      ENDDO
+
+!     Tendances de t et q
+         pdqvaplsc(1:ngrid,k)  = dqevap(1:ngrid,k) - zcond(1:ngrid)
+         pdqliqlsc(1:ngrid,k) = - pdqvaplsc(1:ngrid,k)
+         pdtlsc(1:ngrid,k)  = pdqliqlsc(1:ngrid,k)*real(Lcp)
+
+   Enddo ! k= nlayermx, 1, -1
+ 
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/lect_start_archive.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/lect_start_archive.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/lect_start_archive.F	(revision 222)
@@ -0,0 +1,1492 @@
+      SUBROUTINE lect_start_archive(date,tsurf,tsoil,emis,q2,
+     &     t,ucov,vcov,ps,h,phisold_newgrid,
+     &     q,qsurf,surfith,nid,
+     &     rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+
+!      USE surfdat_h
+      USE comsoil_h, ONLY: nsoilmx, layer, mlayer, volcapa, inertiedat
+      USE tracer_h, ONLY: igcm_co2_ice
+      USE infotrac, ONLY: tname, nqtot
+      USE slab_ice_h, ONLY: noceanmx
+!      USE control_mod
+! to use  'getin'
+
+c=======================================================================
+c
+c
+c   Auteur:    05/1997 , 12/2003 : coord hybride  FF
+c   ------
+c
+c
+c   Objet:     Lecture des variables d'un fichier "start_archive"
+c              Plus besoin de régler ancienne valeurs grace
+c              a l'allocation dynamique de memoire (Yann Wanherdrick)
+c
+c
+c
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+!#include "planete.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+!#include "control.h"
+!#include "logic.h"
+#include "ener.h"
+#include "temps.h"
+#include "netcdf.inc"
+!#include"advtrac.h"
+#include "callkeys.h"
+c=======================================================================
+c   Declarations
+c=======================================================================
+
+c Old variables dimensions (from file)
+c------------------------------------
+      INTEGER   imold,jmold,lmold,nsoilold,nqold
+
+
+c Variables pour les lectures des fichiers "ini" 
+c--------------------------------------------------
+!      INTEGER sizei,
+      integer timelen,dimid
+!      INTEGER length
+!      parameter (length = 100)
+      INTEGER tab0
+      INTEGER isoil,iq,iqmax
+      CHARACTER*2   str2
+
+!      REAL dimfirst(4) ! tableau contenant les 1ers elements des dimensions
+
+!      REAL dimlast(4) ! tableau contenant les derniers elements des dimensions
+
+!      REAL dimcycl(4) ! tableau contenant les periodes des dimensions
+!      CHARACTER*120 dimsource
+!      CHARACTER*16 dimname
+!      CHARACTER*80 dimtitle
+!      CHARACTER*40 dimunits
+!      INTEGER   dimtype
+
+!      INTEGER dimord(4)  ! tableau contenant l''ordre
+!      data dimord /1,2,3,4/ ! de sortie des dimensions
+
+!      INTEGER vardim(4)
+      REAL date
+      INTEGER   memo
+!      character (len=50) :: tmpname
+
+c Variable histoire 
+c------------------
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL h(iip1,jjp1,llm),ps(iip1,jjp1)
+      REAL q(iip1,jjp1,llm,nqtot),qtot(iip1,jjp1,llm)
+
+c autre variables dynamique nouvelle grille
+c------------------------------------------
+
+c!-*-
+!      integer klatdat,klongdat
+!      PARAMETER (klatdat=180,klongdat=360)
+
+c Physique sur grille scalaire 
+c----------------------------
+
+c variable physique
+c------------------
+      REAL tsurf(ngridmx) ! surface temperature
+      REAL tsoil(ngridmx,nsoilmx) ! soil temperature
+      REAL co2ice(ngridmx) ! CO2 ice layer
+      REAL emis(ngridmx)
+      REAL q2(ngridmx,nlayermx+1),qsurf(ngridmx,nqtot)
+      REAL tslab(ngridmx,noceanmx)
+      REAL rnat(ngridmx),pctsrf_sic(ngridmx)
+      REAL tsea_ice(ngridmx),sea_ice(ngridmx)
+c     REAL phisfi(ngridmx)
+
+      INTEGER i,j,l
+      INTEGER nid,nvarid
+c     REAL year_day,periheli,aphelie,peri_day
+c     REAL obliquit,z0,emin_turb,lmixmin
+c     REAL emissiv,emisice(2),albedice(2)
+c     REAL iceradius(2) , dtemisice(2)
+
+      integer ierr
+      integer, dimension(4) :: start,count
+
+c Variable nouvelle grille naturelle au point scalaire
+c------------------------------------------------------
+      real us(iip1,jjp1,llm),vs(iip1,jjp1,llm)
+      REAL phisold_newgrid(iip1,jjp1)
+      REAL t(iip1,jjp1,llm)
+      real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx)
+      real inertiedatS(iip1,jjp1,nsoilmx)
+      real co2iceS(iip1,jjp1)
+      real emisS(iip1,jjp1)
+      REAL q2S(iip1,jjp1,llm+1),qsurfS(iip1,jjp1,nqtot)
+      real tslabS(iip1,jjp1,noceanmx)
+      real pctsrf_sicS(iip1,jjp1),tsea_iceS(iip1,jjp1)
+      real rnatS(iip1,jjp1), sea_iceS(iip1,jjp1)
+
+      real ptotal, co2icetotal
+
+c Var intermediaires : vent naturel, mais pas coord scalaire
+c-----------------------------------------------------------
+      real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)
+
+
+c Variable de l'ancienne grille 
+c---------------------------------------------------------
+
+      real, dimension(:), allocatable :: timelist
+      real, dimension(:), allocatable :: rlonuold, rlatvold
+      real, dimension(:), allocatable :: rlonvold, rlatuold
+      real, dimension(:), allocatable :: apsold,bpsold
+      real, dimension(:), allocatable :: mlayerold
+      real, dimension(:,:,:), allocatable :: uold,vold,told,q2old
+      real, dimension(:,:,:), allocatable :: tsoilold,qsurfold
+      real, dimension(:,:,:),allocatable :: tsoiloldnew
+! tsoiloldnew: old soil values, but along new subterranean grid
+      real, dimension(:,:,:), allocatable :: inertiedatold
+! inertiedatoldnew: old inertia values, but along new subterranean grid
+      real, dimension(:,:,:), allocatable :: inertiedatoldnew
+      real, dimension(:,:), allocatable :: psold,phisold
+      real, dimension(:,:), allocatable :: co2iceold
+      real, dimension(:,:), allocatable :: tsurfold
+      real, dimension(:,:), allocatable :: emisold
+      real, dimension(:,:,:,:), allocatable :: qold
+      real, dimension(:,:,:), allocatable :: tslabold
+      real, dimension(:,:), allocatable :: rnatold,pctsrf_sicold
+      real, dimension(:,:), allocatable :: tsea_iceold,sea_iceold
+
+
+      real tab_cntrl(100)
+
+      real ptotalold, co2icetotalold
+
+      logical :: olddepthdef=.false. ! flag
+! olddepthdef=.true. if soil depths are in 'old' (unspecified) format
+      logical :: depthinterpol=.false. ! flag
+! depthinterpol=.true. if interpolation will be requiered
+      logical :: therminertia_3D=.true. ! flag
+! therminertia_3D=.true. if thermal inertia is 3D and read from datafile
+c Variable intermediaires iutilise pour l'extrapolation verticale 
+c----------------------------------------------------------------
+      real, dimension(:,:,:), allocatable :: var,varp1 
+      real, dimension(:), allocatable :: oldgrid, oldval
+      real, dimension(:), allocatable :: newval
+
+      real surfith(iip1,jjp1) ! surface thermal inertia
+      ! surface thermal inertia at old horizontal grid resolution
+      real, dimension(:,:), allocatable :: surfithold 
+
+      character(len=30) :: txt ! to store some text
+
+c=======================================================================
+
+! 0. Preliminary stuff
+
+
+
+!-----------------------------------------------------------------------
+! 1. Read data dimensions (i.e. size and length)
+!-----------------------------------------------------------------------
+
+! 1.2 Read the various dimension lengths of data in file 
+
+      ierr= NF_INQ_DIMID(nid,"Time",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"temps",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
+
+      ierr= NF_INQ_DIMID(nid,"latitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"rlatu",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,jmold)
+      jmold=jmold-1
+
+      ierr= NF_INQ_DIMID(nid,"longitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"rlonv",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,imold)
+      imold=imold-1
+
+      ierr= NF_INQ_DIMID(nid,"altitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"sig_s",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,lmold)
+
+      nqold=0
+      do
+         write(str2,'(i2.2)') nqold+1
+         ierr= NF_INQ_VARID(nid,'q'//str2,dimid)
+!        write(*,*) 'q'//str2
+         if (ierr.eq.NF_NOERR) then
+            nqold=nqold+1
+         else
+            exit
+         endif
+      enddo
+
+! 1.2.1 find out the # of subsurface_layers
+      nsoilold=0 !dummy initialisation
+      ierr=NF_INQ_DIMID(nid,"subsurface_layers",dimid)
+      if (ierr.eq.NF_NOERR) then
+        ierr=NF_INQ_DIMLEN(nid,dimid,nsoilold)
+	if (ierr.ne.NF_NOERR) then
+	 write(*,*)'lec_start_archive: ',
+     &              'Failed reading subsurface_layers length'
+	endif
+      else
+        write(*,*)"lec_start_archive: did not find subsurface_layers"
+      endif
+
+      if (nsoilold.eq.0) then ! 'old' archive format;
+      ! must use Tg//str2 fields to compute nsoilold
+      write(*,*)"lec_start_archive: building nsoilold from Tg fields"
+        do
+	 write(str2,'(i2.2)') nsoilold+1
+	 ierr=NF_INQ_VARID(nid,'Tg'//str2,dimid)
+	 if (ierr.eq.NF_NOERR) then
+	  nsoilold=nsoilold+1
+	 else
+	  exit
+	 endif
+	enddo
+      endif
+
+
+      if (nsoilold.ne.nsoilmx) then ! interpolation will be required
+        depthinterpol=.true.
+      endif
+
+! 1.3 Report dimensions
+      
+      write(*,*) "Start_archive dimensions:"
+      write(*,*) "longitude: ",imold
+      write(*,*) "latitude: ",jmold
+      write(*,*) "altitude: ",lmold
+      write(*,*) "tracers: ",nqold
+      write(*,*) "subsurface_layers: ",nsoilold
+      if (depthinterpol) then
+      write(*,*) " => Warning, nsoilmx= ",nsoilmx
+      write(*,*) '    which implies that you want subterranean interpola
+     &tion.'
+      write(*,*) '  Otherwise, set nsoilmx -in dimphys.h- to: ',nsoilold
+      endif
+      write(*,*) "time lenght: ",timelen
+      write(*,*) 
+
+!-----------------------------------------------------------------------
+! 2. Allocate arrays to store datasets
+!-----------------------------------------------------------------------
+
+      allocate(timelist(timelen))
+      allocate(rlonuold(imold+1), rlatvold(jmold))
+      allocate(rlonvold(imold+1), rlatuold(jmold+1))
+      allocate (apsold(lmold),bpsold(lmold))
+      allocate(uold(imold+1,jmold+1,lmold))
+      allocate(vold(imold+1,jmold+1,lmold))
+      allocate(told(imold+1,jmold+1,lmold))
+      allocate(psold(imold+1,jmold+1))
+      allocate(phisold(imold+1,jmold+1))
+      allocate(qold(imold+1,jmold+1,lmold,nqtot))
+      allocate(co2iceold(imold+1,jmold+1))
+      allocate(tsurfold(imold+1,jmold+1))
+      allocate(emisold(imold+1,jmold+1))
+      allocate(q2old(imold+1,jmold+1,lmold+1))
+!      allocate(tsoilold(imold+1,jmold+1,nsoilmx))
+      allocate(tsoilold(imold+1,jmold+1,nsoilold))
+      allocate(tsoiloldnew(imold+1,jmold+1,nsoilmx))
+      allocate(inertiedatold(imold+1,jmold+1,nsoilold)) ! soil thermal inertia
+      allocate(inertiedatoldnew(imold+1,jmold+1,nsoilmx))
+      ! surface thermal inertia at old horizontal grid resolution
+      allocate(surfithold(imold+1,jmold+1))
+      allocate(mlayerold(nsoilold))
+      allocate(qsurfold(imold+1,jmold+1,nqtot))
+      allocate(tslabold(imold+1,jmold+1,noceanmx))
+      allocate(rnatold(imold+1,jmold+1))
+      allocate(pctsrf_sicold(imold+1,jmold+1))
+      allocate(tsea_iceold(imold+1,jmold+1))
+      allocate(sea_iceold(imold+1,jmold+1))
+
+      allocate(var (imold+1,jmold+1,llm))
+      allocate(varp1 (imold+1,jmold+1,llm+1))
+
+      write(*,*) 'q2',ngridmx,nlayermx+1
+      write(*,*) 'q2S',iip1,jjp1,llm+1
+      write(*,*) 'q2old',imold+1,jmold+1,lmold+1
+
+!-----------------------------------------------------------------------
+! 3. Read time-independent data
+!-----------------------------------------------------------------------
+
+C-----------------------------------------------------------------------
+c 3.1. Lecture du tableau des parametres du run 
+c     (pour  la lecture ulterieure de "ptotalold" et "co2icetotalold")
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Lect_start_archive: champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+c
+      tab0 = 50
+
+c-----------------------------------------------------------------------
+c 3.2 Lecture des longitudes et latitudes
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlatv>"
+         CALL abort
+      ENDIF
+c
+
+c-----------------------------------------------------------------------
+c 3.3. Lecture des niveaux verticaux
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "aps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <aps> est absent"
+         apsold=0
+         PRINT*, "<aps> set to 0"
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apsold)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, apsold)
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: Lecture echouee pour <aps>"
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "bps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <bps> est absent"
+         PRINT*, "It must be an old start_archive, lets look for sig_s"
+         ierr = NF_INQ_VARID (nid, "sig_s", nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "Nothing to do..."
+            CALL abort
+         ENDIF
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpsold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, bpsold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <bps>"
+         CALL abort
+      END IF
+
+c-----------------------------------------------------------------------
+c 3.4 Read Soil layers depths
+c-----------------------------------------------------------------------
+     
+      ierr=NF_INQ_VARID(nid,"soildepth",nvarid)
+      if (ierr.ne.NF_NOERR) then
+       write(*,*)'lect_start_archive: Could not find <soildepth>'
+       write(*,*)' => Assuming this is an archive in old format'
+       olddepthdef=.true.
+       depthinterpol=.true.
+       ! this is how soil depth was defined in ye old days
+	do isoil=1,nsoilold
+	  mlayerold(isoil)=sqrt(887.75/3.14)*((2.**(isoil-0.5))-1.)
+	enddo
+      else
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayerold)
+#else
+        ierr = NF_GET_VAR_REAL(nid,nvarid,mlayerold)
+#endif
+       if (ierr .NE. NF_NOERR) then
+         PRINT*, "lect_start_archive: Failed reading <soildepth>"
+         CALL abort
+       endif
+
+      endif !of if(ierr.ne.NF_NOERR)
+
+      ! Read (or build) mlayer()
+      if (depthinterpol) then
+       ! Build (default) new soil depths (mlayer(:) is in comsoil.h),
+       ! as in soil_settings.F
+       write(*,*)' => Building default soil depths'
+       do isoil=0,nsoilmx-1
+         mlayer(isoil)=2.e-4*(2.**(isoil-0.5))
+       enddo
+       write(*,*)' => mlayer: ',mlayer
+       ! Also build (default) new soil interlayer depth layer(:)
+       do isoil=1,nsoilmx
+         layer(isoil)=sqrt(mlayer(0)*mlayer(1))*
+     &                      ((mlayer(1)/mlayer(0))**(isoil-1))
+       enddo
+       write(*,*)' =>  layer: ',layer
+      else ! read mlayer() from file
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayer)
+#else
+        ierr = NF_GET_VAR_REAL(nid,nvarid,mlayer)
+#endif
+       if (ierr .NE. NF_NOERR) then
+         PRINT*, "lect_start_archive: Failed reading <soildepth>"
+         CALL abort
+       endif
+      endif ! of if (depthinterpol)
+
+c-----------------------------------------------------------------------
+c 3.5 Read Soil thermal inertia
+c-----------------------------------------------------------------------
+
+      ierr=NF_INQ_VARID(nid,"inertiedat",nvarid)
+      if (ierr.ne.NF_NOERR) then
+       write(*,*)'lect_start_archive: Could not find <inertiedat>'
+       write(*,*)' => Assuming this is an archive in old format'
+       therminertia_3D=.false.
+       write(*,*)' => Thermal inertia will be read from reference file'
+       volcapa=1.e6
+       write(*,*)'    and soil volumetric heat capacity is set to ',
+     &           volcapa
+      else
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,inertiedatold)
+#else
+        ierr = NF_GET_VAR_REAL(nid,nvarid,inertiedatold)
+#endif
+       if (ierr .NE. NF_NOERR) then
+         PRINT*, "lect_start_archive: Failed reading <inertiedat>"
+         CALL abort
+       endif
+      endif
+
+c-----------------------------------------------------------------------
+c 3.6 Lecture geopotentiel au sol
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phisold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+C-----------------------------------------------------------------------
+c   lecture de "ptotalold" et "co2icetotalold"
+c-----------------------------------------------------------------------
+      ptotalold = tab_cntrl(tab0+49)
+      co2icetotalold = tab_cntrl(tab0+50)
+ 
+c-----------------------------------------------------------------------
+c 4. Lecture du temps et choix
+c-----------------------------------------------------------------------
+ 
+c  lecture du temps
+c
+      ierr = NF_INQ_DIMID (nid, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         ierr = NF_INQ_DIMID (nid, "temps", nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: Le champ <Time> est absent"
+            CALL abort
+         endif
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      endif 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, timelist)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, timelist)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <Time>"
+         CALL abort
+      ENDIF
+c
+      write(*,*)
+      write(*,*)
+      write(*,*) 'Differentes dates des etats initiaux stockes:'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      pi=2.*ASIN(1.)
+      do i=1,timelen
+c       call solarlong(timelist(i),sollong(i))
+c       sollong(i) = sollong(i)*180./pi
+        write(*,*) 'etat initial au jour martien' ,int(timelist(i))
+c       write(*,6) nint(timelist(i)),nint(mod(timelist(i),669)),
+c    .    sollong(i)
+      end do
+
+   6  FORMAT(i7,i7,f9.3)
+ 
+      write(*,*)
+      write(*,*) 'Choix de la date'
+ 123  read(*,*,iostat=ierr) date
+      if(ierr.ne.0) goto 123
+      memo = 0
+      do i=1,timelen
+        if (date.eq.int(timelist(i))) then
+            memo = i
+        endif
+      end do
+ 
+      if (memo.eq.0) then
+        write(*,*)
+        write(*,*)
+        write(*,*) 'He alors... Y sait pas lire !?!'
+        write(*,*)
+        write(*,*) 'Differentes dates des etats initiaux stockes:'
+        write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+        do i=1,timelen
+          write(*,*) 'etat initial au jour martien' ,nint(timelist(i))
+c         write(*,6) nint(timelist(i)),nint(mod(timelist(i),669))
+        end do
+        goto 123
+      endif
+
+!-----------------------------------------------------------------------
+! 5. Read (time-dependent) data from datafile
+!-----------------------------------------------------------------------
+
+
+c-----------------------------------------------------------------------
+c 5.1 Lecture des champs 2D (co2ice, emis,ps,tsurf,Tg[10], qsurf)
+c-----------------------------------------------------------------------
+ 
+      start=(/1,1,memo,0/)
+      count=(/imold+1,jmold+1,1,0/)
+       
+! CO2ice is now in qsurf(igcm_co2_ice) ...
+!      ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
+!      IF (ierr .NE. NF_NOERR) THEN
+!         PRINT*, "lect_start_archive: Le champ <co2ice> est absent"
+!         CALL abort
+!      ENDIF
+!#ifdef NC_DOUBLE
+!      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,co2iceold)
+!#else
+!      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,co2iceold)
+!#endif
+!      IF (ierr .NE. NF_NOERR) THEN
+!         PRINT*, "lect_start_archive: Lecture echouee pour <co2ice>"
+!         PRINT*, NF_STRERROR(ierr)
+!         CALL abort
+!      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "emis", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <emis> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,emisold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,emisold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <emis>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,psold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,psold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "tsurf", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <tsurf> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,tsurfold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,tsurfold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <tsurf>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "q2surf", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <q2surf> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <q2surf>"
+         CALL abort
+      ENDIF
+c
+cc Slab ocean
+      if(ok_slab_ocean) then
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,noceanmx,1/)
+
+       ierr=NF_INQ_VARID(nid,"tslab",nvarid)
+       IF (ierr.ne.NF_NOERR) then
+          PRINT*,"lect_start_archive: Cannot find <tslab>"
+       ENDIF
+#ifdef NC_DOUBLE
+      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,tslabold)
+#else
+      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,tslabold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <tslab>"
+      ENDIF
+
+
+c
+      start=(/1,1,memo,0/)
+      count=(/imold+1,jmold+1,1,0/)
+
+      ierr = NF_INQ_VARID (nid, "rnat", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rnat> est absent"
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,rnatold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,rnatold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rnat>"
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "pctsrf_sic", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <pctsrf_sic> est absent"
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,pctsrf_sicold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,pctsrf_sicold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <pctsrf_sic>"
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "tsea_ice", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <tsea_ice> est absent"
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,tsea_iceold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,tsea_iceold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <tsea_ice>"
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "sea_ice", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <sea_ice> est absent"
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,sea_iceold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,sea_iceold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <sea_ice>"
+      ENDIF
+  
+      ENDIF! ok_slab_ocean
+c
+      write(*,*)"lect_start_archive: rlonuold:"
+     &           ,rlonuold," rlatvold:",rlatvold
+      write(*,*)
+
+! Surface tracers:      
+      do iq=1,nqtot
+        ! initialize all surface tracers to zero
+        call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
+      enddo
+
+
+!      print*,'tname=',tname
+!      print*,'nid',nid
+!      print*,'nvarid',nvarid
+!      stop
+
+      DO iq=1,nqtot
+          txt=trim(tname(iq))//"_surf"
+          if (txt.eq."h2o_vap") then
+            ! There is no surface tracer for h2o_vap;
+            ! "h2o_ice" should be loaded instead
+            txt="h2o_ice_surf"
+            write(*,*) 'lect_start_archive: loading surface tracer',
+     &                     ' h2o_ice instead of h2o_vap'
+          endif
+
+        
+        write(*,*) "lect_start_archive: loading tracer ",trim(txt)
+        ierr = NF_INQ_VARID (nid,txt,nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "lect_start_archive: ",
+     &              " Tracer <",trim(txt),"> not found"
+
+!          print*,'RDW has added hack to let me continue...'
+!          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     &          qsurfold(1,1,iq))
+#else
+        ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     &          qsurfold(1,1,iq))
+#endif
+        IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "lect_start_archive: ",
+     &             " Failed loading <",trim(txt),">"
+          write (*,*) trim(txt),'    is set to 0'
+!          call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
+        ENDIF
+
+      ENDDO ! of DO iq=1,nqtot
+
+
+!-----------------------------------------------------------------------
+! 5.2 Read 3D subterranean fields
+!-----------------------------------------------------------------------
+
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,nsoilold,1/)
+!
+! Read soil temperatures
+!
+      if (olddepthdef) then ! tsoil stored using the 'old format'
+         start=(/1,1,memo,0/)
+         count=(/imold+1,jmold+1,1,0/) ! because the "Tg" are 2D datasets
+       do isoil=1,nsoilold
+         write(str2,'(i2.2)') isoil
+c
+         ierr = NF_INQ_VARID (nid, "Tg"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: ",
+     &              "Field <","Tg"//str2,"> not found"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     &          tsoilold(1,1,isoil))
+#else
+         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     &          tsoilold(1,1,isoil))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: ",
+     &            "Failed reading <","Tg"//str2,">"
+            CALL abort
+         ENDIF
+c
+       enddo ! of do isoil=1,nsoilold
+      
+      ! reset 'start' and 'count' to "3D" behaviour
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,nsoilold,1/)
+      
+      else
+       write(*,*) "lect_start_archive: loading tsoil "
+       ierr=NF_INQ_VARID(nid,"tsoil",nvarid)
+       if (ierr.ne.NF_NOERR) then
+        write(*,*)"lect_start_archive: Cannot find <tsoil>"
+	call abort
+       else
+#ifdef NC_DOUBLE
+      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,tsoilold)
+#else
+      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,tsoilold)
+#endif
+       endif ! of if (ierr.ne.NF_NOERR)
+       
+      endif ! of if (olddepthdef)
+
+!
+! Read soil thermal inertias
+!
+!      if (.not.olddepthdef) then ! no thermal inertia data in "old" archives
+!       ierr=NF_INQ_VARID(nid,"inertiedat",nvarid)
+!       if (ierr.ne.NF_NOERR) then
+!        write(*,*)"lect_start_archive: Cannot find <inertiedat>"
+!	call abort
+!       else
+!#ifdef NC_DOUBLE
+!      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,inertiedatold)
+!#else
+!      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,inertiedatold)
+!#endif
+!       endif ! of if (ierr.ne.NF_NOERR)
+!      endif
+
+c-----------------------------------------------------------------------
+c 5.3	Lecture des champs 3D (t,u,v, q2atm,q)
+c-----------------------------------------------------------------------
+
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,lmold,1/)
+
+c
+      ierr = NF_INQ_VARID (nid,"temp", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <temp> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid, start, count, told)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid, start, count, told)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <temp>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"u", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <u> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,uold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,uold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <u>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"v", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <v> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,vold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,vold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <v>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"q2atm", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <q2atm> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old(1,1,2))
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old(1,1,2))
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <q2atm>"
+         CALL abort
+      ENDIF
+c
+
+! Tracers:      
+      do iq=1,nqtot
+         call initial0((jmold+1)*(imold+1)*lmold,qold(1,1,1,iq) )
+      enddo
+
+      DO iq=1,nqtot
+        txt=tname(iq)
+        write(*,*)"lect_start_archive: loading tracer ",trim(txt)
+        ierr = NF_INQ_VARID (nid,txt,nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: ",
+     &              " Tracer <",trim(txt),"> not found"
+!            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,qold(1,1,1,iq))
+#else
+        ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,qold(1,1,1,iq))
+#endif
+        IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "lect_start_archive: ",
+     &             "  Failed loading <",trim(txt),">"
+          write (*,*) trim(txt),'      set to 1.E-30'
+          do l=1,lmold
+            do j=1,jmold+1
+              do i=1,imold+1
+                 qold(i,j,l,iq)=1.e-30
+              end do
+            end do
+          end do
+        ENDIF
+
+      ENDDO ! of DO iq=1,nqtot
+
+
+!=======================================================================
+! 6. Interpolation from old grid to new grid
+!=======================================================================
+
+c=======================================================================
+c   INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables
+c=======================================================================
+c  Interpolation horizontale puis passage dans la grille physique pour 
+c  les variables physique 
+c  Interpolation verticale puis horizontale pour chaque variable 3D
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c 6.1	Variable 2d :
+c-----------------------------------------------------------------------
+c Relief 
+      call interp_horiz (phisold,phisold_newgrid,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+! CO2 ice is now in qsurf(igcm_co2_ice)
+!      call interp_horiz (co2iceold,co2ices,imold,jmold,iim,jjm,1,
+!     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c Temperature de surface
+      call interp_horiz (tsurfold,tsurfs,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsurfs,tsurf)
+c     write(44,*) 'tsurf', tsurf
+
+c Temperature du sous-sol
+!      call interp_horiz(tsoilold,tsoils,
+!     &                  imold,jmold,iim,jjm,nsoilmx,
+!     &                   rlonuold,rlatvold,rlonu,rlatv)
+!      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoils,tsoil)
+c     write(45,*) 'tsoil',tsoil
+
+c Emissivite de la surface
+      call interp_horiz (emisold,emiss,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,emiss,emis)
+c     write(46,*) 'emis',emis
+
+
+
+c-----------------------------------------------------------------------
+c 6.1.2	Traitement special de la pression au sol :
+c-----------------------------------------------------------------------
+
+c  Extrapolation la pression dans la nouvelle grille
+      call interp_horiz(psold,ps,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c-----------------------------------------------------------------------
+c	On assure la conservation de la masse de l'atmosphere + calottes
+c-----------------------------------------------------------------------
+
+      ptotal =  0.
+      DO j=1,jjp1
+         DO i=1,iim
+            ptotal=ptotal+ps(i,j)*aire(i,j)/g
+         END DO
+      END DO
+      co2icetotal = 0.
+      if (igcm_co2_ice.ne.0) then
+        ! recast surface CO2 ice on new grid
+        call interp_horiz(qsurfold(1,1,igcm_co2_ice),
+     &                  qsurfs(1,1,igcm_co2_ice),
+     &                  imold,jmold,iim,jjm,1,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+       DO j=1,jjp1
+         DO i=1,iim
+           !co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j)
+           co2icetotal=co2icetotal+qsurfS(i,j,igcm_co2_ice)*aire(i,j)
+         END DO
+       END DO
+      else
+        write(*,*) "Warning: No co2_ice surface tracer"
+      endif
+
+      write(*,*)
+      write(*,*)'Ancienne grille: masse de l atm :',ptotalold
+      write(*,*)'Nouvelle grille: masse de l atm :',ptotal
+      write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold 
+      write(*,*)
+      write(*,*)'Ancienne grille: masse de la glace CO2:',co2icetotalold
+      write(*,*)'Nouvelle grille: masse de la glace CO2:',co2icetotal
+      if (co2icetotalold.ne.0.) then
+      write(*,*)'Ratio new ice./old ice =',co2icetotal/co2icetotalold
+      endif
+      write(*,*)
+
+
+      DO j=1,jjp1
+         DO i=1,iip1
+            ps(i,j)=ps(i,j) * ptotalold/ptotal
+         END DO
+      END DO
+
+      if ( co2icetotalold.gt.0.) then 
+!         DO j=1,jjp1
+!            DO i=1,iip1
+!               co2iceS(i,j)=co2iceS(i,j) * co2icetotalold/co2icetotal
+!            END DO
+!         END DO
+        write(*,*) "Not enforcing conservation of surface CO2 ice"
+        write(*,*) " (should be OK when CO2 ice is a tracer)"
+      end if
+
+c-----------------------------------------------------------------------
+c 6.2 Subterranean 3d variables:
+c-----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c 6.2.1 Thermal Inertia
+c       Note: recall that inertiedat is a common in "comsoil.h"
+c-----------------------------------------------------------------------
+
+      ! depth-wise interpolation, if required
+      if (depthinterpol.and.(.not.olddepthdef)) then
+        allocate(oldval(nsoilold))
+	allocate(newval(nsoilmx))
+        write(*,*)'lect_start_archive: WARNING: vertical interpolation o
+     &f soil thermal inertia; might be wiser to reset it.'
+        write(*,*)
+       
+        do i=1,imold+1
+         do j=1,jmold+1
+	   !copy old values
+	   oldval(1:nsoilold)=inertiedatold(i,j,1:nsoilold)
+	   !interpolate
+	   call interp_line(mlayerold,oldval,nsoilold,
+     &                     mlayer,newval,nsoilmx)
+           !copy interpolated values
+           inertiedatoldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
+	 enddo
+        enddo
+        ! cleanup
+	deallocate(oldval)
+	deallocate(newval)
+      endif !of if (depthinterpol)
+
+      if (therminertia_3D) then
+        ! We have inertiedatold
+       if((imold.ne.iim).or.(jmold.ne.jjm)) then
+       write(*,*)'lect_start_archive: WARNING: horizontal interpolation 
+     &of thermal inertia; might be better to reset it.'
+       write(*,*)
+       endif
+       
+        ! Do horizontal interpolation
+	if (depthinterpol) then
+	  call interp_horiz(inertiedatoldnew,inertiedatS,
+     &                  imold,jmold,iim,jjm,nsoilmx,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+	else
+          call interp_horiz(inertiedatold,inertiedatS,
+     &                  imold,jmold,iim,jjm,nsoilold,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+        endif ! of if (depthinterpol)
+
+      else ! no 3D thermal inertia data
+       write(*,*)'lect_start_archive: using reference surface inertia'
+        ! Use surface inertia (and extend it to all depths)
+        do i=1,nsoilmx
+         inertiedatS(1:iip1,1:jjp1,i)=surfith(1:iip1,1:jjp1)
+        enddo
+	! Build an old resolution surface thermal inertia
+	! (will be needed for tsoil interpolation)
+	call interp_horiz(surfith,surfithold,
+     &                    iim,jjm,imold,jmold,1,
+     &                    rlonu,rlatv,rlonuold,rlatvold)
+      endif
+
+
+      ! Reshape inertiedatS to scalar grid as inertiedat
+      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,
+     &                  inertiedatS,inertiedat)
+      
+c-----------------------------------------------------------------------
+c 6.2.2 Soil temperature
+c-----------------------------------------------------------------------
+!      write(*,*) 'Soil'
+
+      !print*,'Problem in lect_start_archive interpolating'
+      !print*,'to new resolution!!'
+
+      ! Recast temperatures along soil depth, if necessary
+      if (olddepthdef) then
+        allocate(oldgrid(nsoilold+1))
+        allocate(oldval(nsoilold+1))
+	allocate(newval(nsoilmx))
+        do i=1,imold+1
+	 do j=1,jmold+1
+
+            !if(i.gt.iip1 .or. j.gt.jjp1)then
+               !print*,'Problem in lect_start_archive interpolating'
+               !print*,'to new resolution!!'
+               !call abort
+            !endif
+
+	   ! copy values
+	   oldval(1)=tsurfold(i,j)
+!	   oldval(1)=tsurfS(i,j)
+	   oldval(2:nsoilold+1)=tsoilold(i,j,1:nsoilold)
+	   ! build vertical coordinate
+	   oldgrid(1)=0. ! ground
+	   oldgrid(2:nsoilold+1)=mlayerold(1:nsoilold)*
+     &                (surfithold(i,j)/1.e6)
+          ! Note; at this stage, we impose volcapa=1.e6 above
+	  ! since volcapa isn't set in old soil definitions
+
+	  ! interpolate
+	  call interp_line(oldgrid,oldval,nsoilold+1,
+     &                     mlayer,newval,nsoilmx)
+	 ! copy result in tsoilold
+	 tsoiloldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
+	 enddo
+	enddo
+        ! cleanup
+	deallocate(oldgrid)
+	deallocate(oldval)
+	deallocate(newval)
+
+      else
+       if (depthinterpol) then ! if vertical interpolation is required
+        allocate(oldgrid(nsoilold+1))
+        allocate(oldval(nsoilold+1))
+	allocate(newval(nsoilmx))
+        ! build vertical coordinate
+	oldgrid(1)=0. ! ground
+	oldgrid(2:nsoilold+1)=mlayerold(1:nsoilold)
+        do i=1,imold+1
+	 do j=1,jmold+1
+	   ! copy values
+	   oldval(1)=tsurfold(i,j)
+!	   oldval(1)=tsurfS(i,j)
+	   oldval(2:nsoilold+1)=tsoilold(i,j,1:nsoilold)
+	  ! interpolate
+	  call interp_line(oldgrid,oldval,nsoilold+1,
+     &                     mlayer,newval,nsoilmx)
+	 ! copy result in tsoilold
+	 tsoiloldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
+	 enddo
+	enddo
+!	write(*,*)'tsoiloldnew(1,1,1):',tsoiloldnew(1,1,1)
+        ! cleanup
+	deallocate(oldgrid)
+	deallocate(oldval)
+	deallocate(newval)
+       
+       else
+        tsoiloldnew(:,:,:)=tsoilold(:,:,:)
+       endif ! of if (depthinterpol)
+      endif ! of if (olddepthdef)
+
+      ! Do the horizontal interpolation
+       call interp_horiz(tsoiloldnew,tsoilS,
+     &                  imold,jmold,iim,jjm,nsoilmx,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+      ! Reshape tsoilS to scalar grid as tsoil
+       call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoilS,tsoil)
+
+c-----------------------------------------------------------------------
+c 6.3   Slab Ocean :
+c-----------------------------------------------------------------------
+      call interp_horiz (tslabold,tslabs,imold,jmold,iim,jjm,noceanmx,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tslabs,tslab)
+
+      call interp_horiz (rnatold,rnats,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,rnats,rnat)
+
+      call interp_horiz (pctsrf_sicold,pctsrf_sics,imold,jmold,iim,
+     &                   jjm,1,rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,pctsrf_sics,pctsrf_sic)
+
+      call interp_horiz (tsea_iceold,tsea_ices,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsea_ices,tsea_ice)
+
+      call interp_horiz (sea_iceold,sea_ices,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,sea_ices,sea_ice)
+
+c-----------------------------------------------------------------------
+c 6.4 Variable 3d :
+c-----------------------------------------------------------------------
+      
+c temperatures atmospheriques
+      write (*,*) 'lect_start_archive: told ', told (1,jmold+1,1)  ! INFO
+      call interp_vert
+     &    (told,var,lmold,llm,apsold,bpsold,aps,bps,
+     &     psold,(imold+1)*(jmold+1))
+      write (*,*) 'lect_start_archive: var ', var (1,jmold+1,1)  ! INFO
+      call interp_horiz(var,t,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'lect_start_archive: t ', t(1,jjp1,1)  ! INFO
+
+c q2 : pbl wind variance
+      write (*,*) 'lect_start_archive: q2old ', q2old (1,2,1)  ! INFO
+      call interp_vert (q2old,varp1,lmold+1,llm+1,
+     &     apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+      write (*,*) 'lect_start_archive: varp1 ', varp1 (1,2,1)  ! INFO
+      call interp_horiz(varp1,q2s,imold,jmold,iim,jjm,llm+1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'lect_start_archive: q2s ', q2s (1,2,1)  ! INFO
+      call gr_dyn_fi (llm+1,iim+1,jjm+1,ngridmx,q2s,q2)
+      write (*,*) 'lect_start_archive: q2 ', q2 (1,2)  ! INFO
+c     write(47,*) 'q2',q2
+
+c calcul des champ de vent; passage en vent covariant
+      write (*,*) 'lect_start_archive: uold ', uold (1,2,1)  ! INFO
+      call interp_vert
+     & (uold,var,lmold,llm,apsold,bpsold,aps,bps,
+     &  psold,(imold+1)*(jmold+1))
+      write (*,*) 'lect_start_archive: var ', var (1,2,1)  ! INFO
+      call interp_horiz(var,us,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'lect_start_archive: us ', us (1,2,1)   ! INFO
+
+      call interp_vert
+     & (vold,var,lmold,llm,
+     &  apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+      call interp_horiz(var,vs,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call scal_wind(us,vs,unat,vnat)
+      write (*,*) 'lect_start_archive: unat ', unat (1,2,1)    ! INFO
+      do l=1,llm
+        do j = 1, jjp1
+          do i=1,iip1
+            ucov( i,j,l ) = unat( i,j,l ) * cu(i,j)
+c           ucov( i,j,l ) = 0
+          end do
+        end do
+      end do 
+      write (*,*) 'lect_start_archive: ucov ', ucov (1,2,1)  ! INFO
+c     write(48,*) 'ucov',ucov
+      do l=1,llm
+        do j = 1, jjm
+          do i=1,iim
+            vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j)
+c           vcov( i,j,l ) = 0
+          end do
+          vcov( iip1,j,l ) = vcov( 1,j,l )
+        end do
+      end do
+c     write(49,*) 'ucov',vcov
+
+      if (nqtot .gt. 0) then
+c traceurs surface
+      do iq = 1, nqtot
+            call interp_horiz(qsurfold(1,1,iq) ,qsurfs(1,1,iq),
+     &                  imold,jmold,iim,jjm,1,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+      enddo
+
+      call gr_dyn_fi (nqtot,iim+1,jjm+1,ngridmx,qsurfs,qsurf)
+
+c traceurs 3D
+      do  iq = 1, nqtot
+            call interp_vert(qold(1,1,1,iq),var,lmold,llm,
+     &        apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+            call interp_horiz(var,q(1,1,1,iq),imold,jmold,iim,jjm,llm,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+      enddo
+cccccccccccccccccccccccccccccc      
+c  make sure that sum of q = 1      
+c dominent species is = 1 - sum(all other species)      
+cccccccccccccccccccccccccccccc      
+c      iqmax=1
+c      
+c      if (nqold.gt.10) then
+c       do l=1,llm
+c        do j=1,jjp1
+c          do i=1,iip1
+c           do iq=1,nqold
+c            if (q(i,j,l,iq).gt.q(i,j,l,iqmax)) then
+c              iqmax=iq
+c            endif
+c           enddo
+c           q(i,j,l,iqmax)=1.
+c           qtot(i,j,l)=0
+c           do iq=1,nqold
+c            if (iq.ne.iqmax) then        
+c              q(i,j,l,iqmax)=q(i,j,l,iqmax)-q(i,j,l,iq)        
+c            endif
+c           enddo !iq
+c           do iq=1,nqold
+c            qtot(i,j,l)=qtot(i,j,l)+q(i,j,l,iq)
+c            if (i.eq.1.and.j.eq.1.and.l.Eq.1) write(*,*)' qtot(i,j,l)',
+c     $    qtot(i,j,l)
+c           enddo !iq
+c          enddo !i   
+c         enddo !j   
+c       enddo !l  
+c      endif
+ccccccccccccccccccccccccccccccc
+
+c     Periodicite :
+      do  iq = 1, nqtot
+         do l=1, llm
+            do j = 1, jjp1
+               q(iip1,j,l,iq) = q(1,j,l,iq)
+            end do
+         end do
+      enddo
+      
+!      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,co2ices,co2ice)
+! no need to transfer "co2ice" any more; it is in qsurf(igcm_co2_ice)
+
+      endif !! if nqtot .ne. 0
+
+c-----------------------------------------------------------------------
+c   Initialisation  h:	(passage de t -> h)
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+         DO j=1,jjp1
+            DO i=1,iim
+               h(i,j,l) = t(i,j,l)*((ps(i,j)/preff)**kappa)
+            END DO
+            h(iip1,j,l) =  h(1,j,l)
+         END DO
+      END DO
+
+
+c***********************************************************************
+c***********************************************************************
+c     Fin subroutine lecture ini
+c***********************************************************************
+c***********************************************************************
+
+      deallocate(timelist)
+      deallocate(rlonuold, rlatvold)
+      deallocate(rlonvold, rlatuold)
+      deallocate(apsold,bpsold)
+      deallocate(uold)
+      deallocate(vold)
+      deallocate(told)
+      deallocate(psold)
+      deallocate(phisold)
+      deallocate(qold)
+      deallocate(co2iceold)
+      deallocate(tsurfold)
+      deallocate(emisold)
+      deallocate(q2old)
+      deallocate(tsoilold)
+      deallocate(tsoiloldnew)
+      deallocate(inertiedatold)
+      deallocate(inertiedatoldnew)
+      deallocate(surfithold)
+      deallocate(mlayerold)
+      deallocate(qsurfold)
+      deallocate(var,varp1)
+      deallocate(tslabold)
+      deallocate(rnatold)
+      deallocate(pctsrf_sicold)
+      deallocate(tsea_iceold)
+      deallocate(sea_iceold)
+
+!      write(*,*)'lect_start_archive: END'
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mass_redistribution.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mass_redistribution.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mass_redistribution.F90	(revision 222)
@@ -0,0 +1,405 @@
+      SUBROUTINE mass_redistribution(ngrid,nlayer,nq,ptimestep,   &
+                       rnat,pcapcal,pplay,pplev,pt,ptsrf,pq,pqs,     &
+		       pu,pv,pdt,pdtsrf,pdq,pdu,pdv,pdmassmr,  &
+		       pdtmr,pdtsrfmr,pdpsrfmr,pdumr,pdvmr,pdqmr,pdqsmr)
+                                                   
+       USE watercommon_h, Only: Tsat_water,RLVTT
+       use surfdat_h
+       use radcommon_h, only: glat
+       USE comgeomfi_h
+       USE tracer_h
+
+       IMPLICIT NONE
+!=======================================================================
+!   subject:
+!   --------
+!     Mass and momentum fluxes through sigma levels as the surface pressure is modified are also taken into account
+!
+!   author:   Jeremy Leconte 2012 (from F.Forget 1998)
+!   ------
+!
+!   input:
+!   ----- 
+!    ngrid                 nombre de points de verticales
+!                          (toutes les boucles de la physique sont au
+!                          moins vectorisees sur ngrid)
+!    nlayer                nombre de couches
+!    pplay(ngrid,nlayer)   Pressure levels 
+!    pplev(ngrid,nlayer+1) Pressure levels 
+!    nq                    Number of tracers
+!
+!    pt(ngrid,nlayer)      temperature (en K)
+!    pq(ngrid,nlayer,nq)   tracer specific concentration (kg/kg of air)
+!    pu,pv (ngrid,nlayer)  wind velocity (m/s)
+!
+!                    
+!    pdX                   physical tendency of X before mass redistribution
+!
+!    pdmassmr                air Mass added to the atmosphere in each layer (kg/m2/s)
+!
+!   output:
+!   -------
+!
+!    pdXmr(ngrid)           physical tendency of X after mass redistribution
+!
+!    
+!
+!=======================================================================
+!
+!    0.  Declarations :
+!    ------------------
+!
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "comvert.h"
+#include "paramet.h"
+#include "callkeys.h"
+
+!-----------------------------------------------------------------------
+!    Arguments :
+!    ---------
+      INTEGER ngrid, nlayer, nq   
+      REAL ptimestep
+      REAL pcapcal(ngrid)
+      INTEGER rnat(ngrid)      
+      REAL pplay(ngrid,nlayer),pplev(ngrid,nlayer+1)
+      REAL pt(ngrid,nlayer),pdt(ngrid,nlayer)
+      REAL ptsrf(ngrid),pdtsrf(ngrid)
+      REAL pdtmr(ngrid,nlayer)
+      REAL pu(ngrid,nlayer) ,  pv(ngrid,nlayer)
+      REAL pdu(ngrid,nlayer) , pdv(ngrid,nlayer)
+      REAL pdmassmr(ngrid,nlayer)
+      REAL pdumr(ngrid,nlayer) , pdvmr(ngrid,nlayer)
+      REAL pq(ngrid,nlayer,nq),pdq(ngrid,nlayer,nq)
+      REAL pqs(ngrid,nq)
+      REAL pdqmr(ngrid,nlayer,nq),pdqsmr(ngrid,nq)
+      REAL pdpsrfmr(ngrid),pdtsrfmr(ngrid)
+!
+!    Local variables :
+!    -----------------
+
+!    Boiling/sublimation
+      REAL Tsat(ngrid),zmassboil(ngrid)
+
+!    vertical reorganization of sigma levels
+      REAL zzu(nlayermx),zzv(nlayermx)
+      REAL zzq(nlayermx,nq),zzt(nlayermx)
+!    Dummy variables      
+      INTEGER n,l,ig,iq
+      REAL zdtsig(ngrid,nlayermx)
+      REAL zmass(ngrid,nlayermx),zzmass(nlayermx),w(nlayermx+1)
+      REAL zdmass_sum(ngrid,nlayermx+1)
+      REAL zmflux(nlayermx+1)
+      REAL zq1(nlayermx)
+      REAL ztsrf(ngrid)
+      REAL ztm(nlayermx+1) 
+      REAL zum(nlayermx+1) , zvm(nlayermx+1)
+      REAL zqm(nlayermx+1,nq),zqm1(nlayermx+1)
+
+!   local saved variables
+      LOGICAL, SAVE :: firstcall=.true.
+
+!----------------------------------------------------------------------
+
+!   Initialisation
+!   --------------
+!
+      IF (firstcall) THEN
+         firstcall=.false.	 
+      ENDIF
+!
+!======================================================================
+!    Calcul of h2o condensation  
+!    ============================================================
+!  
+!    Used variable :
+!       pdmassmr      : air Mass added to the atmosphere in each layer per unit time (kg/m2/s)
+!       zdmass_sum(ngrid,l) : total air mass added to the atm above layer l per unit time (kg/m2/s)
+!
+!
+!     Surface tracer Tendencies set to 0
+!     -------------------------------------
+      pdqsmr(1:ngrid,1:nq)=0.
+
+      ztsrf(1:ngrid) = ptsrf(1:ngrid) + pdtsrf(1:ngrid)*ptimestep
+
+
+      DO ig=1,ngrid
+         zdmass_sum(ig,nlayermx+1)=0.
+         DO l = nlayermx, 1, -1
+           zmass(ig,l) = (pplev(ig,l)-pplev(ig,l+1))/glat(ig)
+	   zdmass_sum(ig,l)= zdmass_sum(ig,l+1)+pdmassmr(ig,l)
+         END DO
+      END DO
+
+
+      if (water) then
+         do ig=1,ngrid
+	    call Tsat_water(pplev(ig,1)+zdmass_sum(ig,1)*g*ptimestep,Tsat(ig))
+	 enddo
+               call writediagfi(ngrid,'Tsat','saturation temperature at surface','',2,Tsat)
+	 
+         do ig=1,ngrid
+	    if (ztsrf(ig).gt.Tsat(ig)) then
+	       zmassboil(ig)=(ptsrf(ig)-Tsat(ig))*pcapcal(ig)/RLVTT/ptimestep
+	       if ((zmassboil(ig)*ptimestep.gt.pqs(ig,igcm_h2o_vap)).and.(rnat(ig).eq.1)) then
+	          zmassboil(ig)=pqs(ig,igcm_h2o_vap)/ptimestep
+	       endif
+	       zmassboil(ig)=zmassboil(ig)*0.0 !momentary, should be 1. JL12
+               pdqsmr(ig,igcm_h2o_vap)=-zmassboil(ig)
+	       pdtsrfmr(ig)=-zmassboil(ig)*RLVTT/pcapcal(ig)
+	       ztsrf(ig)=ptsrf(ig)+pdtsrfmr(ig)*ptimestep
+	    else
+	       zmassboil(ig)=0.
+	       pdtsrfmr(ig)=0.
+	    endif
+	 enddo
+      endif
+
+!     *************************
+!           UPDATE SURFACE
+!     *************************
+!    Changing pressure at the surface:
+!    """"""""""""""""""""""""""""""""""""
+         
+      pdpsrfmr(1:ngrid) = (zdmass_sum(1:ngrid,1)+zmassboil(1:ngrid))*g
+
+      do ig = 1, ngrid
+        IF(ABS(pdpsrfmr(ig)*ptimestep).GT.pplev(ig,1)) THEN
+         PRINT*,'STOP in condens'
+         PRINT*,'condensing more than total mass'
+         PRINT*,'Grid point ',ig
+         PRINT*,'Ps = ',pplev(ig,1)
+         PRINT*,'d Ps = ',pdpsrfmr(ig)*ptimestep
+         STOP
+        ENDIF
+      enddo ! of DO ig=1,ngrid
+
+
+! ***************************************************************
+!  Correction to account for redistribution between sigma or hybrid 
+!  layers when changing surface pressure
+!  zzx quantities have dimension (nlayermx) to speed up calculation
+! *************************************************************
+
+      DO ig=1,ngrid
+         zzt(1:nlayermx)  = pt(ig,1:nlayermx) + pdt(ig,1:nlayermx) * ptimestep
+         zzu(1:nlayermx)  = pu(ig,1:nlayermx) + pdu(ig,1:nlayermx) * ptimestep
+         zzv(1:nlayermx)  = pv(ig,1:nlayermx) + pdv(ig,1:nlayermx) * ptimestep
+         zzq(1:nlayermx,1:nq)=pq(ig,1:nlayermx,1:nq)+pdq(ig,1:nlayermx,1:nq)*ptimestep ! must add the water that has fallen???
+
+!  Mass fluxes of air through the sigma levels (kg.m-2.s-1)  (>0 when up)
+!  """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
+
+         zmflux(1) = zmassboil(ig)
+         DO l=1,nlayer
+            zmflux(l+1) = zmflux(l) + pdmassmr(ig,l) - (bp(l)-bp(l+1))*(zdmass_sum(ig,1)+zmflux(1))
+! zmflux set to 0 if very low to avoid: top layer is disappearing in v1ld  
+            if (abs(zmflux(l+1)).lt.1E-13.OR.bp(l+1).eq.0.) zmflux(l+1)=0.
+         END DO
+
+! Mass of each layer
+! ------------------ 
+         zzmass(1:nlayermx)=zmass(ig,1:nlayermx)*(1.+pdpsrfmr(ig)*ptimestep/pplev(ig,1))
+
+
+!  Corresponding fluxes for T,U,V,Q
+!  """"""""""""""""""""""""""""""""
+
+!        averaging operator for TRANSPORT  
+!        """"""""""""""""""""""""""""""""
+!        Value transfert at the surface interface when condensation
+!        sublimation:
+         ztm(1) = ztsrf(ig)
+         zum(1) = 0.  
+         zvm(1) = 0.  
+         zqm(1,1:nq)=0. ! most tracer do not condense !
+         if (water) zqm(1,igcm_h2o_vap)=1. ! flux is 100% h2o at surface
+	 
+!        Van Leer scheme:
+         w(1:nlayermx+1)=-zmflux(1:nlayermx+1)*ptimestep
+         call vl1d(zzt,2.,zzmass,w,ztm) 
+         call vl1d(zzu ,2.,zzmass,w,zum) 
+         call vl1d(zzv ,2.,zzmass,w,zvm) 
+         do iq=1,nq
+           zq1(1:nlayermx)=zzq(1:nlayermx,iq)
+           zqm1(1)=zqm(1,iq)
+!		print*,iq
+!		print*,zq1
+           call vl1d(zq1,2.,zzmass,w,zqm1)
+           do l=2,nlayer
+              zzq(l,iq)=zq1(l)
+              zqm(l,iq)=zqm1(l)
+           enddo
+         enddo
+
+!        Surface condensation affects low winds
+         if (zmflux(1).lt.0) then 
+            zum(1)= zzu(1) *  (w(1)/zzmass(1))
+            zvm(1)= zzv(1) *  (w(1)/zzmass(1))
+            if (w(1).gt.zzmass(1)) then ! ensure numerical stability
+               zum(1)= (zzu(1)-zum(2))*zzmass(1)/w(1) + zum(2)
+               zvm(1)= (zzv(1)-zvm(2))*zzmass(1)/w(1) + zvm(2)
+            end if
+         end if
+                    
+         ztm(nlayer+1)= zzt(nlayer) ! should not be used, but... 
+         zum(nlayer+1)= zzu(nlayer)  ! should not be used, but...
+         zvm(nlayer+1)= zzv(nlayer)  ! should not be used, but...
+         zqm(nlayer+1,1:nq)= zzq(nlayer,1:nq)
+ 
+!        Tendencies on T, U, V, Q 
+!        """"""""""""""""""""""""
+         DO l=1,nlayer
+ 
+!           Tendencies on T
+            pdtmr(ig,l) = (1/zzmass(l)) *   &
+		(zmflux(l)*(ztm(l) - zzt(l))-zmflux(l+1)*(ztm(l+1)-zzt(l)))
+		  !JL12 the last term in Newcondens has been set to zero because we are only dealing with redistribution here
+
+!           Tendencies on U
+            pdumr(ig,l)   = (1/zzmass(l)) *( zmflux(l)*(zum(l) - zzu(l)) - zmflux(l+1)*(zum(l+1) - zzu(l)) )
+
+!           Tendencies on V
+            pdvmr(ig,l)   = (1/zzmass(l)) *( zmflux(l)*(zvm(l) - zzv(l)) - zmflux(l+1)*(zvm(l+1) - zzv(l)) )
+
+         END DO
+
+!        Tendencies on Q
+         do iq=1,nq
+            DO l=1,nlayer
+               pdqmr(ig,l,iq)= (1/zzmass(l)) *   &
+		   (zmflux(l)*(zqm(l,iq)-zzq(l,iq))- zmflux(l+1)*(zqm(l+1,iq)-zzq(l,iq)) - pdmassmr(ig,l)*zzq(l,iq))
+            END DO
+         enddo
+
+      END DO  ! loop on ig 
+
+      return
+      end
+
+
+
+! *****************************************************************
+      SUBROUTINE vl1d(q,pente_max,zzmass,w,qm)
+!
+!    
+!     Operateur de moyenne inter-couche pour calcul de transport type
+!     Van-Leer " pseudo amont " dans la verticale
+!    q,w sont des arguments d'entree  pour le s-pg ....
+!    masse : masse de la couche Dp/g
+!    w : masse d'atm ``transferee'' a chaque pas de temps (kg.m-2)
+!    pente_max = 2 conseillee
+!
+!
+!   --------------------------------------------------------------------
+      IMPLICIT NONE
+
+#include "dimensions.h"
+
+!   Arguments:
+!   ----------
+      real zzmass(llm),pente_max
+      REAL q(llm),qm(llm+1)
+      REAL w(llm+1)
+!
+!      Local 
+!   ---------
+!
+      INTEGER l
+!
+      real dzq(llm),dzqw(llm),adzqw(llm),dzqmax
+      real sigw, Mtot, MQtot
+      integer m 
+!     integer ismax,ismin 
+
+
+!    On oriente tout dans le sens de la pression 
+!     W > 0 WHEN DOWN !!!!!!!!!!!!!
+
+      do l=2,llm
+            dzqw(l)=q(l-1)-q(l)
+            adzqw(l)=abs(dzqw(l))
+      enddo
+
+      do l=2,llm-1
+            if(dzqw(l)*dzqw(l+1).gt.0.) then
+                dzq(l)=0.5*(dzqw(l)+dzqw(l+1))
+            else
+                dzq(l)=0.
+            endif
+            dzqmax=pente_max*min(adzqw(l),adzqw(l+1))
+            dzq(l)=sign(min(abs(dzq(l)),dzqmax),dzq(l))
+      enddo
+
+         dzq(1)=0.
+         dzq(llm)=0.
+
+       do l = 1,llm-1
+
+!         Regular scheme (transfered mass < layer mass)
+!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(w(l+1).gt.0. .and. w(l+1).le.zzmass(l+1)) then
+             sigw=w(l+1)/zzmass(l+1)
+             qm(l+1)=(q(l+1)+0.5*(1.-sigw)*dzq(l+1))
+          else if(w(l+1).le.0. .and. -w(l+1).le.zzmass(l)) then
+             sigw=w(l+1)/zzmass(l)
+             qm(l+1)=(q(l)-0.5*(1.+sigw)*dzq(l))
+
+!         Extended scheme (transfered mass > layer mass)
+!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          else if(w(l+1).gt.0.) then
+             m=l+1
+             Mtot = zzmass(m)
+             MQtot = zzmass(m)*q(m)
+             do while ((m.lt.llm).and.(w(l+1).gt.(Mtot+zzmass(m+1))))
+                m=m+1
+                Mtot = Mtot + zzmass(m)
+                MQtot = MQtot + zzmass(m)*q(m)
+             end do
+             if (m.lt.llm) then
+                sigw=(w(l+1)-Mtot)/zzmass(m+1)
+                qm(l+1)= (1/w(l+1))*(MQtot + (w(l+1)-Mtot)*(q(m+1)+0.5*(1.-sigw)*dzq(m+1)) )
+             else
+!                w(l+1) = Mtot
+!                qm(l+1) = Mqtot / Mtot
+                write(*,*) 'top layer is disappearing !',l,Mtot,w(l+1),qm(l+1)
+		print*,zzmass
+ 		print*,w
+		print*,q
+		print*,qm
+               stop
+             end if
+          else      ! if(w(l+1).lt.0) 
+             m = l-1 
+             Mtot = zzmass(m+1)
+             MQtot = zzmass(m+1)*q(m+1)
+             if (m.gt.0) then ! because some compilers will have problems
+                              ! evaluating zzmass(0)
+              do while ((m.gt.0).and.(-w(l+1).gt.(Mtot+zzmass(m))))
+                m=m-1
+                Mtot = Mtot + zzmass(m+1)
+                MQtot = MQtot + zzmass(m+1)*q(m+1)
+                if (m.eq.0) exit
+              end do
+             endif
+             if (m.gt.0) then
+                sigw=(w(l+1)+Mtot)/zzmass(m)
+                qm(l+1)= (-1/w(l+1))*(MQtot + (-w(l+1)-Mtot)*(q(m)-0.5*(1.+sigw)*dzq(m))  )
+             else
+                qm(l+1)= (-1/w(l+1))*(MQtot + (-w(l+1)-Mtot)*qm(1))
+             end if   
+          end if
+       enddo
+
+!     boundary conditions (not used in newcondens !!)
+!         qm(llm+1)=0.
+!         if(w(1).gt.0.) then
+!            qm(1)=q(1)
+!         else 
+!           qm(1)=0.
+!         end if
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mkstat.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mkstat.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mkstat.F90	(revision 222)
@@ -0,0 +1,170 @@
+subroutine mkstats(ierr)
+
+ 
+!
+!  This program writes a stats.nc file from sums and sums of squares
+!  to means and standard deviations and also writes netcdf style
+!  file so that the data can be viewed easily.  The data file is
+!  overwritten in place.  
+!  SRL  21 May 1996
+!  Yann W. july 2003
+
+use mod_phys_lmdz_para, only : is_master
+
+implicit none
+
+#include "dimensions.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+integer :: ierr,nid,nbvar,i,ndims,lt,nvarid
+integer, dimension(4) :: id,varid,start,size
+integer, dimension(5) :: dimids
+character (len=50) :: name,nameout,units,title
+real, dimension(iip1,jjp1,llm) :: sum3d,square3d,mean3d,sd3d
+real, dimension(iip1,jjp1) :: sum2d,square2d,mean2d,sd2d
+real, dimension(istime) :: time
+real, dimension(jjp1) :: lat
+real, dimension(iip1) :: lon
+real, dimension(llm) :: alt
+logical :: lcopy=.true.
+!integer :: latid,lonid,altid,timeid
+integer :: meanid,sdid
+!integer, dimension(4) :: dimout
+
+! Incrementation of count for the last step, which is not done in wstats
+count(istime)=count(istime)+1
+
+if (is_master) then
+! only the master needs do this
+
+ierr = NF_OPEN("stats.nc",NF_WRITE,nid)
+
+! We catch the id of dimensions of the stats file
+
+ierr= NF_INQ_DIMID(nid,"latitude",id(1))
+ierr= NF_INQ_DIMID(nid,"longitude",id(2))
+ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+ierr= NF_INQ_VARID(nid,"latitude",varid(1))
+ierr= NF_INQ_VARID(nid,"longitude",varid(2))
+ierr= NF_INQ_VARID(nid,"altitude",varid(3))
+ierr= NF_INQ_VARID(nid,"Time",varid(4))
+
+! Time initialisation
+
+do i=1,istime
+   time(i)=i*24./istime
+#ifdef NC_DOUBLE
+   ierr= NF_PUT_VARA_DOUBLE(nid,varid(4),i,1,time(i))
+#else
+   ierr= NF_PUT_VARA_REAL(nid,varid(4),i,1,time(i))
+#endif
+enddo
+
+! We catche the values of the variables
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(1),lat)
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(2),lon)
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(3),alt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,varid(1),lat)
+         ierr = NF_GET_VAR_REAL(nid,varid(2),lon)
+         ierr = NF_GET_VAR_REAL(nid,varid(3),alt)
+#endif
+
+! We catch the number of variables in the stats file
+ierr = NF_INQ_NVARS(nid,nbvar)
+
+! to catche the "real" number of variables (without the "additionnal variables")
+nbvar=(nbvar-4)/2 
+
+do i=1,nbvar
+   varid=(i-1)*2+5
+
+   ! What's the variable's name?
+   ierr=NF_INQ_VARNAME(nid,varid,name)
+   write(*,*) "OK variable ",name
+   ! Its units?
+   units=" "
+   ierr=NF_GET_ATT_TEXT(nid,varid,"units",units)
+   ! Its title?
+   title=" "
+   ierr=NF_GET_ATT_TEXT(nid,varid,"title",title)
+   ! Its number of dimensions?   
+   ierr=NF_INQ_VARNDIMS(nid,varid,ndims)
+   ! Its values?
+
+   if(ndims==4) then ! lat, lon, alt & time
+
+!      dimout(1)=lonid
+!      dimout(2)=latid
+!      dimout(3)=altid
+!      dimout(4)=timeid
+
+      size=(/iip1,jjp1,llm,1/)
+      do lt=1,istime
+         start=(/1,1,1,lt/)
+         ! Extraction of the "source" variables
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum3d)
+         ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square3d)
+#else
+         ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum3d)
+         ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square3d)
+#endif
+         ! Calculation of these variables
+         mean3d=sum3d/count(lt)
+         sd3d=sqrt(max(0.,square3d/count(lt)-mean3d**2))
+         ! Writing of the variables
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean3d)
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd3d)
+#else
+         ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean3d)
+         ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd3d)
+#endif
+      enddo
+
+    else if (ndims.eq.3) then
+
+!      dimout(1)=lonid
+!      dimout(2)=latid
+!      dimout(3)=timeid
+
+      size=(/iip1,jjp1,1,0/)
+      do lt=1,istime
+         start=(/1,1,lt,0/)
+         ! Extraction of the "source" variables
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum2d)
+         ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square2d)
+#else
+         ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum2d)
+         ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square2d)
+#endif
+         ! Calculation of these variables
+         mean2d=sum2d/count(lt)
+         sd2d=sqrt(max(0.,square2d/count(lt)-mean2d**2))
+         ! Writing of the variables
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean2d)
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd2d)
+#else
+         ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean2d)
+         ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd2d)
+#endif
+      enddo
+
+    endif 
+enddo
+
+ierr= NF_CLOSE(nid)
+
+endif ! of if (is_master)
+
+end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_grid_phy_lmdz.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_grid_phy_lmdz.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_grid_phy_lmdz.F90	(revision 222)
@@ -0,0 +1,454 @@
+!
+!$Header$
+!
+MODULE mod_grid_phy_lmdz
+
+  PUBLIC
+  PRIVATE :: grid1dTo2d_glo_igen, grid1dTo2d_glo_rgen, grid1dTo2d_glo_lgen, &
+             grid2dTo1d_glo_igen, grid2dTo1d_glo_rgen, grid2dTo1d_glo_lgen
+
+  INTEGER,SAVE :: nbp_lon  ! == iim
+  INTEGER,SAVE :: nbp_lat  ! == jjmp1
+  INTEGER,SAVE :: nbp_lev  ! == llm
+  INTEGER,SAVE :: klon_glo
+
+  INTERFACE grid1dTo2d_glo
+    MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, &
+                     grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, &
+		     grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3
+   END INTERFACE 
+
+   INTERFACE grid2dTo1d_glo
+    MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, &
+                     grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, &
+		     grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3
+   END INTERFACE 
+ 
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE init_grid_phy_lmdz(iim,jjp1,nbp,llm)
+  IMPLICIT NONE
+  INTEGER, INTENT(in) :: iim
+  INTEGER, INTENT(in) :: jjp1
+  INTEGER, INTENT(in) :: nbp
+  INTEGER, INTENT(in) :: llm
+  
+    nbp_lon=iim
+    nbp_lat=jjp1
+    nbp_lev=llm
+    klon_glo=nbp
+  
+  ! Ehouarn: handle 1D case:
+  if ((iim.eq.1).and.(jjp1.eq.2)) then
+    nbp_lat=1
+    klon_glo=1
+  endif
+  
+  END SUBROUTINE init_grid_phy_lmdz
+  
+  
+  SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_i
+  
+
+  SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_i1
+
+  SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_i2
+  
+  SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_i3
+
+
+  SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_r
+  
+
+  SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_r1
+
+  SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_r2
+  
+  SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_l
+  
+
+  SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_l1
+
+  SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_l2
+  
+  SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_l3  
+  
+    SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_i
+  
+
+  SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_i1
+
+  SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_i2
+  
+  SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_r
+  
+
+  SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_r1
+
+  SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_r2
+  
+  SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_r3
+
+
+
+  SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_l
+  
+
+  SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_l1
+
+  SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_l2
+  
+  SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_l3
+
+!---------------------------------------------------------------- 
+!  fonctions generiques (privees)
+!---------------------------------------------------------------- 
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_igen   
+
+
+  SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+   
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_rgen   
+
+  SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_lgen     
+  
+  
+  SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_igen   
+  
+  SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_rgen 
+    
+  SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_lgen   
+
+END MODULE mod_grid_phy_lmdz
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_grid_phy_lmdz.F90.orig
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_grid_phy_lmdz.F90.orig	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_grid_phy_lmdz.F90.orig	(revision 222)
@@ -0,0 +1,453 @@
+!
+!$Header$
+!
+MODULE mod_grid_phy_lmdz
+
+  PUBLIC
+  PRIVATE :: grid1dTo2d_glo_igen, grid1dTo2d_glo_rgen, grid1dTo2d_glo_lgen, &
+             grid2dTo1d_glo_igen, grid2dTo1d_glo_rgen, grid2dTo1d_glo_lgen
+
+  INTEGER,SAVE :: nbp_lon  ! == iim
+  INTEGER,SAVE :: nbp_lat  ! == jjmp1
+  INTEGER,SAVE :: nbp_lev  ! == llm
+  INTEGER,SAVE :: klon_glo
+
+  INTERFACE grid1dTo2d_glo
+    MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, &
+                     grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, &
+		     grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3
+   END INTERFACE 
+
+   INTERFACE grid2dTo1d_glo
+    MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, &
+                     grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, &
+		     grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3
+   END INTERFACE 
+ 
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE init_grid_phy_lmdz(iim,jjp1,llm)
+  IMPLICIT NONE
+  INTEGER, INTENT(in) :: iim
+  INTEGER, INTENT(in) :: jjp1
+  INTEGER, INTENT(in) :: llm
+  
+    nbp_lon=iim
+    nbp_lat=jjp1
+    nbp_lev=llm
+    klon_glo=(iim*jjp1)-2*(iim-1)
+  
+  ! Ehouarn: handle 1D case:
+  if ((iim.eq.1).and.(jjp1.eq.2)) then
+    nbp_lat=1
+    klon_glo=1
+  endif
+  
+  END SUBROUTINE init_grid_phy_lmdz
+  
+  
+  SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_i
+  
+
+  SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_i1
+
+  SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_i2
+  
+  SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_i3
+
+
+  SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_r
+  
+
+  SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_r1
+
+  SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_r2
+  
+  SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_l
+  
+
+  SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_l1
+
+  SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_l2
+  
+  SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_l3  
+  
+    SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_i
+  
+
+  SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_i1
+
+  SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_i2
+  
+  SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_r
+  
+
+  SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_r1
+
+  SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_r2
+  
+  SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_r3
+
+
+
+  SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_l
+  
+
+  SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_l1
+
+  SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_l2
+  
+  SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_l3
+
+!---------------------------------------------------------------- 
+!  fonctions generiques (privees)
+!---------------------------------------------------------------- 
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_igen   
+
+
+  SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+   
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_rgen   
+
+  SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_lgen     
+  
+  
+  SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_igen   
+  
+  SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_rgen 
+    
+  SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_lgen   
+
+END MODULE mod_grid_phy_lmdz
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_data.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_data.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_data.F90	(revision 222)
@@ -0,0 +1,212 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_mpi_data
+  USE mod_const_mpi, only: MPI_REAL_LMDZ, COMM_LMDZ
+  
+  INTEGER,SAVE :: ii_begin
+  INTEGER,SAVE :: ii_end
+  INTEGER,SAVE :: jj_begin
+  INTEGER,SAVE :: jj_end
+  INTEGER,SAVE :: jj_nb
+  INTEGER,SAVE :: ij_begin
+  INTEGER,SAVE :: ij_end
+  INTEGER,SAVE :: ij_nb
+  INTEGER,SAVE :: klon_mpi_begin
+  INTEGER,SAVE :: klon_mpi_end
+  INTEGER,SAVE :: klon_mpi
+  
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end 
+
+  
+  INTEGER,SAVE :: mpi_rank
+  INTEGER,SAVE :: mpi_size
+  INTEGER,SAVE :: mpi_root
+  LOGICAL,SAVE :: is_mpi_root
+  LOGICAL,SAVE :: is_using_mpi
+  
+  
+  LOGICAL,SAVE :: is_north_pole
+  LOGICAL,SAVE :: is_south_pole
+  INTEGER,SAVE :: COMM_LMDZ_PHY
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+  USE mod_const_mpi, ONLY : COMM_LMDZ
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+    
+    INTEGER :: ierr
+    INTEGER :: klon_glo
+    INTEGER :: i
+    
+#ifdef CPP_MPI
+    is_using_mpi=.TRUE.
+#else
+    is_using_mpi=.FALSE.
+#endif
+    
+    if (iim.eq.1) then
+       klon_glo=1
+    else
+!       klon_glo=iim*(jjp1-2)+2
+       klon_glo=sum(distrib)
+    endif
+    
+    COMM_LMDZ_PHY=COMM_LMDZ
+
+    IF (is_using_mpi) THEN    
+#ifdef CPP_MPI
+      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
+      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
+#endif
+    ELSE
+      mpi_size=1
+      mpi_rank=0
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN
+      mpi_root = 0
+      is_mpi_root = .true.
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN 
+      is_north_pole = .TRUE.
+    ELSE
+      is_north_pole = .FALSE.
+    ENDIF
+    
+    IF (mpi_rank == mpi_size-1) THEN
+      is_south_pole = .TRUE.
+    ELSE
+      is_south_pole = .FALSE.
+    ENDIF
+    
+    ALLOCATE(jj_para_nb(0:mpi_size-1))
+    ALLOCATE(jj_para_begin(0:mpi_size-1))
+    ALLOCATE(jj_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ij_para_nb(0:mpi_size-1))
+    ALLOCATE(ij_para_begin(0:mpi_size-1))
+    ALLOCATE(ij_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ii_para_begin(0:mpi_size-1))
+    ALLOCATE(ii_para_end(0:mpi_size-1))
+
+    ALLOCATE(klon_mpi_para_nb(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_begin(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_end(0:mpi_size-1))
+  
+      
+    klon_mpi_para_nb(0:mpi_size-1)=distrib(0:nb_proc-1)
+
+    DO i=0,mpi_size-1
+      IF (i==0) THEN 
+        klon_mpi_para_begin(i)=1
+      ELSE 
+        klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1
+      ENDIF
+        klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1
+    ENDDO
+
+
+    DO i=0,mpi_size-1
+      
+      IF (i==0) THEN
+        ij_para_begin(i) = 1
+      ELSE
+        ij_para_begin(i) = klon_mpi_para_begin(i)+iim-1
+      ENDIF
+
+      jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1
+      ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1
+
+      
+      ij_para_end(i) = klon_mpi_para_end(i)+iim-1
+      jj_para_end(i) = (ij_para_end(i)-1)/iim + 1
+      ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 1
+
+      ! Ehouarn: handle 1D case:
+      if (klon_glo.eq.1) then
+        klon_mpi_para_end(i) = 1
+        klon_mpi_para_nb(i) = 1
+        ij_para_end(i) = 1
+        jj_para_end(i) = 1
+        ii_para_end(i) = 1
+      endif
+
+      ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1
+      jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1
+         
+    ENDDO
+  
+    ii_begin = ii_para_begin(mpi_rank)
+    ii_end   = ii_para_end(mpi_rank)
+    jj_begin = jj_para_begin(mpi_rank)
+    jj_end   = jj_para_end(mpi_rank)
+    jj_nb    = jj_para_nb(mpi_rank)
+    ij_begin = ij_para_begin(mpi_rank)
+    ij_end   = ij_para_end(mpi_rank)
+    ij_nb    = ij_para_nb(mpi_rank)
+    klon_mpi_begin = klon_mpi_para_begin(mpi_rank)
+    klon_mpi_end   = klon_mpi_para_end(mpi_rank)
+    klon_mpi       = klon_mpi_para_nb(mpi_rank)
+   
+    CALL Print_module_data
+    
+  END SUBROUTINE Init_phys_lmdz_mpi_data
+
+  SUBROUTINE print_module_data
+  IMPLICIT NONE
+!  INCLUDE "iniprint.h" 
+  
+    WRITE(*,*) 'ii_begin =', ii_begin
+    WRITE(*,*) 'ii_end =', ii_end
+    WRITE(*,*) 'jj_begin =',jj_begin
+    WRITE(*,*) 'jj_end =', jj_end
+    WRITE(*,*) 'jj_nb =', jj_nb
+    WRITE(*,*) 'ij_begin =', ij_begin
+    WRITE(*,*) 'ij_end =', ij_end
+    WRITE(*,*) 'ij_nb =', ij_nb
+    WRITE(*,*) 'klon_mpi_begin =', klon_mpi_begin
+    WRITE(*,*) 'klon_mpi_end =', klon_mpi_end
+    WRITE(*,*) 'klon_mpi =', klon_mpi
+    WRITE(*,*) 'jj_para_nb =', jj_para_nb
+    WRITE(*,*) 'jj_para_begin =', jj_para_begin
+    WRITE(*,*) 'jj_para_end =', jj_para_end
+    WRITE(*,*) 'ii_para_begin =', ii_para_begin
+    WRITE(*,*) 'ii_para_end =', ii_para_end
+    WRITE(*,*) 'ij_para_nb =', ij_para_nb
+    WRITE(*,*) 'ij_para_begin =', ij_para_begin
+    WRITE(*,*) 'ij_para_end =', ij_para_end
+    WRITE(*,*) 'klon_mpi_para_nb =', klon_mpi_para_nb
+    WRITE(*,*) 'klon_mpi_para_begin =', klon_mpi_para_begin
+    WRITE(*,*) 'klon_mpi_para_end  =', klon_mpi_para_end 
+    WRITE(*,*) 'mpi_rank =', mpi_rank
+    WRITE(*,*) 'mpi_size =', mpi_size
+    WRITE(*,*) 'mpi_root =', mpi_root
+    WRITE(*,*) 'is_mpi_root =', is_mpi_root
+    WRITE(*,*) 'is_north_pole =', is_north_pole
+    WRITE(*,*) 'is_south_pole =', is_south_pole
+    WRITE(*,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_data.F90.orig
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_data.F90.orig	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_data.F90.orig	(revision 222)
@@ -0,0 +1,211 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_mpi_data
+  USE mod_const_mpi, only: MPI_REAL_LMDZ, COMM_LMDZ
+  
+  INTEGER,SAVE :: ii_begin
+  INTEGER,SAVE :: ii_end
+  INTEGER,SAVE :: jj_begin
+  INTEGER,SAVE :: jj_end
+  INTEGER,SAVE :: jj_nb
+  INTEGER,SAVE :: ij_begin
+  INTEGER,SAVE :: ij_end
+  INTEGER,SAVE :: ij_nb
+  INTEGER,SAVE :: klon_mpi_begin
+  INTEGER,SAVE :: klon_mpi_end
+  INTEGER,SAVE :: klon_mpi
+  
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end 
+
+  
+  INTEGER,SAVE :: mpi_rank
+  INTEGER,SAVE :: mpi_size
+  INTEGER,SAVE :: mpi_root
+  LOGICAL,SAVE :: is_mpi_root
+  LOGICAL,SAVE :: is_using_mpi
+  
+  
+  LOGICAL,SAVE :: is_north_pole
+  LOGICAL,SAVE :: is_south_pole
+  INTEGER,SAVE :: COMM_LMDZ_PHY
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+  USE mod_const_mpi, ONLY : COMM_LMDZ
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+    
+    INTEGER :: ierr
+    INTEGER :: klon_glo
+    INTEGER :: i
+    
+#ifdef CPP_MPI
+    is_using_mpi=.TRUE.
+#else
+    is_using_mpi=.FALSE.
+#endif
+    
+    if (iim.eq.1) then
+       klon_glo=1
+    else
+       klon_glo=iim*(jjp1-2)+2
+    endif
+    
+    COMM_LMDZ_PHY=COMM_LMDZ
+
+    IF (is_using_mpi) THEN    
+#ifdef CPP_MPI
+      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
+      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
+#endif
+    ELSE
+      mpi_size=1
+      mpi_rank=0
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN
+      mpi_root = 0
+      is_mpi_root = .true.
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN 
+      is_north_pole = .TRUE.
+    ELSE
+      is_north_pole = .FALSE.
+    ENDIF
+    
+    IF (mpi_rank == mpi_size-1) THEN
+      is_south_pole = .TRUE.
+    ELSE
+      is_south_pole = .FALSE.
+    ENDIF
+    
+    ALLOCATE(jj_para_nb(0:mpi_size-1))
+    ALLOCATE(jj_para_begin(0:mpi_size-1))
+    ALLOCATE(jj_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ij_para_nb(0:mpi_size-1))
+    ALLOCATE(ij_para_begin(0:mpi_size-1))
+    ALLOCATE(ij_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ii_para_begin(0:mpi_size-1))
+    ALLOCATE(ii_para_end(0:mpi_size-1))
+
+    ALLOCATE(klon_mpi_para_nb(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_begin(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_end(0:mpi_size-1))
+  
+      
+    klon_mpi_para_nb(0:mpi_size-1)=distrib(0:nb_proc-1)
+
+    DO i=0,mpi_size-1
+      IF (i==0) THEN 
+        klon_mpi_para_begin(i)=1
+      ELSE 
+        klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1
+      ENDIF
+        klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1
+    ENDDO
+
+
+    DO i=0,mpi_size-1
+      
+      IF (i==0) THEN
+        ij_para_begin(i) = 1
+      ELSE
+        ij_para_begin(i) = klon_mpi_para_begin(i)+iim-1
+      ENDIF
+
+      jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1
+      ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1
+
+      
+      ij_para_end(i) = klon_mpi_para_end(i)+iim-1
+      jj_para_end(i) = (ij_para_end(i)-1)/iim + 1
+      ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 1
+
+      ! Ehouarn: handle 1D case:
+      if (klon_glo.eq.1) then
+        klon_mpi_para_end(i) = 1
+        klon_mpi_para_nb(i) = 1
+        ij_para_end(i) = 1
+        jj_para_end(i) = 1
+        ii_para_end(i) = 1
+      endif
+
+      ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1
+      jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1
+         
+    ENDDO
+  
+    ii_begin = ii_para_begin(mpi_rank)
+    ii_end   = ii_para_end(mpi_rank)
+    jj_begin = jj_para_begin(mpi_rank)
+    jj_end   = jj_para_end(mpi_rank)
+    jj_nb    = jj_para_nb(mpi_rank)
+    ij_begin = ij_para_begin(mpi_rank)
+    ij_end   = ij_para_end(mpi_rank)
+    ij_nb    = ij_para_nb(mpi_rank)
+    klon_mpi_begin = klon_mpi_para_begin(mpi_rank)
+    klon_mpi_end   = klon_mpi_para_end(mpi_rank)
+    klon_mpi       = klon_mpi_para_nb(mpi_rank)
+   
+    CALL Print_module_data
+    
+  END SUBROUTINE Init_phys_lmdz_mpi_data
+
+  SUBROUTINE print_module_data
+  IMPLICIT NONE
+!  INCLUDE "iniprint.h" 
+  
+    WRITE(*,*) 'ii_begin =', ii_begin
+    WRITE(*,*) 'ii_end =', ii_end
+    WRITE(*,*) 'jj_begin =',jj_begin
+    WRITE(*,*) 'jj_end =', jj_end
+    WRITE(*,*) 'jj_nb =', jj_nb
+    WRITE(*,*) 'ij_begin =', ij_begin
+    WRITE(*,*) 'ij_end =', ij_end
+    WRITE(*,*) 'ij_nb =', ij_nb
+    WRITE(*,*) 'klon_mpi_begin =', klon_mpi_begin
+    WRITE(*,*) 'klon_mpi_end =', klon_mpi_end
+    WRITE(*,*) 'klon_mpi =', klon_mpi
+    WRITE(*,*) 'jj_para_nb =', jj_para_nb
+    WRITE(*,*) 'jj_para_begin =', jj_para_begin
+    WRITE(*,*) 'jj_para_end =', jj_para_end
+    WRITE(*,*) 'ii_para_begin =', ii_para_begin
+    WRITE(*,*) 'ii_para_end =', ii_para_end
+    WRITE(*,*) 'ij_para_nb =', ij_para_nb
+    WRITE(*,*) 'ij_para_begin =', ij_para_begin
+    WRITE(*,*) 'ij_para_end =', ij_para_end
+    WRITE(*,*) 'klon_mpi_para_nb =', klon_mpi_para_nb
+    WRITE(*,*) 'klon_mpi_para_begin =', klon_mpi_para_begin
+    WRITE(*,*) 'klon_mpi_para_end  =', klon_mpi_para_end 
+    WRITE(*,*) 'mpi_rank =', mpi_rank
+    WRITE(*,*) 'mpi_size =', mpi_size
+    WRITE(*,*) 'mpi_root =', mpi_root
+    WRITE(*,*) 'is_mpi_root =', is_mpi_root
+    WRITE(*,*) 'is_north_pole =', is_north_pole
+    WRITE(*,*) 'is_south_pole =', is_south_pole
+    WRITE(*,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_transfert.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_mpi_transfert.F90	(revision 222)
@@ -0,0 +1,1906 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_mpi_transfert
+
+
+  INTERFACE bcast_mpi
+    MODULE PROCEDURE bcast_mpi_c,                                                     &
+                     bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
+                     bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
+		     bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
+  END INTERFACE
+
+  INTERFACE scatter_mpi
+    MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, &
+                     scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, &
+		     scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3
+  END INTERFACE
+
+  
+  INTERFACE gather_mpi
+    MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, &
+                     gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, &
+		     gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3  
+  END INTERFACE
+  
+  INTERFACE scatter2D_mpi
+    MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, &
+                     scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, &
+		     scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3
+  END INTERFACE
+
+  INTERFACE gather2D_mpi
+    MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, &
+                     gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, &
+		     gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3
+  END INTERFACE 
+  
+  INTERFACE reduce_sum_mpi
+    MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, &
+                     reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4
+  END INTERFACE 
+
+ INTERFACE grid1dTo2d_mpi
+    MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, &
+                     grid1dTo2d_mpi_r,grid1dTo2d_mpi_r1,grid1dTo2d_mpi_r2,grid1dTo2d_mpi_r3, &
+		     grid1dTo2d_mpi_l,grid1dTo2d_mpi_l1,grid1dTo2d_mpi_l2,grid1dTo2d_mpi_l3
+ END INTERFACE 
+
+ INTERFACE grid2dTo1d_mpi
+    MODULE PROCEDURE grid2dTo1d_mpi_i,grid2dTo1d_mpi_i1,grid2dTo1d_mpi_i2,grid2dTo1d_mpi_i3, &
+                     grid2dTo1d_mpi_r,grid2dTo1d_mpi_r1,grid2dTo1d_mpi_r2,grid2dTo1d_mpi_r3, &
+		     grid2dTo1d_mpi_l,grid2dTo1d_mpi_l1,grid2dTo1d_mpi_l2,grid2dTo1d_mpi_l3
+ END INTERFACE 
+    
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_mpi_c(var1)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var1
+   
+    CALL bcast_mpi_cgen(Var1,len(Var1))
+
+  END SUBROUTINE bcast_mpi_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_mpi_i(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    
+    INTEGER               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_igen(Var_tmp,1)
+    var=var_tmp(1)
+    
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+
+    CALL bcast_mpi_igen(Var,size(Var))
+    
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+  
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+    REAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_rgen(Var_tmp,1)
+    var=var_tmp(1)   
+
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_lgen(Var_tmp,1)
+    var=var_tmp(1)   
+
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l4
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL scatter_mpi_igen(VarIn,Varout,1)
+    
+  END SUBROUTINE scatter_mpi_i
+
+  SUBROUTINE scatter_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
+    
+  END SUBROUTINE scatter_mpi_i1
+  
+  SUBROUTINE scatter_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+
+  END SUBROUTINE scatter_mpi_i2
+
+  SUBROUTINE scatter_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_i3
+
+
+  SUBROUTINE scatter_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,1)
+  
+  END SUBROUTINE scatter_mpi_r
+
+  SUBROUTINE scatter_mpi_r1(VarIn, VarOut)
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
+  
+  END SUBROUTINE scatter_mpi_r1
+  
+  SUBROUTINE scatter_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+  
+  END SUBROUTINE scatter_mpi_r2
+
+  SUBROUTINE scatter_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_r3
+
+
+  SUBROUTINE scatter_mpi_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,1)
+    
+  END SUBROUTINE scatter_mpi_l
+
+  SUBROUTINE scatter_mpi_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
+  
+  END SUBROUTINE scatter_mpi_l1
+  
+  SUBROUTINE scatter_mpi_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+  
+  END SUBROUTINE scatter_mpi_l2
+
+  SUBROUTINE scatter_mpi_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_l3  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_i
+  
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_i1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_i2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_i3
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_r
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_r1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_r2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_r3
+
+!!!!! --> Les booleen
+
+  SUBROUTINE gather_mpi_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_l
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_l1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_l2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter2D_mpi_i(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i
+
+  SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i1
+
+  SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i2
+  
+  SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter2D_mpi_i3
+
+
+
+  SUBROUTINE scatter2D_mpi_r(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_R
+
+
+  SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_r1
+
+
+  SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_r2
+  
+  SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE scatter2D_mpi_r3
+  
+  
+  SUBROUTINE scatter2D_mpi_l(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_l
+
+
+  SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE scatter2D_mpi_l1
+
+
+  SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+  
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_l2
+  
+  SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid2dTo1d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE scatter2D_mpi_l3
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather2D_mpi_i(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i
+
+  SUBROUTINE gather2D_mpi_i1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i1
+
+  SUBROUTINE gather2D_mpi_i2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i2
+  
+  SUBROUTINE gather2D_mpi_i3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+ 
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i3
+
+
+
+  SUBROUTINE gather2D_mpi_r(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r
+
+  SUBROUTINE gather2D_mpi_r1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r1
+
+  SUBROUTINE gather2D_mpi_r2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r2
+  
+  SUBROUTINE gather2D_mpi_r3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r3
+
+  
+  
+  SUBROUTINE gather2D_mpi_l(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l
+
+  SUBROUTINE gather2D_mpi_l1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l1
+
+  SUBROUTINE gather2D_mpi_l2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l2
+  
+  SUBROUTINE gather2D_mpi_l3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz, only: klon_glo, grid1dTo2d_glo
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l3
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_sum_mpi_i
+
+  SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i1
+
+  SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i2
+
+  SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i3
+
+  SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i4                  
+  
+  
+  SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_sum_mpi_r
+
+  SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+     
+  END SUBROUTINE reduce_sum_mpi_r1
+
+  SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r2
+
+  SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r3
+
+  SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r4 
+  
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE grid1dTo2d_mpi_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_i
+  
+
+  SUBROUTINE grid1dTo2d_mpi_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i1
+
+  SUBROUTINE grid1dTo2d_mpi_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i2
+  
+  SUBROUTINE grid1dTo2d_mpi_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i3
+
+
+  SUBROUTINE grid1dTo2d_mpi_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_r
+  
+
+  SUBROUTINE grid1dTo2d_mpi_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r1
+
+  SUBROUTINE grid1dTo2d_mpi_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r2
+  
+  SUBROUTINE grid1dTo2d_mpi_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_mpi_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_l
+  
+
+  SUBROUTINE grid1dTo2d_mpi_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l1
+
+  SUBROUTINE grid1dTo2d_mpi_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l2
+  
+  SUBROUTINE grid1dTo2d_mpi_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l3
+
+
+  SUBROUTINE grid2dTo1d_mpi_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_i
+  
+
+  SUBROUTINE grid2dTo1d_mpi_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i1
+
+  SUBROUTINE grid2dTo1d_mpi_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i2
+  
+  SUBROUTINE grid2dTo1d_mpi_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_r
+  
+
+  SUBROUTINE grid2dTo1d_mpi_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r1
+
+  SUBROUTINE grid2dTo1d_mpi_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r2
+  
+  SUBROUTINE grid2dTo1d_mpi_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r3
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_l
+  
+
+  SUBROUTINE grid2dTo1d_mpi_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l1
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l2
+
+  
+  SUBROUTINE grid2dTo1d_mpi_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l3
+
+               
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_mpi_cgen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+    
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE bcast_mpi_cgen
+
+
+      
+  SUBROUTINE bcast_mpi_igen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE bcast_mpi_igen
+
+
+
+  
+  SUBROUTINE bcast_mpi_rgen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+    
+  END SUBROUTINE bcast_mpi_rgen
+  
+
+
+
+  SUBROUTINE bcast_mpi_lgen(var,nb)
+    USE mod_phys_lmdz_mpi_data ,  mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr)
+    if (ierr.ne.MPI_SUCCESS) then
+      write(*,*) "bcast_mpi error: ierr=",ierr
+      stop
+    endif
+#endif
+
+  END SUBROUTINE bcast_mpi_lgen
+
+  
+
+  SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+#ifdef CPP_MPI 
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
+                      MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE scatter_mpi_igen
+
+  SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+#ifdef CPP_MPI 
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
+                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
+
+#endif
+
+  END SUBROUTINE scatter_mpi_rgen
+
+  
+  SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+#ifdef CPP_MPI
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
+                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE scatter_mpi_lgen  
+
+
+
+
+  SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+	Index=Index+nb*dimsize
+      ENDDO
+     
+    ENDIF
+    
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
+                     MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+		          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+	  Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_igen  
+
+  SUBROUTINE gather_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+	Index=Index+nb*dimsize
+      ENDDO
+    ENDIF
+    
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
+                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+		          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+	  Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_rgen  
+
+  SUBROUTINE gather_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+    
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+	Index=Index+nb*dimsize
+      ENDDO
+    ENDIF
+    
+
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
+                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+		          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+	  Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_lgen
+  
+
+
+  SUBROUTINE reduce_sum_mpi_igen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+   
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+   
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+#ifdef CPP_MPI
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+            
+  END SUBROUTINE reduce_sum_mpi_igen
+  
+  SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+
+    IMPLICIT NONE
+
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+ 
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+#ifdef CPP_MPI
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE reduce_sum_mpi_rgen
+
+
+
+  SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=0
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
+    
+    offset=ii_begin
+    IF (is_north_pole) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+	ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+	ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE grid1dTo2d_mpi_igen   
+
+
+  SUBROUTINE grid1dTo2d_mpi_rgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=0
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
+    
+    offset=ii_begin
+    IF (is_north_pole) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+	ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+	ENDDO
+      ENDDO
+    ENDIF
+
+   END SUBROUTINE grid1dTo2d_mpi_rgen   
+
+
+
+  SUBROUTINE grid1dTo2d_mpi_lgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=.FALSE.
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=.FALSE.
+    
+    offset=ii_begin
+    IF (is_north_pole) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+	ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+	ENDDO
+      ENDDO
+    ENDIF
+
+   END SUBROUTINE grid1dTo2d_mpi_lgen   
+
+  
+
+
+  SUBROUTINE grid2dTo1d_mpi_igen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_igen   
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_rgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+         VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_rgen   
+  
+
+  SUBROUTINE grid2dTo1d_mpi_lgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_lgen   
+
+END MODULE mod_phys_lmdz_mpi_transfert
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_omp_data.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_omp_data.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_omp_data.F90	(revision 222)
@@ -0,0 +1,109 @@
+!
+!$Id: mod_phys_lmdz_omp_data.F90 1575 2011-09-21 13:57:48Z jghattas $
+!
+MODULE mod_phys_lmdz_omp_data
+
+  INTEGER,SAVE :: omp_size
+  INTEGER,SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_using_omp
+  
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_begin
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_end    
+  
+  INTEGER,SAVE :: klon_omp
+  INTEGER,SAVE :: klon_omp_begin
+  INTEGER,SAVE :: klon_omp_end
+!$OMP  THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end)
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi)
+    USE dimphy
+    IMPLICIT NONE
+    INTEGER, INTENT(in) :: klon_mpi
+
+    INTEGER :: i
+
+    CHARACTER (LEN=20) :: modname='Init_phys_lmdz_omp_data'
+    CHARACTER (LEN=80) :: abort_message
+
+
+#ifdef CPP_OMP    
+    INTEGER :: OMP_GET_NUM_THREADS
+    EXTERNAL OMP_GET_NUM_THREADS
+    INTEGER :: OMP_GET_THREAD_NUM
+    EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef CPP_OMP
+!$OMP MASTER
+        is_using_omp=.TRUE.
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+    is_using_omp=.FALSE.
+    omp_size=1
+    omp_rank=0
+#endif
+
+   is_omp_root=.FALSE.
+!$OMP MASTER
+   IF (omp_rank==0) THEN
+     is_omp_root=.TRUE.
+   ELSE
+     abort_message = 'ANORMAL : OMP_MASTER /= 0'
+     CALL abort_gcm (modname,abort_message,1)
+   ENDIF
+!$OMP END MASTER
+
+
+!$OMP MASTER 
+    ALLOCATE(klon_omp_para_nb(0:omp_size-1))
+    ALLOCATE(klon_omp_para_begin(0:omp_size-1))
+    ALLOCATE(klon_omp_para_end(0:omp_size-1))
+    
+    DO i=0,omp_size-1
+      klon_omp_para_nb(i)=klon_mpi/omp_size
+      IF (i<MOD(klon_mpi,omp_size)) klon_omp_para_nb(i)=klon_omp_para_nb(i)+1
+    ENDDO
+    
+    klon_omp_para_begin(0) = 1
+    klon_omp_para_end(0) = klon_omp_para_nb(0)
+    
+    DO i=1,omp_size-1
+      klon_omp_para_begin(i)=klon_omp_para_end(i-1)+1
+      klon_omp_para_end(i)=klon_omp_para_begin(i)+klon_omp_para_nb(i)-1
+    ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+   
+    klon_omp=klon_omp_para_nb(omp_rank)
+    klon_omp_begin=klon_omp_para_begin(omp_rank)
+    klon_omp_end=klon_omp_para_end(omp_rank)
+    
+    CALL Print_module_data
+    
+  END SUBROUTINE Init_phys_lmdz_omp_data
+
+  SUBROUTINE Print_module_data
+  IMPLICIT NONE
+!  INCLUDE "iniprint.h"
+
+!$OMP CRITICAL  
+  WRITE(*,*)'--------> TASK ',omp_rank
+  WRITE(*,*)'omp_size =',omp_size
+  WRITE(*,*)'omp_rank =',omp_rank
+  WRITE(*,*)'is_omp_root =',is_omp_root
+  WRITE(*,*)'klon_omp_para_nb =',klon_omp_para_nb
+  WRITE(*,*)'klon_omp_para_begin =',klon_omp_para_begin
+  WRITE(*,*)'klon_omp_para_end =',klon_omp_para_end    
+  WRITE(*,*)'klon_omp =',klon_omp
+  WRITE(*,*)'klon_omp_begin =',klon_omp_begin
+  WRITE(*,*)'klon_omp_end =',klon_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE Print_module_data
+END MODULE mod_phys_lmdz_omp_data
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_omp_transfert.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_omp_transfert.F90	(revision 222)
@@ -0,0 +1,1057 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  PRIVATE
+  
+  INTEGER,PARAMETER :: grow_factor=1.5
+  INTEGER,PARAMETER :: size_min=1024
+  
+  CHARACTER(LEN=size_min),SAVE            :: buffer_c
+!  INTEGER,SAVE                            :: size_c=0
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_i
+  INTEGER,SAVE                            :: size_i=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:)      :: buffer_r
+  INTEGER,SAVE                            :: size_r=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_l
+  INTEGER,SAVE                            :: size_l=0
+
+
+  
+  
+  INTERFACE bcast_omp
+    MODULE PROCEDURE bcast_omp_c,                                                     &
+                     bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, &
+                     bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, &
+		     bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4
+  END INTERFACE
+
+  INTERFACE scatter_omp
+    MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, &
+                     scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, &
+		     scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3
+  END INTERFACE
+
+  
+  INTERFACE gather_omp
+    MODULE PROCEDURE gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, &
+                     gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, &
+		     gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3  
+  END INTERFACE
+  
+  
+  INTERFACE reduce_sum_omp
+    MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, &
+                     reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4
+  END INTERFACE 
+
+
+  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp
+
+CONTAINS
+
+  SUBROUTINE check_buffer_i(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_i) THEN
+      IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i)
+      size_i=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_i(size_i))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_i
+  
+  SUBROUTINE check_buffer_r(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_r) THEN
+      IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r)
+      size_r=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_r(size_r))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_r
+  
+  SUBROUTINE check_buffer_l(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_l) THEN
+      IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l)
+      size_l=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_l(size_l))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_l
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_omp_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    
+    CALL bcast_omp_cgen(Var,len(Var),buffer_c)
+    
+  END SUBROUTINE bcast_omp_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_omp_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    INTEGER :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_i(1)
+    CALL bcast_omp_igen(Var_tmp,1,buffer_i)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_i
+
+
+  SUBROUTINE bcast_omp_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i1
+
+
+  SUBROUTINE bcast_omp_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i2
+
+
+  SUBROUTINE bcast_omp_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i3
+
+
+  SUBROUTINE bcast_omp_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+    REAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_r(1)
+    CALL bcast_omp_rgen(Var_tmp,1,buffer_r)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_r
+
+
+  SUBROUTINE bcast_omp_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r1
+
+
+  SUBROUTINE bcast_omp_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r2
+
+
+  SUBROUTINE bcast_omp_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r3
+
+
+  SUBROUTINE bcast_omp_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r4
+
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_l(1)
+    CALL bcast_omp_lgen(Var_tmp,1,buffer_l)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_l
+
+
+  SUBROUTINE bcast_omp_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l1
+
+
+  SUBROUTINE bcast_omp_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l2
+
+
+  SUBROUTINE bcast_omp_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l3
+
+
+  SUBROUTINE bcast_omp_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l4
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,1,buffer_i)
+    
+  END SUBROUTINE scatter_omp_i
+
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i)
+    
+  END SUBROUTINE scatter_omp_i1
+  
+  
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i)
+
+  END SUBROUTINE scatter_omp_i2
+
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i)
+  
+  END SUBROUTINE scatter_omp_i3
+
+
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r)
+    
+  END SUBROUTINE scatter_omp_r
+
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r)
+        
+  END SUBROUTINE scatter_omp_r1
+  
+  
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r)
+
+  END SUBROUTINE scatter_omp_r2
+
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r)
+  
+  END SUBROUTINE scatter_omp_r3
+  
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l)
+    
+  END SUBROUTINE scatter_omp_l
+
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l)
+    
+  END SUBROUTINE scatter_omp_l1
+  
+  
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l)
+
+  END SUBROUTINE scatter_omp_l2
+
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l)
+  
+  END SUBROUTINE scatter_omp_l3  
+  
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,1,buffer_i)
+    
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i)
+    
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i)
+          
+  END SUBROUTINE gather_omp_i2
+  
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i)
+    
+  END SUBROUTINE gather_omp_i3
+
+
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,1,buffer_r)
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r)
+        
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r)
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))       
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r)
+    
+  END SUBROUTINE gather_omp_r3
+
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,1,buffer_l)
+    
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l)
+    
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l)
+    
+  END SUBROUTINE gather_omp_l2
+  
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l)
+    
+  END SUBROUTINE gather_omp_l3
+
+
+
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_i(1)   
+    CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_sum_omp_i
+
+  SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+   
+  END SUBROUTINE reduce_sum_omp_i1
+  
+  
+  SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i2
+
+
+  SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i3
+
+
+  SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_r(1)   
+    CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_sum_omp_r
+
+  SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+   
+  END SUBROUTINE reduce_sum_omp_r1
+  
+  
+  SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r2
+
+
+  SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r3
+
+
+  SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r4
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    LES ROUTINES GENERIQUES    !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_omp_cgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    CHARACTER(LEN=*),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+    
+    INTEGER :: i
+  
+  !$OMP MASTER
+      Buff=Var
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var=Buff
+    ENDDO
+  !$OMP BARRIER      
+  
+  END SUBROUTINE bcast_omp_cgen
+
+
+      
+  SUBROUTINE bcast_omp_igen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_igen
+
+
+  SUBROUTINE bcast_omp_rgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_rgen
+
+  SUBROUTINE bcast_omp_lgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+  
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_lgen
+
+
+  SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
+    USE mod_phys_lmdz_omp_data, only: klon_omp, klon_omp_begin
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+ 
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+ 
+  END SUBROUTINE scatter_omp_igen
+
+
+  SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data, only: klon_omp, klon_omp_begin
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_rgen
+
+
+  SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data, only: klon_omp, klon_omp_begin
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+ !$OMP MASTER 
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_lgen
+
+
+
+
+
+  SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data, only: klon_omp, klon_omp_begin
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_igen
+
+
+  SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data, only: klon_omp, klon_omp_begin
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_rgen
+
+
+  SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data, only: klon_omp, klon_omp_begin
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_lgen
+
+
+  SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_igen
+
+  SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_rgen
+
+END MODULE mod_phys_lmdz_omp_transfert
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_para.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_para.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_para.F90	(revision 222)
@@ -0,0 +1,114 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_para
+  USE mod_phys_lmdz_transfert_para
+  USE mod_phys_lmdz_mpi_data
+  USE mod_phys_lmdz_omp_data
+    
+  INTEGER,SAVE :: klon_loc
+  LOGICAL,SAVE :: is_sequential
+  LOGICAL,SAVE :: is_parallel
+  LOGICAL,SAVE :: is_master
+  
+!$OMP THREADPRIVATE(klon_loc,is_master)
+  
+CONTAINS
+
+  SUBROUTINE Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+    CALL Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL Init_phys_lmdz_omp_data(klon_mpi)
+    klon_loc=klon_omp
+    IF (is_mpi_root .AND. is_omp_root) THEN 
+       is_master=.TRUE.
+     ELSE
+       is_master=.FALSE.
+     ENDIF
+     CALL Test_transfert
+!$OMP END PARALLEL    
+     IF (is_using_mpi .OR. is_using_omp) THEN
+       is_sequential=.FALSE.
+       is_parallel=.TRUE.
+     ELSE
+       is_sequential=.TRUE.
+       is_parallel=.FALSE.
+     ENDIF
+      
+  END SUBROUTINE Init_phys_lmdz_para
+
+  SUBROUTINE Test_transfert
+  USE mod_grid_phy_lmdz, only: klon_glo, nbp_lev, nbp_lon, nbp_lat, &
+                               grid1dTo2d_glo, grid2dTo1d_glo
+  IMPLICIT NONE
+!    INCLUDE "iniprint.h"
+ 
+    REAL :: Test_Field1d_glo(klon_glo,nbp_lev)
+    REAL :: tmp1d_glo(klon_glo,nbp_lev)
+    REAL :: Test_Field2d_glo(nbp_lon,nbp_lat,nbp_lev)
+    REAL :: tmp2d_glo(nbp_lon,nbp_lat,nbp_lev)
+    REAL :: Test_Field1d_loc(klon_loc,nbp_lev)
+    REAL :: Test_Field2d_loc(nbp_lon,jj_nb,nbp_lev)
+    REAL :: CheckSum
+    
+    INTEGER :: i,l
+  
+    Test_Field1d_glo = 0.
+    Test_Field2d_glo = 0.
+    Test_Field1d_loc = 0.
+    Test_Field2d_loc = 0.
+  
+    IF (is_mpi_root) THEN
+!$OMP MASTER
+      DO l=1,nbp_lev
+        DO i=1,klon_glo
+!          Test_Field1d_glo(i,l)=MOD(i,10)+10*(l-1)
+           Test_Field1d_glo(i,l)=1
+        ENDDO
+      ENDDO
+!$OMP END MASTER  
+    ENDIF
+  
+    CALL Scatter(Test_Field1d_glo,Test_Field1d_loc)
+    CALL Gather(Test_Field1d_loc,tmp1d_glo)
+  
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
+      WRITE(*,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+    CALL grid1dTo2d_glo(Test_Field1d_glo,Test_Field2d_glo)
+    CALL scatter2D(Test_Field2d_glo,Test_Field1d_loc)
+    CALL gather2d(Test_Field1d_loc,Test_Field2d_glo)
+    CALL grid2dTo1d_glo(Test_Field2d_glo,tmp1d_glo)
+
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
+      WRITE(*,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+
+    CALL bcast(Test_Field1d_glo)
+    CALL reduce_sum(Test_Field1d_glo,tmp1d_glo)
+
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo*omp_size*mpi_size-tmp1d_glo)
+      WRITE(*,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+     
+   END SUBROUTINE Test_transfert
+  
+END MODULE mod_phys_lmdz_para
+    
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_transfert_para.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_transfert_para.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mod_phys_lmdz_transfert_para.F90	(revision 222)
@@ -0,0 +1,1275 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_transfert_para
+
+  USE mod_phys_lmdz_mpi_transfert
+  USE mod_phys_lmdz_omp_transfert 
+
+
+
+  INTERFACE bcast
+    MODULE PROCEDURE bcast_c,                                     &
+                     bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, &
+                     bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, &
+		     bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4
+  END INTERFACE
+
+  INTERFACE scatter
+    MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, &
+                     scatter_r,scatter_r1,scatter_r2,scatter_r3, &
+		     scatter_l,scatter_l1,scatter_l2,scatter_l3
+  END INTERFACE
+
+  
+  INTERFACE gather
+    MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, &
+                     gather_r,gather_r1,gather_r2,gather_r3, &
+		     gather_l,gather_l1,gather_l2,gather_l3  
+  END INTERFACE
+  
+  INTERFACE scatter2D
+    MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, &
+                     scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, &
+		     scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3
+  END INTERFACE
+
+  INTERFACE gather2D
+    MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, &
+                     gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, &
+		     gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3
+  END INTERFACE 
+  
+  INTERFACE reduce_sum
+    MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, &
+                     reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4
+  END INTERFACE 
+
+   
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i
+
+  SUBROUTINE bcast_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i1
+
+
+  SUBROUTINE bcast_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i2
+
+
+  SUBROUTINE bcast_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i3
+
+
+  SUBROUTINE bcast_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i4
+
+ 
+!! -- Les reels -- !!
+  
+  SUBROUTINE bcast_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r
+
+  SUBROUTINE bcast_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r1
+
+
+  SUBROUTINE bcast_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r2
+
+
+  SUBROUTINE bcast_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r3
+
+
+  SUBROUTINE bcast_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r4 
+
+
+!! -- Les booleens -- !!
+  
+  SUBROUTINE bcast_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l
+
+  SUBROUTINE bcast_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l1
+
+
+  SUBROUTINE bcast_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l2
+
+
+  SUBROUTINE bcast_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l3
+
+
+  SUBROUTINE bcast_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l4
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i
+
+
+  SUBROUTINE scatter_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i1
+
+
+  SUBROUTINE scatter_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i2
+
+
+  SUBROUTINE scatter_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_i3
+
+
+  SUBROUTINE scatter_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r
+
+
+  SUBROUTINE scatter_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r1
+
+
+  SUBROUTINE scatter_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r2
+
+
+  SUBROUTINE scatter_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_r3
+  
+  
+
+  SUBROUTINE scatter_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l
+
+
+  SUBROUTINE scatter_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l1
+
+
+  SUBROUTINE scatter_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l2
+
+
+  SUBROUTINE scatter_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_l3
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i
+
+
+  SUBROUTINE gather_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i1
+
+
+  SUBROUTINE gather_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i2
+
+
+  SUBROUTINE gather_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r
+
+
+  SUBROUTINE gather_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r1
+
+
+  SUBROUTINE gather_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r2
+
+
+  SUBROUTINE gather_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r3
+
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l
+
+
+  SUBROUTINE gather_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l1
+
+
+  SUBROUTINE gather_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l2
+
+
+  SUBROUTINE gather_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!!! --> Les entiers
+
+  SUBROUTINE scatter2D_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i
+
+
+  SUBROUTINE scatter2D_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i1
+  
+
+  SUBROUTINE scatter2D_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i2  
+
+
+  SUBROUTINE scatter2D_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i3
+  
+
+!!!!! --> Les reels
+
+  SUBROUTINE scatter2D_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r
+
+
+  SUBROUTINE scatter2D_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r1
+  
+
+  SUBROUTINE scatter2D_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r2  
+
+
+  SUBROUTINE scatter2D_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r3
+    
+    
+!!!!! --> Les booleens
+
+
+  SUBROUTINE scatter2D_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l
+
+
+  SUBROUTINE scatter2D_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l1
+  
+
+  SUBROUTINE scatter2D_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l2  
+
+
+  SUBROUTINE scatter2D_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!! --> Les entiers
+
+  SUBROUTINE gather2D_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i
+  
+
+  SUBROUTINE gather2D_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i1
+
+  
+  SUBROUTINE gather2D_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i2
+
+
+  SUBROUTINE gather2D_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather2D_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r
+  
+
+  SUBROUTINE gather2D_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r1
+
+  
+  SUBROUTINE gather2D_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r2
+
+
+  SUBROUTINE gather2D_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r3
+  
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather2D_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l
+  
+
+  SUBROUTINE gather2D_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l1
+
+  
+  SUBROUTINE gather2D_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l2
+
+
+  SUBROUTINE gather2D_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l3
+  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Les entiers
+
+  SUBROUTINE reduce_sum_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    INTEGER             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i  
+
+
+  SUBROUTINE reduce_sum_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i4  
+
+
+! Les reels
+
+  SUBROUTINE reduce_sum_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    REAL             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r  
+
+
+  SUBROUTINE reduce_sum_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r4  
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/moistadj.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/moistadj.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/moistadj.F90	(revision 222)
@@ -0,0 +1,336 @@
+subroutine moistadj(ngrid, nq, pt, pq, pdq, pplev, pplay, pdtmana, pdqmana, ptimestep, rneb)
+
+  use watercommon_h, only: T_h2O_ice_liq, RLVTT, RCPD, RCPV, Psat_water, Lcpdqsat_water
+  USE tracer_h
+
+  implicit none
+
+
+!=====================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates moist convective adjustment by the method of Manabe.
+!     
+!     Authors
+!     -------
+!     Adapted from the LMDTERRE code by R. Wordsworth (2010)
+!     Original author Z. X. Li (1993)
+!     
+!=====================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+
+      INTEGER ngrid, nq
+
+      REAL pt(ngrid,nlayermx)            ! temperature (K)
+      REAL pq(ngrid,nlayermx,nq)       ! tracer (kg/kg)
+      REAL pdq(ngrid,nlayermx,nq)
+
+      REAL pdqmana(ngrid,nlayermx,nq)  ! tendency of tracers (kg/kg.s-1)
+      REAL pdtmana(ngrid,nlayermx)       ! temperature increment
+
+!     local variables
+      REAL zt(ngrid,nlayermx)      ! temperature (K)
+      REAL zq(ngrid,nlayermx)      ! humidite specifique (kg/kg)
+      REAL pplev(ngrid,nlayermx+1) ! pression a inter-couche (Pa)
+      REAL pplay(ngrid,nlayermx)   ! pression au milieu de couche (Pa)
+
+      REAL d_t(ngrid,nlayermx)     ! temperature increment
+      REAL d_q(ngrid,nlayermx)     ! incrementation pour vapeur d'eau
+      REAL d_ql(ngrid,nlayermx)    ! incrementation pour l'eau liquide
+      REAL rneb(ngrid,nlayermx) ! cloud fraction 
+      REAL ptimestep
+
+!      REAL t_coup
+!      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+
+!     Local variables
+      INTEGER i, k, iq, nn
+      INTEGER, PARAMETER :: niter = 1
+      INTEGER k1, k1p, k2, k2p
+      LOGICAL itest(ngrid)
+      REAL delta_q(ngrid, nlayermx)
+      DOUBLE PRECISION :: cp_new_t(nlayermx), v_cptt(ngrid,nlayermx)
+      REAL cp_delta_t(nlayermx)
+      DOUBLE PRECISION :: v_cptj(nlayermx), v_cptjk1, v_ssig
+      REAL v_p, v_t, v_zqs,v_cptt2,v_pratio,v_dlnpsat
+      REAL zqs(ngrid,nlayermx), zdqs(ngrid,nlayermx),zpsat(ngrid,nlayermx),zdlnpsat(ngrid,nlayermx)
+      REAL zq1(ngrid), zq2(ngrid)
+      DOUBLE PRECISION :: gamcpdz(ngrid,2:nlayermx)
+      DOUBLE PRECISION :: zdp, zdpm
+
+      REAL zsat ! super-saturation
+      REAL zflo ! flotabilite
+
+      DOUBLE PRECISION :: local_q(ngrid,nlayermx),local_t(ngrid,nlayermx)
+
+      REAL zdelta, zcor, zcvm5
+
+      REAL dEtot, dqtot, masse ! conservation diagnostics
+      real dL1tot, dL2tot
+
+!     Indices of water vapour and water ice tracers
+      INTEGER,SAVE :: i_h2o=0  ! water vapour
+      INTEGER,SAVE :: i_ice=0  ! water ice
+
+      LOGICAL firstcall
+      SAVE firstcall
+
+      DATA firstcall /.TRUE./
+
+      IF (firstcall) THEN
+
+         i_h2o=igcm_h2o_vap
+         i_ice=igcm_h2o_ice
+        
+         write(*,*) "rain: i_ice=",i_ice
+         write(*,*) "      i_h2o=",i_h2o
+
+         firstcall = .FALSE.
+      ENDIF
+
+!     GCM -----> subroutine variables
+      zq(1:ngrid,1:nlayermx)    = pq(1:ngrid,1:nlayermx,i_h2o)+ pdq(1:ngrid,1:nlayermx,i_h2o)*ptimestep
+      zt(1:ngrid,1:nlayermx)    = pt(1:ngrid,1:nlayermx)
+      pdqmana(1:ngrid,1:nlayermx,1:nq)=0.0
+
+      DO k = 1, nlayermx
+       DO i = 1, ngrid
+         if(zq(i,k).lt.0.)then
+            zq(i,k)=0.0
+         endif
+       ENDDO
+      ENDDO
+      
+      local_q(1:ngrid,1:nlayermx) = zq(1:ngrid,1:nlayermx)
+      local_t(1:ngrid,1:nlayermx) = zt(1:ngrid,1:nlayermx)
+      rneb(1:ngrid,1:nlayermx) = 0.0
+      d_ql(1:ngrid,1:nlayermx) = 0.0
+      d_t(1:ngrid,1:nlayermx)  = 0.0
+      d_q(1:ngrid,1:nlayermx)  = 0.0
+
+!     Calculate v_cptt
+      DO k = 1, nlayermx
+         DO i = 1, ngrid
+            v_cptt(i,k) = RCPD * local_t(i,k)
+            v_t = MAX(local_t(i,k),15.)
+            v_p = pplay(i,k)
+
+            call Psat_water(v_t,v_p,zpsat(i,k),zqs(i,k))
+	    call Lcpdqsat_water(v_t,v_p,zpsat(i,k),zqs(i,k),zdqs(i,k),zdlnpsat(i,k))
+         ENDDO
+      ENDDO
+
+!     Calculate Gamma * Cp * dz: (gamma is the critical gradient)
+      DO k = 2, nlayermx
+         DO i = 1, ngrid
+            zdp = pplev(i,k)-pplev(i,k+1)
+            zdpm = pplev(i,k-1)-pplev(i,k)
+!            gamcpdz(i,k) = ( ( R/RCPD /(zdpm+zdp) * (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)          &
+!                +  RLVTT /(zdpm+zdp) * (zqs(i,k-1)*zdpm + zqs(i,k)*zdp) )                           &
+!	        * (pplay(i,k-1)-pplay(i,k)) / pplev(i,k) )                                          &
+!                / (1.0+ (zdqs(i,k-1)*zdpm + zdqs(i,k)*zdp)/(zdpm+zdp) )                    
+! general case where water is not a trace gas (JL13)
+            v_zqs     = (zqs(i,k-1)*zdpm + zqs(i,k)*zdp)/(zdpm+zdp)
+	    v_cptt2   = (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)/(zdpm+zdp)
+	    v_pratio  = ((1.-zpsat(i,k-1)/pplay(i,k-1))*zdpm + (1.-zpsat(i,k)/pplay(i,k))*zdp)/(zdpm+zdp)
+	    v_dlnpsat = (zdlnpsat(i,k-1)*zdpm + zdlnpsat(i,k)*zdp)/(zdpm+zdp)
+            gamcpdz(i,k) = ( (R/RCPD*v_cptt2*(1.- v_zqs) + RLVTT*v_zqs) * (pplay(i,k-1)-pplay(i,k))/pplev(i,k) )  &
+                / (((1.- v_zqs) + v_zqs * RCPV/RCPD)*v_pratio + v_zqs  * v_dlnpsat)                
+         ENDDO
+      ENDDO
+
+!------------------------------------ modification of unstable profile
+      DO 9999 i = 1, ngrid
+
+      itest(i) = .FALSE.
+
+!        print*,'we in the loop'
+!        stop    
+
+      k1 = 0
+      k2 = 1
+
+  810 CONTINUE ! look for k1, the base of the column
+      k2 = k2 + 1
+      IF (k2 .GT. nlayermx) GOTO 9999
+      zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2)
+      zsat=(local_q(i,k2-1)-zqs(i,k2-1))*(pplev(i,k2-1)-pplev(i,k2))   &
+         +(local_q(i,k2)-zqs(i,k2))*(pplev(i,k2)-pplev(i,k2+1))
+
+      IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810
+      k1 = k2 - 1
+      itest(i) = .TRUE.
+
+  820 CONTINUE !! look for k2, the top of the column
+      IF (k2 .EQ. nlayermx) GOTO 821
+      k2p = k2 + 1
+      zsat=zsat+(pplev(i,k2p)-pplev(i,k2p+1))*(local_q(i,k2p)-zqs(i,k2p))
+      zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p)
+
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821
+      k2 = k2p
+      GOTO 820
+  821 CONTINUE
+
+!------------------------------------------------------ local adjustment
+  830 CONTINUE ! actual adjustment
+    Do nn=1,niter
+      v_cptj(k1) = 0.0
+      zdp = pplev(i,k1)-pplev(i,k1+1)
+      v_cptjk1 = ( (1.0+zdqs(i,k1))*(v_cptt(i,k1)+v_cptj(k1)) + RLVTT*(local_q(i,k1)-zqs(i,k1)) ) * zdp
+      v_ssig = zdp * (1.0+zdqs(i,k1))
+
+      k1p = k1 + 1
+      DO k = k1p, k2
+         zdp = pplev(i,k)-pplev(i,k+1)
+         v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k)
+         v_cptjk1 = v_cptjk1 + zdp * ( (1.0+zdqs(i, k))*(v_cptt(i,k)+v_cptj(k)) + RLVTT*(local_q(i,k)-zqs(i,k)) )        
+         v_ssig = v_ssig + zdp *(1.0+zdqs(i,k))
+      ENDDO
+
+
+      ! this right here is where the adjustment is done???
+      DO k = k1, k2
+         cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
+         cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k)
+         v_cptt(i,k)=cp_new_t(k)
+         local_q(i,k) = zqs(i,k) + zdqs(i,k)*cp_delta_t(k)/RLVTT
+         local_t(i,k) = cp_new_t(k) / RCPD
+
+         v_t = MAX(local_t(i,k),15.)
+         v_p = pplay(i,k)
+         
+         call Psat_water(v_t,v_p,zpsat(i,k),zqs(i,k))
+         call Lcpdqsat_water(v_t,v_p,zpsat(i,k),zqs(i,k),zdqs(i,k),zdlnpsat(i,k))
+
+      ENDDO
+    Enddo ! nn=1,niter
+
+
+!--------------------------------------------------- sounding downwards
+!              -- we refine the prognostic variables in
+!              -- the layer about to be adjusted
+
+!      DO k = k1, k2
+!         v_cptt(i,k) = RCPD * local_t(i,k)
+!         v_t = local_t(i,k)
+!         v_p = pplay(i,k)
+!       
+!         call Psat_water(v_t,v_p,zpsat,zqs(i,k))
+!         call Lcpdqsat_water(v_t,v_p,zpsat,zqs(i,k),zdqs(i,k))
+!      ENDDO
+
+      DO k = 2, nlayermx
+         zdpm = pplev(i,k-1) - pplev(i,k)
+         zdp = pplev(i,k) - pplev(i,k+1)
+!         gamcpdz(i,k) = ( ( R/RCPD /(zdpm+zdp) * (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)          &
+!             +  RLVTT /(zdpm+zdp) * (zqs(i,k-1)*zdpm + zqs(i,k)*zdp) )                           &
+!	      * (pplay(i,k-1)-pplay(i,k)) / pplev(i,k) )                                          &
+!             / (1.0+ (zdqs(i,k-1)*zdpm + zdqs(i,k)*zdp)/(zdpm+zdp) )                    
+! general case where water is not a trace gas (JL13)
+         v_zqs     = (zqs(i,k-1)*zdpm + zqs(i,k)*zdp)/(zdpm+zdp)
+	 v_cptt2   = (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)/(zdpm+zdp)
+	 v_pratio  = ((1.-zpsat(i,k-1)/pplay(i,k-1))*zdpm + (1.-zpsat(i,k)/pplay(i,k))*zdp)/(zdpm+zdp)
+	 v_dlnpsat = (zdlnpsat(i,k-1)*zdpm + zdlnpsat(i,k)*zdp)/(zdpm+zdp)
+         gamcpdz(i,k) = ( (R/RCPD*v_cptt2*(1.- v_zqs) + RLVTT*v_zqs) * (pplay(i,k-1)-pplay(i,k))/pplev(i,k) )  &
+                / (((1.- v_zqs) + v_zqs * RCPV/RCPD)*v_pratio + v_zqs  * v_dlnpsat)                
+      ENDDO
+
+!     Test to see if we've reached the bottom
+
+      IF (k1 .EQ. 1) GOTO 841 ! yes we have!
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      zsat=(local_q(i,k1-1)-zqs(i,k1-1))*(pplev(i,k1-1)-pplev(i,k1))   &
+        + (local_q(i,k1)-zqs(i,k1))*(pplev(i,k1)-pplev(i,k1+1))
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! yes we have!
+
+  840 CONTINUE
+      k1 = k1 - 1
+      IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      zsat = zsat + (local_q(i,k1-1)-zqs(i,k1-1))               &
+                  *(pplev(i,k1-1)-pplev(i,k1))
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN
+         GOTO 840
+      ELSE
+         GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      ENDIF
+  841 CONTINUE
+
+      GOTO 810 ! look for other layers higher up
+
+ 9999 CONTINUE ! loop over all the points
+
+!-----------------------------------------------------------------------
+! Determine the cloud fraction (hypothese: la nebulosite a lieu
+! a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
+
+      DO k = 1, nlayermx
+      DO i = 1, ngrid
+         IF (itest(i)) THEN
+         delta_q(i,k) = local_q(i,k) - zq(i,k)
+         IF (delta_q(i,k).LT.0.) rneb(i,k)  = 1.0
+         ENDIF
+      ENDDO
+      ENDDO
+
+! Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
+! l'eau liquide est distribuee aux endroits ou la vapeur d'eau
+! diminue et d'une maniere proportionnelle a cet diminution):
+
+      DO i = 1, ngrid
+         IF (itest(i)) THEN
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         ENDIF
+      ENDDO
+      DO k = 1, nlayermx
+      DO i = 1, ngrid
+         IF (itest(i)) THEN
+         zdp = pplev(i,k)-pplev(i,k+1)
+         zq1(i) = zq1(i) - delta_q(i,k) * zdp
+         zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp
+         ENDIF
+      ENDDO
+      ENDDO
+      DO k = 1, nlayermx
+      DO i = 1, ngrid
+         IF (itest(i)) THEN
+           IF (zq2(i).NE.0.0) d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO k = 1, nlayermx
+      DO i = 1, ngrid
+          local_q(i, k) = MAX(local_q(i, k), seuil_vap)
+      ENDDO
+      ENDDO
+
+      DO k = 1, nlayermx
+      DO i = 1, ngrid
+         d_t(i,k) = local_t(i,k) - zt(i,k)
+         d_q(i,k) = local_q(i,k) - zq(i,k)
+      ENDDO
+      ENDDO
+
+!     now subroutine -----> GCM variables
+      DO k = 1, nlayermx
+         DO i = 1, ngrid
+            
+            pdtmana(i,k)       = d_t(i,k)/ptimestep
+            pdqmana(i,k,i_h2o) = d_q(i,k)/ptimestep
+            pdqmana(i,k,i_ice) = d_ql(i,k)/ptimestep
+         
+         ENDDO
+      ENDDO
+
+
+      RETURN
+   END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mucorr.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mucorr.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mucorr.F	(revision 222)
@@ -0,0 +1,113 @@
+      SUBROUTINE mucorr(npts,pdeclin, plat, pmu,pfract,phaut,prad,pflat)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul of equivalent solar angle and and fraction of day whithout 
+c   diurnal cycle.
+c
+c   parmeters :
+c   -----------
+c
+c      Input :
+c      -------
+c         npts             number of points
+c         pdeclin          solar declinaison
+c         plat(npts)        latitude
+c         phaut            hauteur typique de l'atmosphere
+c         prad             rayon planetaire
+c
+c      Output :
+c      --------
+c         pmu(npts)          equivalent cosinus of the solar angle
+c         pfract(npts)       fractionnal day
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c
+c    0. Declarations :
+c    -----------------
+
+c     Arguments :
+c     -----------
+      INTEGER npts
+      REAL plat(npts),pmu(npts), pfract(npts)
+      REAL phaut,prad,pdeclin, pflat
+c
+c     Local variables :
+c     -----------------
+      INTEGER j
+      REAL pi
+      REAL z,cz,sz,tz,phi,cphi,sphi,tphi
+      REAL ap,a,t,b, tp, rap
+      REAL alph
+
+c-----------------------------------------------------------------------
+
+c----- SG: geometry adapted to a flattened planet (Feb2014)
+
+      pi = 4. * atan(1.0)
+      z = pdeclin
+      cz = cos (z)
+      sz = sin (z)
+      rap = 1./((1.-pflat)**2)
+
+      DO 20 j = 1, npts
+
+         phi = plat(j)
+         cphi = cos(phi)
+         if (cphi.le.1.e-9) cphi=1.e-9
+         sphi = sin(phi)
+         tphi = sphi / cphi
+         b = cphi * cz
+         t = -rap*tphi * sz / cz
+         a = 1.0 - t*t
+         ap = a
+   
+         IF(t.eq.0.) then
+            tp=0.5*pi
+         ELSE
+            IF (a.lt.0.) a = 0.
+            t = sqrt(a) / t
+            IF (t.lt.0.) then
+               tp = -atan (-t) + pi
+            ELSE
+               tp = atan(t)
+            ENDIF
+         ENDIF
+         t = tp
+   
+         pmu(j) = (sphi*sz*t*rap) / pi + b*sin(t)/pi
+         pfract(j) = t / pi
+         IF (ap .lt.0.) then
+            pmu(j) = sphi * sz*rap
+            pfract(j) = 1.0
+         ENDIF
+         IF (pmu(j).le.0.0) pmu(j) = 0.0
+         pmu(j) = pmu(j) / pfract(j)
+         IF (pmu(j).eq.0.) pfract(j) = 0.
+
+         pmu(j)=pmu(j)/SQRT(cphi**2 + (rap**2) * (sphi**2))
+
+   20 CONTINUE
+
+c-----------------------------------------------------------------------
+c   correction de rotondite:
+c   ------------------------
+
+      ! condition added to avoid errors when rad is not set (e.g. 1D runs)
+      IF (prad.ne.0) THEN
+  
+      alph=phaut/prad
+      DO 30 j=1,npts
+c !!!!!!
+ !!!!!!! AS: how generic is this???
+         pmu(j)=sqrt(1224.*pmu(j)*pmu(j)+1.)/35.
+c    $          (sqrt(alph*alph*pmu(j)*pmu(j)+2.*alph+1.)-alph*pmu(j))
+30    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mufract.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mufract.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/mufract.F	(revision 222)
@@ -0,0 +1,92 @@
+      SUBROUTINE mufract(jjm,pdecli, plat, pmu, pfract)
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Calcul of equivalent solar angle and and fraction of day without 
+c   diurnal cycle.
+c
+c   parmeters :
+c   -----------
+c
+c      Input :
+c      -------
+c         jjm              number of points
+c         pdecli           solar declinaison
+c         plat(jjm)        latitude
+c
+c      Output :
+c      --------
+c         pmu(jjm)          equivalent cosinus of the solar angle
+c         pfract(jjm)       fractionnal day
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0. Declarations :
+c    -----------------
+c
+c     Arguments :
+c     -----------
+
+      INTEGER jjm
+      REAL plat(jjm),pmu(jjm), pfract(jjm)
+      REAL pdecli
+c
+c     Local variables :
+c     -----------------
+
+      INTEGER j
+      REAL pi
+      REAL z,cz,sz,tz,phi,cphi,sphi,tphi
+      REAL ap,a,t,b
+c
+c=======================================================================
+c
+      pi = 4. * atan(1.0)
+      z = pdecli
+      cz = cos (z*pi/180.)
+      sz = sin (z*pi/180.)
+c
+      DO 20 j = 1, jjm
+c
+         phi = plat(j)
+         cphi = cos(phi)
+         if (cphi.le.1.e-9) cphi=1.e-9
+         sphi = sin(phi)
+         tphi = sphi / cphi
+         b = cphi * cz
+         t = -tphi * sz / cz
+         a = 1.0 - t*t
+         ap = a
+         IF(t.eq.0.) THEN
+            t=0.5*pi
+         ELSE
+            IF (a.lt.0.) a = 0.
+            t = sqrt(a) / t
+            IF (t.lt.0.) THEN
+               t = -atan (-t) + pi
+            ELSE
+               t = atan(t)
+            ENDIF
+         ENDIF
+         pmu(j) = (sphi*sz*t) / pi + b*sin(t)/pi
+         pfract(j) = t / pi
+         IF (ap .lt.0.) THEN
+            pmu(j) = sphi * sz
+            pfract(j) = 1.0
+         ENDIF
+         IF (pmu(j).le.0.0) pmu(j) = 0.0
+         pmu(j) = pmu(j) / pfract(j)
+         IF (pmu(j).eq.0.) pfract(j) = 0.
+c
+   20 CONTINUE
+c
+      RETURN
+      END
+c
+c* end of mufract
+c=======================================================================
+c
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/multipl.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/multipl.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/multipl.F	(revision 222)
@@ -0,0 +1,17 @@
+      SUBROUTINE multipl(n,x1,x2,y)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   multiplication de deux vecteurs
+c
+c=======================================================================
+c
+      INTEGER n,i
+      REAL x1(n),x2(n),y(n)
+c
+      DO 10 i=1,n
+         y(i)=x1(i)*x2(i)
+10    CONTINUE
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newsedim.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newsedim.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newsedim.F	(revision 222)
@@ -0,0 +1,198 @@
+      SUBROUTINE newsedim(ngrid,nlay,naersize,ptimestep,
+     &  pplev,masse,epaisseur,pt,rd,rho,pqi,wq)
+      IMPLICIT NONE
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!      Calculates sedimentation of 1 tracer 
+!      of radius rd (m) and density rho (kg.m-3) 
+!     
+!==================================================================
+
+!-----------------------------------------------------------------------
+!   declarations
+!   ------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+
+!   arguments
+!   ---------
+
+      integer,intent(in) :: ngrid  ! number of atmospheric columns
+      integer,intent(in) :: nlay  ! number of atmospheric layers
+      integer,intent(in) :: naersize   ! number of particle sizes (1 or number
+                                       ! of grid boxes)
+      real,intent(in) :: ptimestep ! physics time step (s)
+      real,intent(in) :: pplev(ngrid,nlay+1)   ! inter-layer pressures (Pa)
+      real,intent(in) :: pt(ngrid,nlay)    ! mid-layer temperatures (K)
+      real,intent(in) :: masse (ngrid,nlay) ! atmospheric mass (kg)
+      real,intent(in) :: epaisseur (ngrid,nlay)  ! thickness of atm. layers (m)
+      real,intent(in) :: rd(naersize) ! particle radius (m)
+      real,intent(in) :: rho ! particle density (kg.m-3)
+      real,intent(inout) :: pqi(ngrid,nlay)  ! tracer   (e.g. ?/kg)
+      real,intent(out) :: wq(ngrid,nlay+1)  ! flux of tracer during timestep (?/m-2)
+      
+c   local:
+c   ------
+
+      INTEGER l,ig, k, i
+      REAL rfall
+
+      LOGICAL,SAVE :: firstcall=.true.
+
+c    Traceurs :
+c    ~~~~~~~~ 
+      real traversee (ngrid,nlayermx)
+      real vstokes(ngrid,nlayermx)
+      real w(ngrid,nlayermx)
+      real ptop, dztop, Ep, Stra
+
+
+c    Physical constant
+c    ~~~~~~~~~~~~~~~~~
+c     Gas molecular viscosity (N.s.m-2)
+      real,parameter :: visc=1.e-5       ! CO2
+c     Effective gas molecular radius (m)
+      real,parameter :: molrad=2.2e-10   ! CO2
+
+c     local and saved variable
+      real,save :: a,b
+
+c    ** un petit test de coherence
+c       --------------------------
+
+
+      !print*,'temporary fixed particle rad in newsedim!!'
+
+      IF (firstcall) THEN
+         firstcall=.false.
+
+
+
+!=======================================================================
+!     Preliminary calculations for sedimenation velocity
+
+!       - Constant to compute stokes speed simple formulae
+!        (Vstokes =  b * rho* r**2   avec   b= (2/9) * rho * g / visc
+         b = 2./9. * g / visc
+
+!       - Constant  to compute gas mean free path
+!        l= (T/P)*a, avec a = (  0.707*8.31/(4*pi*molrad**2 * avogadro))
+         a = 0.707*8.31/(4*3.1416* molrad**2  * 6.023e23)
+
+c       - Correction to account for non-spherical shape (Murphy et al.  1990)
+c   (correction = 0.85 for irregular particles, 0.5 for disk shaped particles)
+c        a = a    * 0.85
+
+
+      ENDIF
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+
+c     Sedimentation velocity (m/s)
+c     ~~~~~~~~~~~~~~~~~~~~~~
+c     (stokes law corrected for low pressure by the Cunningham
+c     slip-flow correction  according to Rossow (Icarus 36, 1-50, 1978)
+       
+        do  l=1,nlay
+          do ig=1, ngrid
+            if (naersize.eq.1) then 
+              rfall=rd(1)
+            else
+              i=ngrid*(l-1)+ig
+              rfall=rd(i) ! how can this be correct!!?
+            endif  
+
+            vstokes(ig,l) = b * rho * rfall**2 *
+     &      (1 + 1.333* ( a*pt(ig,l)/pplev(ig,l) )/rfall)
+
+c           Layer crossing time (s) :
+            traversee(ig,l)= epaisseur(ig,l)/vstokes(ig,l)
+          end do
+        end do
+
+
+c     Calcul de la masse d'atmosphere correspondant a q transferee
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     (e.g. on recherche le niveau  en dessous de laquelle le traceur
+c      va traverser le niveau intercouche l : "dztop" est sa hauteur
+c      au dessus de l (m), "ptop" est sa pression (Pa))
+      do  l=1,nlay
+        do ig=1, ngrid
+             
+             dztop = vstokes(ig,l)*  ptimestep 
+             Ep=0
+             k=0
+           w(ig,l) = 0. !! JF+AS ajout initialisation (LK MARS)
+c **************************************************************
+c            Simple Method
+cc             w(ig,l) =
+cc     &       (1- exp(-dztop*g/(r*pt(ig,l))))*pplev(ig,l) / g
+cc             write(*,*) 'OK simple method l,w =', l, w(ig,l)
+cc            write(*,*) 'OK simple method dztop =', dztop
+           w(ig,l) = 1. - exp(-dztop*g/(r*pt(ig,l)))
+             !!! Diagnostic: JF. Fix: AS. Date: 05/11
+             !!! Probleme arrondi avec la quantite ci-dessus
+             !!! ---> vaut 0 pour -dztop*g/(r*pt(ig,l)) trop petit
+             !!! ---> dans ce cas on utilise le developpement limite !
+             !!! ---> exp(-x) = 1 - x lorsque x --> 0 avec une erreur de x^2 / 2  
+
+             IF ( w(ig,l) .eq. 0. ) THEN
+                w(ig,l) = ( dztop*g/(r*pt(ig,l)) ) * pplev(ig,l) / g
+             ELSE
+                w(ig,l) = w(ig,l) * pplev(ig,l) / g
+             ENDIF
+! LK borrowed simple method from Mars model (AS/JF)
+
+!**************************************************************
+cccc         Complex method :
+           if (dztop.gt.epaisseur(ig,l)) then
+cccc            Cas ou on "epuise" la couche l : On calcule le flux
+cccc            Venant de dessus en tenant compte de la variation de Vstokes
+
+               Ep= epaisseur(ig,l)
+               Stra= traversee(ig,l)
+               do while(dztop.gt.Ep.and.l+k+1.le.nlay)
+                 k=k+1
+                 dztop= Ep + vstokes(ig,l+k)*(ptimestep -Stra)
+                 Ep = Ep + epaisseur(ig,l+k)
+                 Stra = Stra + traversee(ig,l+k)
+               enddo 
+               Ep = Ep - epaisseur(ig,l+k)
+!             ptop=pplev(ig,l+k)*exp(-(dztop-Ep)*g/(r*pt(ig,l+k)))
+             ptop=exp(-(dztop-Ep)*g/(r*pt(ig,l+k)))
+	     IF ( ptop .eq. 1. ) THEN
+                !PRINT*, 'newsedim: exposant trop petit ', ig, l
+                ptop=pplev(ig,l+k) * ( 1. - (dztop-Ep)*g/(r*pt(ig,l+k)))
+             ELSE
+                ptop=pplev(ig,l+k) * ptop
+             ENDIF
+
+             w(ig,l) = (pplev(ig,l) - ptop)/g
+
+            endif   !!! complex method
+c
+cc           write(*,*) 'OK new    method l,w =', l, w(ig,l)
+cc           write(*,*) 'OK new    method dztop =', dztop
+cc       if(l.eq.7)write(*,*)'l=7,k,pplev,Ptop',pplev(ig,l),Ptop
+cc       if(l.eq.7)write(*,*)'l=7,dztop,Ep',dztop,Ep
+cc            if(l.eq.6)write(*,*)'l=6,k, w',k, w(1,l)
+cc            if(l.eq.7)write(*,*)'l=7,k, w',k, w(1,l)
+cc            if(l.eq.8)write(*,*)'l=8,k, w',k, w(1,l)
+c **************************************************************
+
+        end do
+      end do
+
+      call vlz_fi(ngrid,pqi,2.,masse,w,wq)
+c         write(*,*) ' newsed: wq(6), wq(7), q(6)',
+c    &                wq(1,6),wq(1,7),pqi(1,6)
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newstart.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newstart.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newstart.F	(revision 222)
@@ -0,0 +1,1590 @@
+C======================================================================
+      PROGRAM newstart
+c=======================================================================
+c
+c
+c   Auteur:   Christophe Hourdin/Francois Forget/Yann Wanherdrick
+c   ------
+c             Derniere modif : 12/03
+c
+c
+c   Objet:  Create or modify the initial state for the LMD Mars GCM
+c   -----           (fichiers NetCDF start et startfi)
+c
+c
+c=======================================================================
+
+      use infotrac, only: iniadvtrac, nqtot, tname
+      USE tracer_h, ONLY: igcm_co2_ice, igcm_h2o_vap, igcm_h2o_ice
+      USE comsoil_h, ONLY: nsoilmx, layer, mlayer, inertiedat
+      USE surfdat_h, ONLY: phisfi, albedodat,
+     &                     zmea, zstd, zsig, zgam, zthe
+      USE comgeomfi_h, ONLY: lati, long, area
+      use datafile_mod, only: datadir
+! to use  'getin'
+      USE ioipsl_getincom, only: getin
+      use control_mod, only: day_step, iphysiq, anneeref
+      use phyredem, only: physdem0, physdem1
+      use iostart, only: open_startphy
+      use comgeomphy, only: initcomgeomphy
+      use slab_ice_h, only:noceanmx
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "planete.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+!#include "control.h"
+#include "logic.h"
+#include "ener.h"
+#include "temps.h"
+#include "comdissnew.h"
+#include "serre.h"
+#include "netcdf.inc"
+!#include "advtrac.h"
+c=======================================================================
+c   Declarations
+c=======================================================================
+
+c Variables dimension du fichier "start_archive"
+c------------------------------------
+      CHARACTER	relief*3
+
+
+c Variables pour les lectures NetCDF des fichiers "start_archive" 
+c--------------------------------------------------
+      INTEGER nid_dyn, nid_fi,nid,nvarid
+      INTEGER length
+      parameter (length = 100)
+      INTEGER tab0
+      INTEGER   NB_ETATMAX
+      parameter (NB_ETATMAX = 100)
+
+      REAL  date
+      REAL p_rad,p_omeg,p_g,p_cpp,p_mugaz,p_daysec
+
+c Variable histoire 
+c------------------
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL phis(iip1,jjp1)
+      REAL,ALLOCATABLE :: q(:,:,:,:)               ! champs advectes
+
+c autre variables dynamique nouvelle grille
+c------------------------------------------
+      REAL pks(iip1,jjp1)
+      REAL w(iip1,jjp1,llm+1)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+!      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+!      REAL dh(ip1jmp1,llm),dp(ip1jmp1)
+      REAL phi(iip1,jjp1,llm)
+
+      integer klatdat,klongdat
+      PARAMETER (klatdat=180,klongdat=360)
+
+c Physique sur grille scalaire 
+c----------------------------
+      real zmeaS(iip1,jjp1),zstdS(iip1,jjp1)
+      real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1)
+
+c variable physique
+c------------------
+      REAL tsurf(ngridmx)	! surface temperature
+      REAL tsoil(ngridmx,nsoilmx) ! soil temperature
+!      REAL co2ice(ngridmx)	! CO2 ice layer
+      REAL emis(ngridmx)	! surface emissivity
+      real emisread             ! added by RW
+      REAL,ALLOCATABLE :: qsurf(:,:)
+      REAL q2(ngridmx,nlayermx+1)
+!      REAL rnaturfi(ngridmx)
+      real alb(iip1,jjp1),albfi(ngridmx) ! albedos
+      real ith(iip1,jjp1,nsoilmx),ithfi(ngridmx,nsoilmx) ! thermal inertia (3D)
+      real surfith(iip1,jjp1),surfithfi(ngridmx) ! surface thermal inertia (2D)
+      REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx)
+
+      INTEGER i,j,l,isoil,ig,idum
+      real mugaz ! molar mass of the atmosphere
+
+      integer ierr 
+
+      REAL rnat(ngridmx)
+      REAL tslab(ngridmx,nsoilmx) ! slab ocean temperature
+      REAL pctsrf_sic(ngridmx) ! sea ice cover
+      REAL tsea_ice(ngridmx) ! temperature sea_ice
+      REAL sea_ice(ngridmx) ! mass of sea ice (kg/m2)
+
+c Variables on the new grid along scalar points 
+c------------------------------------------------------
+!      REAL p(iip1,jjp1)
+      REAL t(iip1,jjp1,llm)
+      REAL tset(iip1,jjp1,llm)
+      real phisold_newgrid(iip1,jjp1)
+      REAL :: teta(iip1, jjp1, llm)
+      REAL :: pk(iip1,jjp1,llm)
+      REAL :: pkf(iip1,jjp1,llm)
+      REAL :: ps(iip1, jjp1)
+      REAL :: masse(iip1,jjp1,llm)
+      REAL :: xpn,xps,xppn(iim),xpps(iim)
+      REAL :: p3d(iip1, jjp1, llm+1)
+      REAL :: beta(iip1,jjp1,llm)
+!      REAL dteta(ip1jmp1,llm)
+
+c Variable de l'ancienne grille 
+c------------------------------
+      real time
+      real tab_cntrl(100)
+      real tab_cntrl_bis(100)
+
+c variables diverses
+c-------------------
+      real choix_1,pp
+      character*80      fichnom
+      character*250  filestring
+      integer Lmodif,iq,thermo
+      character modif*20
+      real z_reel(iip1,jjp1)
+      real tsud,albsud,alb_bb,ith_bb,Tiso,Tabove
+      real ptoto,pcap,patm,airetot,ptotn,patmn,psea
+!      real ssum
+      character*1 yes
+      logical :: flagtset=.false. ,  flagps0=.false.
+      real val, val2, val3 ! to store temporary variables
+      real :: iceith=2000 ! thermal inertia of subterranean ice
+      integer iref,jref
+
+      INTEGER :: itau
+      
+      INTEGER :: nq,numvanle
+      character(len=20) :: txt ! to store some text
+      character(len=50) :: surfacefile ! "surface.nc" (or equivalent file)
+      character(len=150) :: longline
+      integer :: count
+      real :: profile(llm+1) ! to store an atmospheric profile + surface value
+
+!     added by RW for test
+      real pmean, phi0
+
+!     added by BC for equilibrium temperature startup
+      real teque
+
+!     added by BC for cloud fraction setup
+      REAL hice(ngridmx),cloudfrac(ngridmx,nlayermx)
+      REAL totalfrac(ngridmx)
+
+
+!     added by RW for nuketharsis
+      real fact1
+      real fact2
+
+
+c sortie visu pour les champs dynamiques
+c---------------------------------------
+!      INTEGER :: visuid
+!      real :: time_step,t_ops,t_wrt
+!      CHARACTER*80 :: visu_file
+
+      cpp    = 0.
+      preff  = 0.
+      pa     = 0. ! to ensure disaster rather than minor error if we don`t
+                  ! make deliberate choice of these values elsewhere.
+
+! initialize "serial/parallel" related stuff
+      CALL init_phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+      call initcomgeomphy
+! Load tracer number and names:
+      call iniadvtrac(nqtot,numvanle)
+! allocate arrays
+      allocate(q(iip1,jjp1,llm,nqtot))
+      allocate(qsurf(ngridmx,nqtot))
+
+c=======================================================================
+c   Choice of the start file(s) to use
+c=======================================================================
+      write(*,*) 'From which kind of files do you want to create new',
+     .  'start and startfi files'
+      write(*,*) '    0 - from a file start_archive'
+      write(*,*) '    1 - from files start and startfi'
+ 
+c-----------------------------------------------------------------------
+c   Open file(s) to modify (start or start_archive)
+c-----------------------------------------------------------------------
+
+      DO
+         read(*,*,iostat=ierr) choix_1
+         if ((choix_1 /= 0).OR.(choix_1 /=1)) EXIT
+      ENDDO
+
+c     Open start_archive
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~
+      if (choix_1.eq.0) then
+
+        write(*,*) 'Creating start files from:'
+        write(*,*) './start_archive.nc'
+        write(*,*)
+        fichnom = 'start_archive.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening file:',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+        tab0 = 50 
+        Lmodif = 1
+
+c     OR open start and startfi files
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      else
+        write(*,*) 'Creating start files from:'
+        write(*,*) './start.nc and ./startfi.nc'
+        write(*,*)
+        fichnom = 'start.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_dyn)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening file:',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+ 
+        fichnom = 'startfi.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_fi)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening file:',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+
+        tab0 = 0 
+        Lmodif = 0
+
+      endif
+
+
+c=======================================================================
+c  INITIALISATIONS DIVERSES
+c=======================================================================
+
+! Initialize global tracer indexes (stored in tracer.h)
+! ... this has to be done before phyetat0
+      call initracer(ngridmx,nqtot,tname)
+
+! Take care of arrays in common modules
+      ! ALLOCATE ARRAYS in surfdat_h (if not already done, e.g. when using start_archive)
+      IF (.not. ALLOCATED(albedodat)) ALLOCATE(albedodat(ngridmx))
+      IF (.not. ALLOCATED(phisfi)) ALLOCATE(phisfi(ngridmx))
+      IF (.not. ALLOCATED(zmea)) ALLOCATE(zmea(ngridmx))
+      IF (.not. ALLOCATED(zstd)) ALLOCATE(zstd(ngridmx))
+      IF (.not. ALLOCATED(zsig)) ALLOCATE(zsig(ngridmx))
+      IF (.not. ALLOCATED(zgam)) ALLOCATE(zgam(ngridmx))
+      IF (.not. ALLOCATED(zthe)) ALLOCATE(zthe(ngridmx))
+      ! ALLOCATE ARRAYS in comsoil_h (if not already done)
+      IF (.not.ALLOCATED(layer))
+     . ALLOCATE(layer(nsoilmx))
+      IF (.not.ALLOCATED(mlayer))
+     . ALLOCATE(mlayer(0:nsoilmx-1))
+      IF (.not.ALLOCATED(inertiedat))
+     . ALLOCATE(inertiedat(ngridmx,nsoilmx))
+      ! ALLOCATE ARRAYS IN comgeomfi_h (done in inifis usually)
+      IF (.not. ALLOCATED(lati)) ALLOCATE(lati(ngridmx))
+      IF (.not. ALLOCATED(long)) ALLOCATE(long(ngridmx))
+      IF (.not. ALLOCATED(area)) ALLOCATE(area(ngridmx))
+
+c-----------------------------------------------------------------------
+c Lecture du tableau des parametres du run (pour la dynamique)
+c-----------------------------------------------------------------------
+      if (choix_1.eq.0) then
+
+        write(*,*) 'reading tab_cntrl START_ARCHIVE'
+c
+        ierr = NF_INQ_VARID (nid, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+c
+      else if (choix_1.eq.1) then
+
+        write(*,*) 'reading tab_cntrl START'
+c
+        ierr = NF_INQ_VARID (nid_dyn, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid_dyn, nvarid, tab_cntrl)
+#else
+        ierr = NF_GET_VAR_REAL(nid_dyn, nvarid, tab_cntrl)
+#endif
+c
+        write(*,*) 'reading tab_cntrl STARTFI'
+c
+        ierr = NF_INQ_VARID (nid_fi, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid_fi, nvarid, tab_cntrl_bis)
+#else
+        ierr = NF_GET_VAR_REAL(nid_fi, nvarid, tab_cntrl_bis)
+#endif
+c
+        do i=1,50
+          tab_cntrl(i+50)=tab_cntrl_bis(i)
+        enddo
+        write(*,*) 'printing tab_cntrl', tab_cntrl
+        do i=1,100
+          write(*,*) i,tab_cntrl(i)
+        enddo
+	
+        ! Lmodif set to 0 to disable modifications possibility in phyeta0                           
+        write(*,*) 'Reading file START'
+        fichnom = 'start.nc'
+        CALL dynetat0(fichnom,nqtot,vcov,ucov,teta,q,masse,
+     .       ps,phis,time)
+
+        write(*,*) 'Reading file STARTFI'
+        fichnom = 'startfi.nc'
+        CALL phyetat0 (ngridmx,fichnom,tab0,Lmodif,nsoilmx,nqtot,
+     .        day_ini,time,
+     .        tsurf,tsoil,emis,q2,qsurf,   !) ! temporary modif by RDW
+     .        cloudfrac,totalfrac,hice,rnat,pctsrf_sic,tslab,tsea_ice,
+     .        sea_ice)
+
+        ! copy albedo and soil thermal inertia on (local) physics grid
+        do i=1,ngridmx
+          albfi(i) = albedodat(i)
+	  do j=1,nsoilmx
+           ithfi(i,j) = inertiedat(i,j)
+	  enddo
+        ! build a surfithfi(:) using 1st layer of ithfi(:), which might
+        ! be needed later on if reinitializing soil thermal inertia
+          surfithfi(i)=ithfi(i,1)
+        enddo
+        ! also copy albedo and soil thermal inertia on (local) dynamics grid
+        ! so that options below can manipulate either (but must then ensure
+        ! to correctly recast things on physics grid)
+        call gr_fi_dyn(1,ngridmx,iip1,jjp1,albfi,alb)
+        call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,ithfi,ith)
+        call gr_fi_dyn(1,ngridmx,iip1,jjp1,surfithfi,surfith)
+      
+      endif
+c-----------------------------------------------------------------------
+c		Initialisation des constantes dynamique
+c-----------------------------------------------------------------------
+
+      kappa = tab_cntrl(9) 
+      etot0 = tab_cntrl(12)
+      ptot0 = tab_cntrl(13)
+      ztot0 = tab_cntrl(14)
+      stot0 = tab_cntrl(15)
+      ang0 = tab_cntrl(16)
+      write(*,*) "Newstart: kappa,etot0,ptot0,ztot0,stot0,ang0"
+      write(*,*) kappa,etot0,ptot0,ztot0,stot0,ang0
+
+      ! for vertical coordinate
+      preff=tab_cntrl(18) ! reference surface pressure
+      pa=tab_cntrl(17)  ! reference pressure at which coord is purely pressure
+      !NB: in start_archive files tab_cntrl(17)=tab_cntrl(18)=0
+      write(*,*) "Newstart: preff=",preff," pa=",pa
+      yes=' '
+      do while ((yes.ne.'y').and.(yes.ne.'n'))
+        write(*,*) "Change the values of preff and pa? (y/n)"
+        read(*,fmt='(a)') yes
+      end do
+      if (yes.eq.'y') then
+        write(*,*)"New value of reference surface pressure preff?"
+        write(*,*)"   (for Mars, typically preff=610)"
+        read(*,*) preff
+        write(*,*)"New value of reference pressure pa for purely"
+        write(*,*)"pressure levels (for hybrid coordinates)?"
+        write(*,*)"   (for Mars, typically pa=20)"
+        read(*,*) pa
+      endif
+c-----------------------------------------------------------------------
+c   Lecture du tab_cntrl et initialisation des constantes physiques
+c  - pour start:  Lmodif = 0 => pas de modifications possibles
+c                  (modif dans le tabfi de readfi + loin)
+c  - pour start_archive:  Lmodif = 1 => modifications possibles
+c-----------------------------------------------------------------------
+      if (choix_1.eq.0) then
+         ! tabfi requires that input file be first opened by open_startphy(fichnom)
+         fichnom = 'start_archive.nc'
+         call open_startphy(fichnom)
+         call tabfi (ngridmx,nid,Lmodif,tab0,day_ini,lllm,p_rad,
+     .            p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
+      else if (choix_1.eq.1) then
+         fichnom = 'startfi.nc'
+         call open_startphy(fichnom)
+         Lmodif=1 ! Lmodif set to 1 to allow modifications in phyeta0                           
+         call tabfi (ngridmx,nid_fi,Lmodif,tab0,day_ini,lllm,p_rad,
+     .            p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
+      endif
+
+      rad = p_rad
+      omeg = p_omeg
+      g = p_g
+      cpp = p_cpp
+      mugaz = p_mugaz
+      daysec = p_daysec
+
+      kappa = 8.314*1000./(p_mugaz*p_cpp) ! added by RDW
+
+c=======================================================================
+c  INITIALISATIONS DIVERSES
+c=======================================================================
+! Load parameters from run.def file
+      CALL defrun_new( 99, .TRUE. )
+      CALL iniconst 
+      CALL inigeom
+      idum=-1
+      idum=0
+
+c Initialisation coordonnees /aires
+c -------------------------------
+! Note: rlatu(:) and rlonv(:) are commons defined in "comgeom.h"
+!       rlatu() and rlonv() are given in radians
+      latfi(1)=rlatu(1)
+      lonfi(1)=0.
+      DO j=2,jjm
+         DO i=1,iim
+            latfi((j-2)*iim+1+i)=rlatu(j)
+            lonfi((j-2)*iim+1+i)=rlonv(i)
+         ENDDO
+      ENDDO
+      latfi(ngridmx)=rlatu(jjp1)
+      lonfi(ngridmx)=0.
+       
+      ! build airefi(), mesh area on physics grid
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+      ! Poles are single points on physics grid
+      airefi(1)=airefi(1)*iim
+      airefi(ngridmx)=airefi(ngridmx)*iim
+
+! also initialize various physics flags/settings which might be needed
+!    (for instance initracer needs to know about some flags, and/or
+!      'datafile' path may be changed by user)
+      call inifis(ngridmx,llm,nqtot,day_ini,daysec,dtphys,
+     &                latfi,lonfi,airefi,rad,g,r,cpp)
+
+c=======================================================================
+c   lecture topographie, albedo, inertie thermique, relief sous-maille
+c=======================================================================
+
+      if (choix_1.eq.0) then  ! for start_archive files, 
+                              ! where an external "surface.nc" file is needed
+
+c do while((relief(1:3).ne.'mol').AND.(relief(1:3).ne.'pla'))
+c       write(*,*)
+c       write(*,*) 'choix du relief (mola,pla)'
+c       write(*,*) '(Topographie MGS MOLA, plat)'
+c       read(*,fmt='(a3)') relief
+        relief="mola"
+c     enddo
+
+!    First get the correct value of datadir, if not already done:
+        ! default 'datadir' is set in "datafile_mod"
+        call getin("datadir",datadir)
+        write(*,*) 'Available surface data files are:'
+        filestring='ls '//trim(datadir)//' | grep .nc'
+        call system(filestring)
+
+        write(*,*) ''
+        write(*,*) 'Please choose the relevant file',
+     &  ' (e.g. "surface_mars.nc")'
+        write(*,*) ' or "none" to not use any (and set planetary'
+        write(*,*) '  albedo and surface thermal inertia)'
+        read(*,fmt='(a50)') surfacefile
+
+        if (surfacefile.ne."none") then
+
+          CALL datareadnc(relief,surfacefile,phis,alb,surfith,
+     &          zmeaS,zstdS,zsigS,zgamS,ztheS)
+        else
+        ! specific case when not using a "surface.nc" file
+          phis(:,:)=0
+          zmeaS(:,:)=0
+          zstdS(:,:)=0
+          zsigS(:,:)=0
+          zgamS(:,:)=0
+          ztheS(:,:)=0
+          
+          write(*,*) "Enter value of albedo of the bare ground:"
+          read(*,*) alb(1,1)
+          alb(:,:)=alb(1,1)
+          
+          write(*,*) "Enter value of thermal inertia of soil:"
+          read(*,*) surfith(1,1)
+          surfith(:,:)=surfith(1,1)
+        
+        endif ! of if (surfacefile.ne."none")
+
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,surfith,surfithfi)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zmeaS,zmea)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zstdS,zstd)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zsigS,zsig)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zgamS,zgam)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ztheS,zthe)
+
+      endif ! of if (choix_1.eq.0)
+
+
+c=======================================================================
+c  Lecture des fichiers (start ou start_archive)
+c=======================================================================
+
+      if (choix_1.eq.0) then
+
+        write(*,*) 'Reading file START_ARCHIVE'
+        CALL lect_start_archive(date,tsurf,tsoil,emis,q2,
+     &   t,ucov,vcov,ps,teta,phisold_newgrid,q,qsurf,
+     &   surfith,nid,
+     &   rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+        write(*,*) "OK, read start_archive file"
+	! copy soil thermal inertia
+	ithfi(:,:)=inertiedat(:,:)
+	
+        ierr= NF_CLOSE(nid)
+
+      else if (choix_1.eq.1) then 
+         !do nothing, start and startfi have already been read
+      else 
+        CALL exit(1)
+      endif
+
+      dtvr   = daysec/FLOAT(day_step)
+      dtphys   = dtvr * FLOAT(iphysiq)
+
+c=======================================================================
+c 
+c=======================================================================
+
+      do ! infinite loop on list of changes
+
+      write(*,*)
+      write(*,*)
+      write(*,*) 'List of possible changes :'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      write(*,*)
+      write(*,*) 'flat : no topography ("aquaplanet")'
+      write(*,*) 'nuketharsis : no Tharsis bulge'
+      write(*,*) 'bilball : uniform albedo and thermal inertia'
+      write(*,*) 'coldspole : cold subsurface and high albedo at S.pole'
+      write(*,*) 'qname : change tracer name'
+      write(*,*) 't=profile  : read temperature profile in profile.in'
+      write(*,*) 'q=0 : ALL tracer =zero'
+      write(*,*) 'q=x : give a specific uniform value to one tracer'
+      write(*,*) 'q=profile    : specify a profile for a tracer'
+!      write(*,*) 'ini_q : tracers initialisation for chemistry, water an
+!     $d ice   '
+!      write(*,*) 'ini_q-H2O : tracers initialisation for chemistry and 
+!     $ice '
+!      write(*,*) 'ini_q-iceH2O : tracers initialisation for chemistry on
+!     $ly '
+      write(*,*) 'noglacier : Remove tropical H2O ice if |lat|<45'
+      write(*,*) 'watercapn : H20 ice on permanent N polar cap '
+      write(*,*) 'watercaps : H20 ice on permanent S polar cap '
+      write(*,*) 'noacglac  : H2O ice across Noachis Terra'
+      write(*,*) 'oborealis : H2O ice across Vastitas Borealis'
+      write(*,*) 'iceball   : Thick ice layer all over surface'
+      write(*,*) 'wetstart  : start with a wet atmosphere'
+      write(*,*) 'isotherm  : Isothermal Temperatures, wind set to zero'
+      write(*,*) 'radequi   : Earth-like radiative equilibrium temperature
+     $ profile (lat-alt) and winds set to zero'
+      write(*,*) 'coldstart : Start X K above the CO2 frost point and 
+     $set wind to zero (assumes 100% CO2)'
+      write(*,*) 'co2ice=0 : remove CO2 polar cap'
+      write(*,*) 'ptot : change total pressure'
+      write(*,*) 'emis : change surface emissivity'
+      write(*,*) 'therm_ini_s : Set soil thermal inertia to reference sur
+     &face values'
+      write(*,*) 'slab_ocean_0 : initialisation of slab 
+     $ocean variables'
+
+        write(*,*)
+        write(*,*) 'Change to perform ?'
+        write(*,*) '   (enter keyword or return to end)'
+        write(*,*)
+
+        read(*,fmt='(a20)') modif
+        if (modif(1:1) .eq. ' ')then
+         exit ! exit loop on changes
+        endif
+
+        write(*,*)
+        write(*,*) trim(modif) , ' : '
+
+c       'flat : no topography ("aquaplanet")'
+c       -------------------------------------
+        if (trim(modif) .eq. 'flat') then
+c         set topo to zero 
+          z_reel(1:iip1,1:jjp1)=0
+          phis(1:iip1,1:jjp1)=g*z_reel(1:iip1,1:jjp1)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+          write(*,*) 'topography set to zero.'
+          write(*,*) 'WARNING : the subgrid topography parameters',
+     &    ' were not set to zero ! => set calllott to F'                    
+
+c        Choice of surface pressure
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish to choose homogeneous surface',
+     &                 'pressure (y) or let newstart interpolate ',
+     &                 ' the previous field  (n)?'
+             read(*,fmt='(a)') yes
+         end do
+         if (yes.eq.'y') then
+           flagps0=.true.
+           write(*,*) 'New value for ps (Pa) ?'
+ 201       read(*,*,iostat=ierr) patm
+            if(ierr.ne.0) goto 201
+             write(*,*)
+             write(*,*) ' new ps everywhere (Pa) = ', patm
+             write(*,*)
+             do j=1,jjp1
+               do i=1,iip1
+                 ps(i,j)=patm
+               enddo
+             enddo
+         end if
+
+c       'nuketharsis : no tharsis bulge for Early Mars'
+c       ---------------------------------------------
+        else if (trim(modif) .eq. 'nuketharsis') then
+
+           DO j=1,jjp1        
+              DO i=1,iim
+                 ig=1+(j-2)*iim +i
+                 if(j.eq.1) ig=1
+                 if(j.eq.jjp1) ig=ngridmx
+
+                 fact1=(((rlonv(i)*180./pi)+100)**2 + 
+     &                (rlatu(j)*180./pi)**2)/65**2 
+                 fact2=exp( -fact1**2.5 )
+
+                 phis(i,j) = phis(i,j) - (phis(i,j)+4000.*g)*fact2
+
+!                 if(phis(i,j).gt.2500.*g)then
+!                    if(rlatu(j)*180./pi.gt.-80.)then ! avoid chopping south polar cap
+!                       phis(i,j)=2500.*g
+!                    endif
+!                 endif
+
+              ENDDO
+           ENDDO
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+
+c       bilball : uniform albedo, thermal inertia
+c       -----------------------------------------
+        else if (trim(modif) .eq. 'bilball') then
+          write(*,*) 'constante albedo and iner.therm:'
+          write(*,*) 'New value for albedo (ex: 0.25) ?'
+ 101      read(*,*,iostat=ierr) alb_bb
+          if(ierr.ne.0) goto 101
+          write(*,*)
+          write(*,*) ' uniform albedo (new value):',alb_bb
+          write(*,*)
+
+          write(*,*) 'New value for thermal inertia (eg: 247) ?'
+ 102      read(*,*,iostat=ierr) ith_bb
+          if(ierr.ne.0) goto 102
+          write(*,*) 'uniform thermal inertia (new value):',ith_bb
+          DO j=1,jjp1
+             DO i=1,iip1
+                alb(i,j) = alb_bb	! albedo
+		do isoil=1,nsoilmx
+                  ith(i,j,isoil) = ith_bb	! thermal inertia
+		enddo
+             END DO
+          END DO
+!          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+c       coldspole : sous-sol de la calotte sud toujours froid
+c       -----------------------------------------------------
+        else if (trim(modif) .eq. 'coldspole') then
+          write(*,*)'new value for the subsurface temperature',
+     &   ' beneath the permanent southern polar cap ? (eg: 141 K)'
+ 103      read(*,*,iostat=ierr) tsud
+          if(ierr.ne.0) goto 103
+          write(*,*)
+          write(*,*) ' new value of the subsurface temperature:',tsud
+c         nouvelle temperature sous la calotte permanente
+          do l=2,nsoilmx
+               tsoil(ngridmx,l) =  tsud
+          end do
+
+
+          write(*,*)'new value for the albedo',
+     &   'of the permanent southern polar cap ? (eg: 0.75)'
+ 104      read(*,*,iostat=ierr) albsud
+          if(ierr.ne.0) goto 104
+          write(*,*)
+
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c         Option 1:  only the albedo of the pole is modified :    
+          albfi(ngridmx)=albsud
+          write(*,*) 'ig=',ngridmx,'   albedo perennial cap ',
+     &    albfi(ngridmx)
+
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+c          Option 2 A haute resolution : coordonnee de la vrai calotte ~    
+c           DO j=1,jjp1
+c             DO i=1,iip1
+c                ig=1+(j-2)*iim +i
+c                if(j.eq.1) ig=1
+c                if(j.eq.jjp1) ig=ngridmx
+c                if ((rlatu(j)*180./pi.lt.-84.).and.
+c     &            (rlatu(j)*180./pi.gt.-91.).and.
+c     &            (rlonv(i)*180./pi.gt.-91.).and.
+c     &            (rlonv(i)*180./pi.lt.0.))         then
+cc    albedo de la calotte permanente fixe a albsud
+c                   alb(i,j)=albsud
+c                   write(*,*) 'lat=',rlatu(j)*180./pi,
+c     &                      ' lon=',rlonv(i)*180./pi
+cc     fin de la condition sur les limites de la calotte permanente
+c                end if
+c             ENDDO
+c          ENDDO
+c      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+c         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+
+c       ptot : Modification of the total pressure: ice + current atmosphere 
+c       -------------------------------------------------------------------
+        else if (trim(modif).eq.'ptot') then
+
+          ! check if we have a co2_ice surface tracer:
+          if (igcm_co2_ice.eq.0) then
+            write(*,*) " No surface CO2 ice !"
+            write(*,*) " only atmospheric pressure will be considered!"
+          endif
+c         calcul de la pression totale glace + atm actuelle
+          patm=0.
+          airetot=0.
+          pcap=0.
+          DO j=1,jjp1
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+                patm = patm + ps(i,j)*aire(i,j)
+                airetot= airetot + aire(i,j)
+                if (igcm_co2_ice.ne.0) then
+                  !pcap = pcap + aire(i,j)*co2ice(ig)*g
+                  pcap = pcap + aire(i,j)*qsurf(ig,igcm_co2_ice)*g
+                endif
+             ENDDO
+          ENDDO
+          ptoto = pcap + patm
+
+          print*,'Current total pressure at surface (co2 ice + atm) ',
+     &       ptoto/airetot
+
+          print*,'new value?'
+          read(*,*) ptotn
+          ptotn=ptotn*airetot
+          patmn=ptotn-pcap
+          print*,'ptoto,patm,ptotn,patmn'
+          print*,ptoto,patm,ptotn,patmn
+          print*,'Mult. factor for pressure (atm only)', patmn/patm
+          do j=1,jjp1
+             do i=1,iip1
+                ps(i,j)=ps(i,j)*patmn/patm
+             enddo
+          enddo
+
+
+
+c        Correction pour la conservation des traceurs
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish to conserve tracer total mass (y)',
+     &              ' or tracer mixing ratio (n) ?'
+             read(*,fmt='(a)') yes
+         end do
+
+         if (yes.eq.'y') then
+           write(*,*) 'OK : conservation of tracer total mass'
+           DO iq =1, nqtot
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=q(i,j,l,iq)*patm/patmn
+                  ENDDO
+               ENDDO
+             ENDDO
+           ENDDO
+          else
+            write(*,*) 'OK : conservation of tracer mixing ratio'
+          end if
+
+c        Correction pour la pression au niveau de la mer
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish fix pressure at sea level (y)',
+     &              ' or not (n) ?'
+             read(*,fmt='(a)') yes
+         end do
+
+         if (yes.eq.'y') then
+           write(*,*) 'Value?'
+		read(*,*,iostat=ierr) psea
+             DO i=1,iip1
+               DO j=1,jjp1
+                    ps(i,j)=psea
+
+                  ENDDO
+               ENDDO
+		write(*,*) 'psea=',psea
+          else
+            write(*,*) 'no'
+          end if
+
+
+c       emis : change surface emissivity (added by RW)
+c       ----------------------------------------------
+        else if (trim(modif).eq.'emis') then
+
+           print*,'new value?'
+           read(*,*) emisread
+
+           do i=1,ngridmx
+              emis(i)=emisread
+           enddo
+
+c       qname : change tracer name
+c       --------------------------
+        else if (trim(modif).eq.'qname') then
+         yes='y'
+         do while (yes.eq.'y')
+          write(*,*) 'Which tracer name do you want to change ?'
+          do iq=1,nqtot
+            write(*,'(i3,a3,a20)')iq,' : ',trim(tname(iq))
+          enddo
+          write(*,'(a35,i3)')
+     &            '(enter tracer number; between 1 and ',nqtot
+          write(*,*)' or any other value to quit this option)'
+          read(*,*) iq
+          if ((iq.ge.1).and.(iq.le.nqtot)) then
+            write(*,*)'Change tracer name ',trim(tname(iq)),' to ?'
+            read(*,*) txt
+            tname(iq)=txt
+            write(*,*)'Do you want to change another tracer name (y/n)?'
+            read(*,'(a)') yes 
+          else
+! inapropiate value of iq; quit this option
+            yes='n'
+          endif ! of if ((iq.ge.1).and.(iq.le.nqtot))
+         enddo ! of do while (yes.ne.'y')
+
+c       q=0 : set tracers to zero
+c       -------------------------
+        else if (trim(modif).eq.'q=0') then
+c          mise a 0 des q (traceurs)
+          write(*,*) 'Tracers set to 0 (1.E-30 in fact)'
+           DO iq =1, nqtot
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=1.e-30
+                  ENDDO
+               ENDDO
+             ENDDO
+           ENDDO
+
+c          set surface tracers to zero
+           DO iq =1, nqtot
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=0.
+             ENDDO
+           ENDDO
+
+c       q=x : initialise tracer manually 
+c       --------------------------------
+        else if (trim(modif).eq.'q=x') then
+             write(*,*) 'Which tracer do you want to modify ?'
+             do iq=1,nqtot
+               write(*,*)iq,' : ',trim(tname(iq))
+             enddo
+             write(*,*) '(choose between 1 and ',nqtot,')'
+             read(*,*) iq 
+             write(*,*)'mixing ratio of tracer ',trim(tname(iq)),
+     &                 ' ? (kg/kg)'
+             read(*,*) val
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=val
+                  ENDDO
+               ENDDO
+             ENDDO
+             write(*,*) 'SURFACE value of tracer ',trim(tname(iq)),
+     &                   ' ? (kg/m2)'
+             read(*,*) val
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=val
+             ENDDO
+
+c       t=profile : initialize temperature with a given profile
+c       -------------------------------------------------------
+        else if (trim(modif) .eq. 't=profile') then
+             write(*,*) 'Temperature profile from ASCII file'
+             write(*,*) "'profile.in' e.g. 1D output"
+             write(*,*) "(one value per line in file; starting with"
+             write(*,*) "surface value, the 1st atmospheric layer"
+             write(*,*) "followed by 2nd, etc. up to top of atmosphere)"
+             txt="profile.in"
+             open(33,file=trim(txt),status='old',form='formatted',
+     &            iostat=ierr)
+             if (ierr.eq.0) then
+               ! OK, found file 'profile_...', load the profile
+               do l=1,llm+1
+                 read(33,*,iostat=ierr) profile(l)
+                 write(*,*) profile(l)
+                 if (ierr.ne.0) then ! something went wrong
+                   exit ! quit loop
+                 endif
+               enddo
+               if (ierr.eq.0) then
+                 tsurf(1:ngridmx)=profile(1)
+                 tsoil(1:ngridmx,1:nsoilmx)=profile(1)
+                 do l=1,llm
+                   Tset(1:iip1,1:jjp1,l)=profile(l+1)
+                   flagtset=.true.
+                 enddo
+                 ucov(1:iip1,1:jjp1,1:llm)=0.
+                 vcov(1:iip1,1:jjm,1:llm)=0.
+                 q2(1:ngridmx,1:nlayermx+1)=0.
+               else
+                 write(*,*)'problem reading file ',trim(txt),' !'
+                 write(*,*)'No modifications to temperature'
+               endif
+             else
+               write(*,*)'Could not find file ',trim(txt),' !'
+               write(*,*)'No modifications to temperature'
+             endif
+
+c       q=profile : initialize tracer with a given profile
+c       --------------------------------------------------
+        else if (trim(modif) .eq. 'q=profile') then
+             write(*,*) 'Tracer profile will be sought in ASCII file'
+             write(*,*) "'profile_tracer' where 'tracer' is tracer name"
+             write(*,*) "(one value per line in file; starting with"
+             write(*,*) "surface value, the 1st atmospheric layer"
+             write(*,*) "followed by 2nd, etc. up to top of atmosphere)"
+             write(*,*) 'Which tracer do you want to set?'
+             do iq=1,nqtot
+               write(*,*)iq,' : ',trim(tname(iq))
+             enddo
+             write(*,*) '(choose between 1 and ',nqtot,')'
+             read(*,*) iq 
+             if ((iq.lt.1).or.(iq.gt.nqtot)) then
+               ! wrong value for iq, go back to menu
+               write(*,*) "wrong input value:",iq
+               cycle
+             endif
+             ! look for input file 'profile_tracer'
+             txt="profile_"//trim(tname(iq))
+             open(41,file=trim(txt),status='old',form='formatted',
+     &            iostat=ierr)
+             if (ierr.eq.0) then
+               ! OK, found file 'profile_...', load the profile
+               do l=1,llm+1
+                 read(41,*,iostat=ierr) profile(l)
+                 if (ierr.ne.0) then ! something went wrong
+                   exit ! quit loop
+                 endif
+               enddo
+               if (ierr.eq.0) then
+                 ! initialize tracer values
+                 qsurf(:,iq)=profile(1)
+                 do l=1,llm
+                   q(:,:,l,iq)=profile(l+1)
+                 enddo
+                 write(*,*)'OK, tracer ',trim(tname(iq)),' initialized '
+     &                    ,'using values from file ',trim(txt)
+               else
+                 write(*,*)'problem reading file ',trim(txt),' !'
+                 write(*,*)'No modifications to tracer ',trim(tname(iq))
+               endif
+             else
+               write(*,*)'Could not find file ',trim(txt),' !'
+               write(*,*)'No modifications to tracer ',trim(tname(iq))
+             endif
+             
+
+c      wetstart : wet atmosphere with a north to south gradient
+c      --------------------------------------------------------
+       else if (trim(modif) .eq. 'wetstart') then
+        ! check that there is indeed a water vapor tracer
+        if (igcm_h2o_vap.eq.0) then
+          write(*,*) "No water vapour tracer! Can't use this option"
+          stop
+        endif
+          DO l=1,llm
+            DO j=1,jjp1
+              DO i=1,iip1
+                q(i,j,l,igcm_h2o_vap)=150.e-6 * (rlatu(j)+pi/2.) / pi
+              ENDDO
+            ENDDO
+          ENDDO
+
+         write(*,*) 'Water mass mixing ratio at north pole='
+     *               ,q(1,1,1,igcm_h2o_vap)
+         write(*,*) '---------------------------south pole='
+     *               ,q(1,jjp1,1,igcm_h2o_vap)
+
+c      noglacier : remove tropical water ice (to initialize high res sim)
+c      --------------------------------------------------
+        else if (trim(modif) .eq. 'noglacier') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+           do ig=1,ngridmx
+             j=(ig-2)/iim +2
+              if(ig.eq.1) j=1
+              write(*,*) 'OK: remove surface ice for |lat|<45'
+              if (abs(rlatu(j)*180./pi).lt.45.) then
+                   qsurf(ig,igcm_h2o_ice)=0.
+              end if
+           end do
+
+
+c      watercapn : H20 ice on permanent northern cap
+c      --------------------------------------------------
+        else if (trim(modif) .eq. 'watercapn') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+
+           DO j=1,jjp1        
+              DO i=1,iim
+                 ig=1+(j-2)*iim +i
+                 if(j.eq.1) ig=1
+                 if(j.eq.jjp1) ig=ngridmx
+
+                 if (rlatu(j)*180./pi.gt.80.) then
+                    qsurf(ig,igcm_h2o_ice)=3.4e3
+                    !do isoil=1,nsoilmx
+                    !   ith(i,j,isoil) = 18000. ! thermal inertia
+                    !enddo
+                   write(*,*)'     ==> Ice mesh North boundary (deg)= ',
+     &                   rlatv(j-1)*180./pi
+                 end if
+              ENDDO
+           ENDDO
+           CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+
+c$$$           do ig=1,ngridmx
+c$$$             j=(ig-2)/iim +2
+c$$$              if(ig.eq.1) j=1
+c$$$              if (rlatu(j)*180./pi.gt.80.) then
+c$$$
+c$$$                   qsurf(ig,igcm_h2o_ice)=1.e5
+c$$$                   qsurf(ig,igcm_h2o_vap)=0.0!1.e5
+c$$$
+c$$$                   write(*,*) 'ig=',ig,'    H2O ice mass (kg/m2)= ',
+c$$$     &              qsurf(ig,igcm_h2o_ice)
+c$$$
+c$$$                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
+c$$$     &              rlatv(j)*180./pi
+c$$$                end if
+c$$$           enddo
+
+c      watercaps : H20 ice on permanent southern cap
+c      -------------------------------------------------
+        else if (trim(modif) .eq. 'watercaps') then
+           if (igcm_h2o_ice.eq.0) then
+              write(*,*) "No water ice tracer! Can't use this option"
+              stop
+           endif
+
+           DO j=1,jjp1        
+              DO i=1,iim
+                 ig=1+(j-2)*iim +i
+                 if(j.eq.1) ig=1
+                 if(j.eq.jjp1) ig=ngridmx
+
+                 if (rlatu(j)*180./pi.lt.-80.) then
+                    qsurf(ig,igcm_h2o_ice)=3.4e3
+                    !do isoil=1,nsoilmx
+                    !   ith(i,j,isoil) = 18000. ! thermal inertia
+                    !enddo
+                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
+     &                   rlatv(j-1)*180./pi
+                 end if
+              ENDDO
+           ENDDO
+           CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+
+c$$$           do ig=1,ngridmx
+c$$$               j=(ig-2)/iim +2
+c$$$               if(ig.eq.1) j=1
+c$$$               if (rlatu(j)*180./pi.lt.-80.) then
+c$$$                  qsurf(ig,igcm_h2o_ice)=1.e5
+c$$$                  qsurf(ig,igcm_h2o_vap)=0.0 !1.e5
+c$$$
+c$$$                  write(*,*) 'ig=',ig,'   H2O ice mass (kg/m2)= ',
+c$$$     &                 qsurf(ig,igcm_h2o_ice)
+c$$$                  write(*,*)'     ==> Ice mesh North boundary (deg)= ',
+c$$$     &                 rlatv(j-1)*180./pi
+c$$$               end if
+c$$$           enddo
+
+
+c       noacglac : H2O ice across highest terrain
+c       --------------------------------------------
+        else if (trim(modif) .eq. 'noacglac') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                if(phis(i,j).gt.1000.*g)then
+                    alb(i,j) = 0.5 ! snow value
+                    do isoil=1,nsoilmx
+                       ith(i,j,isoil) = 18000. ! thermal inertia
+                       ! this leads to rnat set to 'ocean' in physiq.F90
+                       ! actually no, because it is soil not surface
+                    enddo
+                endif
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+
+
+c       oborealis : H2O oceans across Vastitas Borealis
+c       -----------------------------------------------
+        else if (trim(modif) .eq. 'oborealis') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                if(phis(i,j).lt.-4000.*g)then
+!                if( (phis(i,j).lt.-4000.*g)
+!     &               .and. (rlatu(j)*180./pi.lt.0.) )then ! south hemisphere only
+!                    phis(i,j)=-8000.0*g ! proper ocean
+                    phis(i,j)=-4000.0*g ! scanty ocean
+
+                    alb(i,j) = 0.07 ! oceanic value
+                    do isoil=1,nsoilmx
+                       ith(i,j,isoil) = 18000. ! thermal inertia
+                       ! this leads to rnat set to 'ocean' in physiq.F90
+                       ! actually no, because it is soil not surface
+                    enddo
+                endif
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+c       iborealis : H2O ice in Northern plains
+c       --------------------------------------
+        else if (trim(modif) .eq. 'iborealis') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                if(phis(i,j).lt.-4000.*g)then
+                   !qsurf(ig,igcm_h2o_ice)=1.e3
+                   qsurf(ig,igcm_h2o_ice)=241.4 ! to make total 33 kg m^-2
+                endif
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+
+c       oceanball : H2O liquid everywhere
+c       ----------------------------
+        else if (trim(modif) .eq. 'oceanball') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                qsurf(ig,igcm_h2o_vap)=0.0    ! for ocean, this is infinite source
+                qsurf(ig,igcm_h2o_ice)=0.0
+                alb(i,j) = 0.07 ! ocean value
+
+                do isoil=1,nsoilmx
+                   ith(i,j,isoil) = 18000. ! thermal inertia
+                   !ith(i,j,isoil) = 50. ! extremely low for test
+                   ! this leads to rnat set to 'ocean' in physiq.F90
+                enddo
+
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+c       iceball : H2O ice everywhere
+c       ----------------------------
+        else if (trim(modif) .eq. 'iceball') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                qsurf(ig,igcm_h2o_vap)=-50.    ! for ocean, this is infinite source
+                qsurf(ig,igcm_h2o_ice)=50.     ! == to 0.05 m of oceanic ice
+                alb(i,j) = 0.6 ! ice albedo value
+
+                do isoil=1,nsoilmx
+                   !ith(i,j,isoil) = 18000. ! thermal inertia
+                   ! this leads to rnat set to 'ocean' in physiq.F90
+                enddo
+
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+c       isotherm : Isothermal temperatures and no winds
+c       -----------------------------------------------
+        else if (trim(modif) .eq. 'isotherm') then
+
+          write(*,*)'Isothermal temperature of the atmosphere, 
+     &           surface and subsurface'
+          write(*,*) 'Value of this temperature ? :'
+ 203      read(*,*,iostat=ierr) Tiso
+          if(ierr.ne.0) goto 203
+
+          tsurf(1:ngridmx)=Tiso
+          
+          tsoil(1:ngridmx,1:nsoilmx)=Tiso
+          
+          Tset(1:iip1,1:jjp1,1:llm)=Tiso
+          flagtset=.true.
+          
+          ucov(1:iip1,1:jjp1,1:llm)=0
+          vcov(1:iip1,1:jjm,1:llm)=0
+          q2(1:ngridmx,1:nlayermx+1)=0
+
+c       radequi : Radiative equilibrium profile of temperatures and no winds
+c       --------------------------------------------------------------------
+        else if (trim(modif) .eq. 'radequi') then
+
+          write(*,*)'radiative equilibrium temperature profile'       
+
+          do ig=1, ngridmx
+             teque= 335.0-60.0*sin(latfi(ig))*sin(latfi(ig))-
+     &            10.0*cos(latfi(ig))*cos(latfi(ig))
+             tsurf(ig) = MAX(220.0,teque)
+          end do
+          do l=2,nsoilmx
+             do ig=1, ngridmx
+                tsoil(ig,l) = tsurf(ig)
+             end do
+          end do
+          DO j=1,jjp1
+             DO i=1,iim
+                Do l=1,llm
+                   teque=335.-60.0*sin(rlatu(j))*sin(rlatu(j))-
+     &                  10.0*cos(rlatu(j))*cos(rlatu(j))
+                   Tset(i,j,l)=MAX(220.0,teque)
+                end do
+             end do
+          end do
+          flagtset=.true.
+          ucov(1:iip1,1:jjp1,1:llm)=0
+          vcov(1:iip1,1:jjm,1:llm)=0
+          q2(1:ngridmx,1:nlayermx+1)=0
+
+c       coldstart : T set 1K above CO2 frost point and no winds
+c       ------------------------------------------------
+        else if (trim(modif) .eq. 'coldstart') then
+
+          write(*,*)'set temperature of the atmosphere,' 
+     &,'surface and subsurface how many degrees above CO2 frost point?'
+ 204      read(*,*,iostat=ierr) Tabove
+          if(ierr.ne.0) goto 204
+
+            DO j=1,jjp1
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+            tsurf(ig) = (-3167.8)/(log(.01*ps(i,j))-23.23)+Tabove
+             END DO
+            END DO
+          do l=1,nsoilmx
+            do ig=1, ngridmx
+              tsoil(ig,l) = tsurf(ig)
+            end do
+          end do
+          DO j=1,jjp1
+           DO i=1,iim
+            Do l=1,llm
+               pp = aps(l) +bps(l)*ps(i,j) 
+               Tset(i,j,l)=(-3167.8)/(log(.01*pp)-23.23)+Tabove
+            end do
+           end do
+          end do
+
+          flagtset=.true.
+          ucov(1:iip1,1:jjp1,1:llm)=0
+          vcov(1:iip1,1:jjm,1:llm)=0
+          q2(1:ngridmx,1:nlayermx+1)=0
+
+
+c       co2ice=0 : remove CO2 polar ice caps'
+c       ------------------------------------------------
+        else if (trim(modif) .eq. 'co2ice=0') then
+         ! check that there is indeed a co2_ice tracer ...
+          if (igcm_co2_ice.ne.0) then
+           do ig=1,ngridmx
+              !co2ice(ig)=0
+              qsurf(ig,igcm_co2_ice)=0
+              emis(ig)=emis(ngridmx/2)
+           end do
+          else
+            write(*,*) "Can't remove CO2 ice!! (no co2_ice tracer)"
+          endif
+        
+!       therm_ini_s: (re)-set soil thermal inertia to reference surface values
+!       ----------------------------------------------------------------------
+
+	else if (trim(modif) .eq. 'therm_ini_s') then
+!          write(*,*)"surfithfi(1):",surfithfi(1)
+	  do isoil=1,nsoilmx
+	    inertiedat(1:ngridmx,isoil)=surfithfi(1:ngridmx)
+	  enddo
+          write(*,*)'OK: Soil thermal inertia has been reset to referenc
+     &e surface values'
+!	  write(*,*)"inertiedat(1,1):",inertiedat(1,1)
+	  ithfi(:,:)=inertiedat(:,:)
+	 ! recast ithfi() onto ith()
+	 call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,ithfi,ith)
+! Check:
+!         do i=1,iip1
+!           do j=1,jjp1
+!             do isoil=1,nsoilmx
+!               write(77,*) i,j,isoil,"  ",ith(i,j,isoil)
+!             enddo
+!           enddo
+!	 enddo
+
+
+
+c       slab_ocean_initialisation
+c       ------------------------------------------------
+        else if (trim(modif) .eq. 'slab_ocean_0') then
+        write(*,*)'OK: initialisation of slab ocean' 
+
+      DO ig=1, ngridmx
+         rnat(ig)=1.
+         tslab(ig,1)=0.
+         tslab(ig,2)=0.
+         tsea_ice(ig)=0.
+         sea_ice(ig)=0.
+         pctsrf_sic(ig)=0.
+         
+         if(ithfi(ig,1).GT.10000.)then
+           rnat(ig)=0.
+           phisfi(ig)=0.
+           tsea_ice(ig)=273.15-1.8
+           tslab(ig,1)=tsurf(ig)
+           tslab(ig,2)=tsurf(ig)!*2./3.+(273.15-1.8)/3.
+          endif
+
+      ENDDO
+          CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,phisfi,phis)
+
+
+
+        else
+          write(*,*) '       Unknown (misspelled?) option!!!'
+        end if ! of if (trim(modif) .eq. '...') elseif ...
+
+
+
+       enddo ! of do ! infinite loop on liste of changes
+
+ 999  continue
+
+ 
+c=======================================================================
+c   Initialisation for cloud fraction and oceanic ice (added by BC 2010)
+c=======================================================================
+      DO ig=1, ngridmx
+         totalfrac(ig)=0.5
+         DO l=1,llm
+            cloudfrac(ig,l)=0.5
+         ENDDO
+! Ehouarn, march 2012: also add some initialisation for hice
+         hice(ig)=0.0
+      ENDDO
+      
+c========================================================
+
+!      DO ig=1,ngridmx
+!         IF(tsurf(ig) .LT. 273.16-1.8) THEN
+!            hice(ig)=(273.16-1.8-tsurf(ig))/(273.16-1.8-240)*1.
+!            hice(ig)=min(hice(ig),1.0)
+!         ENDIF
+!      ENDDO
+
+
+
+
+c=======================================================================
+c   Correct pressure on the new grid (menu 0)
+c=======================================================================
+
+
+      if ((choix_1.eq.0).and.(.not.flagps0)) then
+        r = 1000.*8.31/mugaz
+
+        do j=1,jjp1
+          do i=1,iip1
+             ps(i,j) = ps(i,j) *
+     .            exp((phisold_newgrid(i,j)-phis(i,j)) /
+     .                                  (t(i,j,1) * r))
+          end do
+        end do
+
+c periodicite de ps en longitude
+        do j=1,jjp1
+          ps(1,j) = ps(iip1,j)
+        end do
+      end if
+
+         
+c=======================================================================
+c=======================================================================
+
+c=======================================================================
+c    Initialisation de la physique / ecriture de newstartfi :
+c=======================================================================
+
+
+      CALL inifilr 
+      CALL pression(ip1jmp1, ap, bp, ps, p3d)
+
+c-----------------------------------------------------------------------
+c   Initialisation  pks:
+c-----------------------------------------------------------------------
+
+      CALL exner_hyb(ip1jmp1, ps, p3d, beta, pks, pk, pkf)
+! Calcul de la temperature potentielle teta
+
+      if (flagtset) then
+          DO l=1,llm
+             DO j=1,jjp1
+                DO i=1,iim
+                   teta(i,j,l) = Tset(i,j,l) * cpp/pk(i,j,l)
+                ENDDO
+                teta (iip1,j,l)= teta (1,j,l)
+             ENDDO
+          ENDDO
+      else if (choix_1.eq.0) then
+         DO l=1,llm
+            DO j=1,jjp1
+               DO i=1,iim
+                  teta(i,j,l) = t(i,j,l) * cpp/pk(i,j,l)
+               ENDDO
+               teta (iip1,j,l)= teta (1,j,l)
+            ENDDO
+         ENDDO
+      endif
+
+C Calcul intermediaire
+c
+      if (choix_1.eq.0) then
+         CALL massdair( p3d, masse  )
+c
+         print *,' ALPHAX ',alphax
+
+         DO  l = 1, llm
+           DO  i    = 1, iim
+             xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+             xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+           ENDDO
+             xpn      = SUM(xppn)/apoln
+             xps      = SUM(xpps)/apols
+           DO i   = 1, iip1
+             masse(   i   ,   1     ,  l )   = xpn
+             masse(   i   ,   jjp1  ,  l )   = xps
+           ENDDO
+         ENDDO
+      endif
+      phis(iip1,:) = phis(1,:)
+
+      itau=0
+      if (choix_1.eq.0) then
+         day_ini=int(date)
+      endif
+c
+      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+      CALL caldyn0( itau,ucov,vcov,teta,ps,masse,pk,phis ,
+     *                phi,w, pbaru,pbarv,day_ini+time )
+
+          
+      CALL dynredem0("restart.nc",day_ini,anneeref,phis,nqtot)
+      CALL dynredem1("restart.nc",0.0,vcov,ucov,teta,q,nqtot,masse,ps) 
+C
+C Ecriture etat initial physique
+C
+
+      call physdem0("restartfi.nc",lonfi,latfi,nsoilmx,ngridmx,llm,
+     &              nqtot,dtphys,real(day_ini),0.0,
+     &              airefi,albfi,ithfi,zmea,zstd,zsig,zgam,zthe)
+      call physdem1("restartfi.nc",nsoilmx,ngridmx,llm,nq,
+     &                dtphys,real(day_ini),
+     &                tsurf,tsoil,emis,q2,qsurf,
+     &                cloudfrac,totalfrac,hice,
+     &                rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+
+c=======================================================================
+c	Formats 
+c=======================================================================
+
+   1  FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lllm =',i4,2x,'lue sur le fichier demar
+     *rage est differente de la valeur parametree llm =',i4//)
+
+      write(*,*) "newstart: All is well that ends well."
+
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newtrelax.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newtrelax.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/newtrelax.F90	(revision 222)
@@ -0,0 +1,132 @@
+subroutine newtrelax(ngrid,mu0,sinlat,popsk,temp,pplay,pplev,dtrad,firstcall) 
+        
+  implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "netcdf.inc"
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Alternative Newtonian radiative transfer scheme.
+!     
+!     Authors
+!     -------
+!     R. Wordsworth (2010)
+!     
+!==================================================================
+ 
+  integer ngrid
+ 
+  ! Input
+  real mu0(ngrid)                    ! cosine of sun incident angle
+  real sinlat(ngrid)                 ! sine of latitude
+  real temp(ngrid,nlayermx)          ! temperature at each layer (K)
+  real pplay(ngrid,nlayermx)         ! pressure at each layer (Pa)
+  real pplev(ngrid,nlayermx+1)       ! pressure at each level (Pa)
+  real popsk(ngrid,nlayermx)         ! pot. T to T converter
+
+  ! Output
+  real dtrad(ngrid,nlayermx) 
+
+  ! Internal
+  real Trelax_V, Trelax_H
+  real,allocatable,dimension(:,:),save :: Trelax
+
+  real T_trop ! relaxation temperature at tropopause (K)
+  real T_surf ! relaxation temperature at surface (K)
+  real dT_EP  ! Equator-Pole relaxation temperature difference (K)
+
+  real sig, f_sig, sig_trop
+  integer l,ig
+  logical firstcall
+
+
+  logical tidallocked
+  parameter (tidallocked = .true.)
+
+  ! Setup relaxation temperature  
+  if(firstcall) then
+
+     ALLOCATE(Trelax(ngrid,nlayermx))
+
+     print*,'-----------------------------------------------------'
+     print*,'| ATTENTION: You are using a Newtonian cooling scheme'
+     print*,'| for the radiative transfer. This means that ALL'
+     print*,'| other physics subroutines must be switched off.'
+     print*,'-----------------------------------------------------'
+
+     if(tidallocked)then
+        do ig=1,ngrid
+
+           T_surf = 126. + 239.*mu0(ig)
+           T_trop = 140. + 52.*mu0(ig)
+           do l=1,nlayermx
+
+              if(mu0(ig).le.0.0)then ! night side
+                 Trelax(ig,l)=0.0
+              else                   ! day side
+                 Trelax(ig,l) = T_surf*popsk(ig,l)
+                 if (Trelax(ig,l).lt.T_trop) Trelax(ig,l) = T_trop
+              endif
+
+           enddo
+        enddo
+
+     else
+
+        T_trop = 200.
+        T_surf = 288.
+        dT_EP  = 70.
+
+        sig_trop=(T_trop/T_surf)**(1./rcp)
+
+        do l=1,nlayermx
+           do ig=1,ngrid
+
+              ! vertically varying component
+              Trelax_V = T_surf*popsk(ig,l)
+              if (Trelax_V.lt.T_trop) Trelax_V = T_trop
+              
+              ! horizontally varying component
+              sig = pplay(ig,l)/pplev(ig,1)
+              if(sig.ge.sig_trop)then
+                 f_sig=sin((pi/2)*((sig-sig_trop)/(1-sig_trop)))
+              else
+                 f_sig=0.0
+              endif
+              Trelax_H = -f_sig*dT_EP*(sinlat(ig)**2 - 1./3.)
+              
+              Trelax(ig,l) = Trelax_V + Trelax_H            
+           
+           enddo
+        enddo
+
+     endif
+
+     firstcall=.false.
+ 
+  endif
+
+  ! Calculate radiative forcing
+  do l=1,nlayermx
+     do ig=1,ngrid
+        dtrad(ig,l) = -(temp(ig,l) - Trelax(ig,l)) / tau_relax
+        if(temp(ig,l).gt.500.)then ! Trelax(ig,l))then
+           print*,'ig=',ig
+           print*,'l=',l
+           print*,'temp=',temp(ig,l)
+           print*,'Trelax=',Trelax(ig,l)
+        endif
+     enddo
+  enddo
+
+  call writediagfi(ngrid,'Tref','rad forc temp','K',3,Trelax)
+  !call writediagfi(ngrid,'ThetaZ','stellar zenith angle','deg',2,mu0)
+
+  return
+end subroutine newtrelax
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ocean_slab_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ocean_slab_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/ocean_slab_mod.F90	(revision 222)
@@ -0,0 +1,787 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ocean_slab_mod.F90,v 1.3 2008-02-04 16:24:28 fairhead Exp $
+!
+MODULE ocean_slab_mod
+!
+! This module is used for both surface ocean and sea-ice when using the slab ocean,
+! "ocean=slab".
+!
+
+
+      use slab_ice_h
+      use watercommon_h, only: T_h2O_ice_liq
+      use surf_heat_transp_mod
+      implicit none
+
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+
+
+
+  
+  !LOGICAL, PRIVATE, SAVE  :: ok_slab_sic,ok_slab_heaT_h2O_ice_liqBS
+  !$OMP THREADPRIVATE(ok_slab_sic,ok_slab_heaT_h2O_ice_liqBS)
+  !INTEGER, PRIVATE, SAVE                           :: slab_ekman, slab_cadj
+  !$OMP THREADPRIVATE(slab_ekman,slab_cadj)
+  INTEGER, PRIVATE, SAVE                           :: lmt_pas, julien, idayvrai
+  !$OMP THREADPRIVATE(lmt_pas,julien,idayvrai)
+  INTEGER, PRIVATE, SAVE                           :: cpl_pas
+  !$OMP THREADPRIVATE(cpl_pas)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_seaice
+  !$OMP THREADPRIVATE(tmp_seaice)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: tmp_tslab_loc
+  !$OMP THREADPRIVATE(tmp_tslab_loc)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slab_bils
+  !$OMP THREADPRIVATE(slab_bils)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE , SAVE  :: lmt_bils
+  !$OMP THREADPRIVATE(lmt_bils)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: tmp_pctsrf_slab
+  !$OMP THREADPRIVATE(tmp_pctsrf_slab)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: tmp_tslab
+  !$OMP THREADPRIVATE(tmp_tslab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_radsol
+  !$OMP THREADPRIVATE(tmp_radsol)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: dt_hdiff
+  !$OMP THREADPRIVATE(dt_hdiff)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: dt_ekman
+  !$OMP THREADPRIVATE(dt_ekman)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slabh
+  !$OMP THREADPRIVATE(slabh)
+  LOGICAL, PRIVATE, SAVE                           :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_init(ngrid,dtime, tslab_rst, seaice_rst, pctsrf_rst)
+
+      use slab_ice_h
+
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+
+
+! Input variables
+!****************************************************************************************
+        
+    integer,intent(in) :: ngrid ! number of atmospherci columns
+    REAL, INTENT(IN)                         :: dtime
+! Variables read from restart file
+    REAL, DIMENSION(ngrid,noceanmx), INTENT(IN)  :: tslab_rst         
+    REAL, DIMENSION(ngrid), INTENT(IN)        :: seaice_rst
+    REAL, DIMENSION(ngrid), INTENT(IN) :: pctsrf_rst
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: error
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'ocean_slab_intit'
+
+
+    print*,'************************'
+    print*,'SLAB OCEAN est actif, prenez precautions !'
+    print*,'************************'    
+
+! Lecture des parametres:
+!    CALL getpar('ok_slab_sic',.true.,ok_slab_sic,'glace de mer dans slab')
+!    CALL getpar('slab_ekman',0,slab_ekman,'type transport Ekman pour slab (0=rien)')
+!    CALL getpar('slab_cadj',1,slab_cadj,'type ajustement conv slab 2 couches')
+
+! Allocate variables initialize from restart fields
+      ALLOCATE(tmp_tslab(ngrid,noceanmx), stat = error)
+      IF (error /= 0) THEN
+         abort_message='Pb allocation tmp_tslab'
+         CALL abort_gcm(modname,abort_message,1)
+      ENDIF
+      tmp_tslab(:,:) = tslab_rst(:,:)
+      ALLOCATE(tmp_tslab_loc(ngrid,noceanmx), stat = error)
+      IF (error /= 0) THEN
+         abort_message='Pb allocation tmp_tslab_loc'
+         CALL abort_gcm(modname,abort_message,1)
+      ENDIF
+      tmp_tslab_loc(:,:) = tslab_rst(:,:)
+
+    ALLOCATE(tmp_seaice(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_seaice'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_seaice(:) = seaice_rst(:)
+
+    ALLOCATE(tmp_pctsrf_slab(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_pctsrf_slab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_pctsrf_slab(:) = pctsrf_rst(:)
+    
+! Allocate some other variables internal in module mod_oceanslab
+    ALLOCATE(tmp_radsol(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_radsol'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_o(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+    ALLOCATE(tmp_flux_g(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! a mettre un slab_bils aussi en force !!!
+    ALLOCATE(slab_bils(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slab_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    slab_bils(:) = 0.0   
+
+    ALLOCATE(dt_hdiff(ngrid,noceanmx), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation dt_hdiff'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    dt_hdiff = 0.0   
+
+    ALLOCATE(dt_ekman(ngrid,noceanmx), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation dt_hdiff'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    dt_ekman = 0.0   
+
+
+    ALLOCATE(lmt_bils(ngrid), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation lmt_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    lmt_bils(:) = 0.0
+
+    ALLOCATE(slabh(noceanmx), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slabh'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    slabh(1)=50.
+    IF (noceanmx.GE.2) slabh(2)=150.
+    IF (noceanmx.GE.3) slabh(3)=2800.
+
+
+!       CALL init_masquv
+
+
+
+
+  END SUBROUTINE ocean_slab_init
+!
+!****************************************************************************************
+!
+ 
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_ice(dtime, &
+       ngrid, knindex, tsurf, radsol, &
+       precip_snow, snow, evap, &
+       fluxsens,tsurf_new, pctsrf_sic, &
+       taux_slab,tauy_slab,icount)
+
+      use slab_ice_h
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: ngrid
+    INTEGER, DIMENSION(ngrid), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(ngrid), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(ngrid), INTENT(IN)    :: taux_slab
+    REAL, DIMENSION(ngrid), INTENT(IN)    :: tauy_slab
+    REAL, DIMENSION(ngrid), INTENT(IN)    :: evap, fluxsens
+    REAL, DIMENSION(ngrid), INTENT(IN)    :: precip_snow
+    REAL, DIMENSION(ngrid), INTENT(IN)    :: radsol
+    INTEGER, INTENT(IN)                     :: icount
+
+
+!In/Output arguments
+!****************************************************************************************l
+    REAL, DIMENSION(ngrid), INTENT(INOUT)          :: snow
+
+!    REAL, DIMENSION(ngridmx), INTENT(INOUT)          :: agesno
+
+
+! Output arguments
+!****************************************************************************************
+!    REAL, DIMENSION(ngridmx), INTENT(OUT)            :: alb1_new  ! new albedo in visible SW interval
+!    REAL, DIMENSION(ngridmx), INTENT(OUT)            :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(ngrid), INTENT(OUT)            :: tsurf_new     
+    REAL, DIMENSION(ngrid), INTENT(OUT)            :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                 :: i
+    REAL, DIMENSION(ngrid)                :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(ngrid)                :: alb_neig, alb_ice!, tsurf_temp
+    REAL, DIMENSION(ngrid)                :: soilcap, soilflux
+    REAL, DIMENSION(ngrid)                :: zfra
+    REAL                                    :: snow_evap, fonte 
+    REAL, DIMENSION(ngrid,noceanmx)        :: tslab
+    REAL, DIMENSION(ngrid)                :: seaice,tsea_ice ! glace de mer (kg/m2)
+    REAL, DIMENSION(ngrid)                :: pctsrf_new
+
+
+!*****************************************************************************
+
+
+! Initialization of output variables
+!    alb1_new(:) = 0.0
+
+!******************************************************************************
+! F. Codron: 3 cas 
+! -Glace interactive, quantité seaice : T glace suit modèle simple
+! -Pas de glace: T oce peut descendre en dessous de 0°C sans geler
+!*****************************************************************************
+
+       pctsrf_new(:)=tmp_pctsrf_slab(:)
+       tmp_radsol(:)=radsol(:)
+       tmp_flux_o(:)=fluxsens(:)
+
+    DO i = 1, ngrid
+       tsurf_new(i) = tsurf(knindex(i))
+       seaice(i)=tmp_seaice(knindex(i))
+
+
+
+       IF (pctsrf_new(knindex(i)) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_new(i) = T_h2O_ice_liq - 1.8
+          !IF (soil_model) tsoil(i,:) = T_h2O_ice_liq -1.8
+       ENDIF
+    ENDDO
+    tmp_flux_g(:) = 0.0
+    tsea_ice(:)=T_h2O_ice_liq-1.8
+! Calculs flux glace/mer et glace/air
+    IF (ok_slab_sic) THEN   
+!*********************************
+! Calcul de beta, heat capacity
+!********************************* 
+!    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+!    IF ((soil_model)) THEN 
+
+!    ELSE 
+!       dif_grnd = 1.0 / tau_gl
+!       cal = RCPD * calice
+!       WHERE (snow > 0.0) cal = RCPD * calsno 
+!    ENDIF
+!    tsurf_temp = tsurf_new
+!    beta = 1.0
+
+
+! **********************************************
+! Evolution avec glace interactive:
+! *************************************
+!      tsurf_new=tsurf_temp
+      DO i = 1, ngrid
+        IF (pctsrf_new(knindex(i)) .GT. epsfra) THEN
+! *************************************
+! + Calcul Flux entre glace et océan 
+! *************************************
+          tmp_flux_g(knindex(i))=(tsurf_new(i)-(T_h2O_ice_liq-1.8)) &
+            * ice_cond*ice_den/seaice(i)
+
+! ****************************************
+! + Calcul nouvelle température de la glace 
+! ****************************************
+          tsurf_new(i)=tsurf_new(i)+2*(radsol(i)+fluxsens(i) &
+             -tmp_flux_g(knindex(i))) &
+             /(ice_cap*seaice(i))*dtime
+
+! ***************************************
+! + Precip and evaporation of snow and ice
+! ***************************************
+! Add precip
+          IF (precip_snow(i).GT.0.) THEN
+            snow(i)=snow(i)+precip_snow(i)*dtime
+          ENDIF
+! Evaporation 
+          snow_evap=0.
+          IF (evap(i).GT.0.) THEN
+            snow_evap = MIN (snow(i) / dtime, evap(i))
+            snow(i) = snow(i) - snow_evap*dtime
+            snow(i) = MAX(0.0, snow(i))
+            seaice(i)=MAX(0.0,seaice(i)-(evap(i)-snow_evap)*dtime)
+          ENDIF
+        
+! *****************************************
+! + Fonte neige & glace par le haut
+! *****************************************
+! Snow melt
+          IF ((snow(i) > epsfra) .AND. (tsurf_new(i) >= T_h2O_ice_liq)) THEN
+            fonte=MIN(MAX((tsurf_new(i)-T_h2O_ice_liq)*seaice(i) &
+                  /2.*ice_cap/ice_lat,0.0),snow(i))
+            snow(i) = MAX(0.,(snow(i)-fonte))
+            tsurf_new(i)=tsurf_new(i)-fonte*2*ice_lat/(seaice(i)*ice_cap)
+          ENDIF
+          snow(i)=MIN(snow(i),3000.)
+! Ice melt
+          IF ((seaice(i) > epsfra) .AND. (tsurf_new(i) >= T_h2O_ice_liq)) THEN       
+             fonte=seaice(i)*ice_cap*(tsurf_new(i)-T_h2O_ice_liq) &
+                  /(2*ice_lat+ice_cap*1.8)
+             CALL icemelt(fonte,pctsrf_new(knindex(i)),seaice(i))
+             tmp_flux_g(knindex(i))=tmp_flux_g(knindex(i)) &
+                                 +fonte*ice_lat/dtime
+             tsurf_new(i)=T_h2O_ice_liq
+          ENDIF  
+          tmp_seaice(knindex(i))=seaice(i)
+        ENDIF!(pctsrf_new(knindex(i)) .GT. epsfra)
+          tsea_ice(knindex(i))=tsurf_new(i)
+
+      ENDDO
+    ENDIF
+! ******************************************
+! CALL interfoce:
+! cumul/calcul nouvelle T_h2O_ice_liqce
+! fonte/formation de glace en dessous
+! ******************************************   
+    tslab = tmp_tslab
+    
+    CALL interfoce_slab(ngrid, dtime, &
+         tmp_radsol, tmp_flux_o, tmp_flux_g, tmp_pctsrf_slab, &
+         tslab, tsea_ice, pctsrf_new,taux_slab,tauy_slab,icount)
+    
+    tmp_pctsrf_slab(:)=pctsrf_new(:)
+!    tmp_pctsrf_slab(:,is_oce)=1.0-tmp_pctsrf_slab(:) &
+!            -tmp_pctsrf_slab(:,is_lic)-tmp_pctsrf_slab(:,is_ter)
+
+    DO i=1, ngrid
+       tmp_tslab(knindex(i),:)=tslab(knindex(i),:)
+       seaice(i)=tmp_seaice(knindex(i))
+       tsurf_new(i)=tsea_ice(knindex(i))
+
+    ENDDO
+
+! ****************************
+! calcul new albedo
+! ****************************
+! Albedo neige
+!    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+!    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+! Fraction neige (hauteur critique 45kg/m2~15cm)
+!    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/45.0))
+! Albedo glace
+!    IF (ok_slab_sicOBS) THEN
+!       alb_ice=0.6
+!    ELSE
+!       alb_ice(1:knon)=alb_ice_max-(alb_ice_max-alb_ice_min) &
+!         *exp(-seaice(1:knon)/h_alb_ice)
+!    ENDIF
+!Albedo final
+!    alb1_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & 
+!         alb_ice * (1.0-zfra(1:knon))
+!    alb2_new(:) = alb1_new(:)
+
+        
+! ********************************
+! Return the fraction of sea-ice
+! ********************************
+    pctsrf_sic(:) =  tmp_pctsrf_slab(:)
+
+
+  END SUBROUTINE ocean_slab_ice
+
+
+! 
+!***************************************************************************
+!
+  SUBROUTINE interfoce_slab(ngrid, dtime, &
+       radsol, fluxo, fluxg, pctsrf, &
+       tslab, tsea_ice, pctsrf_slab, &
+       taux_slab, tauy_slab,icount)
+!
+! Cette routine calcule la temperature d'un slab ocean, la glace de mer 
+! et les pourcentages de la maille couverte par l'ocean libre et/ou 
+! la glace de mer pour un "slab" ocean de 50m
+!
+! Conception: Laurent Li
+! Re-ecriture + adaptation LMDZ4: I. Musat
+! Transport, nouveau modèle glace, 2 couches: F.Codron
+!
+! input:
+!   klon         nombre T_h2O_ice_liqtal de points de grille
+!   itap         numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   ijour        jour dans l'annee en cours
+!   radsol       rayonnement net au sol (LW + SW)
+!   fluxo        flux turbulent (sensible + latent) sur les mailles oceaniques 
+!   fluxg        flux de conduction entre la surface de la glace de mer et l'ocean
+!   pctsrf       tableau des pourcentages de surface de chaque maille
+! output: 
+!   tslab        temperature de l'ocean libre
+!   tsea_ice         temperature de la glace (surface)
+!   pctsrf_slab  "pourcentages" (valeurs entre 0. et 1.) surfaces issus du slab
+
+    use slab_ice_h 
+
+#include "dimensions.h"
+#include "comcstfi.h"
+!    INCLUDE "iniprint.h"
+#include "callkeys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: ngrid,icount
+!    INTEGER, INTENT(IN)                       :: itap
+    REAL, INTENT(IN)                          :: dtime       ! not used
+!    INTEGER, INTENT(IN)                       :: ijour
+    REAL, DIMENSION(ngrid), INTENT(IN)         :: radsol
+    REAL, DIMENSION(ngrid), INTENT(IN)         :: fluxo
+    REAL, DIMENSION(ngrid), INTENT(IN)         :: fluxg
+    REAL, DIMENSION(ngrid), INTENT(IN)  :: pctsrf
+    REAL, DIMENSION(ngrid), INTENT(IN)  :: taux_slab
+    REAL, DIMENSION(ngrid), INTENT(IN)  :: tauy_slab
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(ngrid,noceanmx), INTENT(OUT) :: tslab
+    REAL, DIMENSION(ngrid), INTENT(INOUT)       :: pctsrf_slab
+    REAL, DIMENSION(ngrid), INTENT(INOUT)       :: tsea_ice
+
+! Local variables
+!****************************************************************************************
+    REAL                    :: fonte,t_cadj
+    INTEGER                 :: i,k,kt,kb
+    REAL                    :: zz, za, zb
+    REAL                    :: cyang ! capacite calorifique slab J/(m2 K)
+    REAL, PARAMETER         :: tau_conv=432000. ! temps ajust conv (5 jours)
+    REAL, DIMENSION(ngrid,noceanmx) :: dtdiff_loc,dtekman_loc
+
+
+
+!***************************************************
+! Capacite calorifique de la couche de surface
+    cyang=capcalocean!slabh(1)*4.228e+06
+    cpl_pas=1!4*iradia
+
+!
+! lecture du bilan au sol lmt_bils issu d'une simulation forcee en debut de journee
+!!    julien = MOD(ijour,360)
+!!    IF (ok_slab_heaT_h2O_ice_liqBS .and. (MOD(itap,lmt_pas) .EQ. 1)) THEN  
+!!       ! 1er pas de temps de la journee
+!!       idayvrai = ijour
+!!       CALL condsurf(julien,idayvrai, lmt_bils)
+!!    ENDIF
+
+! ----------------------------------------------
+! A chaque pas de temps: cumul flux de chaleur
+! ----------------------------------------------
+! bilan du flux de chaleur dans l'ocean :
+!
+    DO i = 1, ngrid
+       za = radsol(i) + fluxo(i)
+       zb = fluxg(i)
+!       IF(((1-pctsrf(i)).GT.epsfra).OR. &
+!            (pctsrf(i).GT.epsfra)) THEN
+          slab_bils(i)=slab_bils(i)+(za*(1-pctsrf(i)) &
+               +zb*pctsrf(i))/ cpl_pas
+!       ENDIF
+
+    ENDDO !klon
+
+! ---------------------------------------------
+! T_h2O_ice_liqus les cpl_pas: update de tslab et seaice
+! ---------------------------------------------
+
+    IF (mod(icount-1,cpl_pas).eq.0) THEN !fin de journee
+!
+! ---------------------------------------------
+! Transport de chaleur par circulation
+! Decoupage par pas de temps pour stabilite numérique 
+! (diffusion, schema centre pour advection)
+! ---------------------------------------------
+      dt_hdiff(:,:)=0.
+      dt_ekman(:,:)=0.
+
+      IF (ok_slab_heat_transp) THEN
+!       DO i=1,cpl_pas
+!  Transport diffusif
+!         IF (ok_soil_hdiff) THEN
+             CALL divgrad_phy(noceanmx,tmp_tslab_loc,dtdiff_loc)
+             dtdiff_loc=dtdiff_loc*soil_hdiff*50./SUM(slabh)!*100.
+ !           dtdiff_loc(:,1)=dtdiff_loc(:,1)*soil_hdiff*50./SUM(slabh)*0.8
+ !           dtdiff_loc(:,2)=dtdiff_loc(:,2)*soil_hdiff*50./SUM(slabh)*0.2
+             dt_hdiff=dt_hdiff+dtdiff_loc
+             tmp_tslab_loc=tmp_tslab_loc+dtdiff_loc*dtime
+!         END IF
+
+! Calcul  de transport par Ekman
+
+          CALL slab_ekman2(taux_slab,tauy_slab,tslab,dtekman_loc)
+
+
+!        END SELECT
+!        IF (slab_ekman.GT.0) THEN
+          do k=1,noceanmx
+            dtekman_loc(:,k)=dtekman_loc(:,k)/(slabh(k)*1000.)!*0.
+          enddo
+          dt_ekman(:,:)=dt_ekman(:,:)+dtekman_loc(:,:)
+          tmp_tslab_loc=tmp_tslab_loc+dtekman_loc*dtime
+!        ENDIF
+!      ENDDO ! time splitting 1,cpl_pas     
+!      IF (slab_ekman.GT.0) THEN
+!	  taux_slab(:)=0.
+!	  tauy_slab(:)=0.
+!      ENDIF
+
+!       print*, 'slab_bils=',slab_bils(1)
+
+
+      ENDIF!(ok_slab_heat_transp)
+
+      DO i = 1, ngrid
+!      IF (((1-pctsrf(i)).GT.epsfra).OR. &
+!             (pctsrf(i).GT.epsfra)) THEN
+! ---------------------------------------------
+! Ajout des flux de chaleur dans l'océan
+! ---------------------------------------
+
+!print*, 'T_h2O_ice_liqcean1=',tmp_tslab_loc(i,1)
+        tmp_tslab_loc(i,1) = tmp_tslab_loc(i,1) + &
+             slab_bils(i)/cyang*dtime*cpl_pas
+
+!print*, 'capcalocean=',capcalocean
+!print*, 'cyang=',cyang
+!print*, 'dT_h2O_ice_liqcean=',slab_bils(i)/cyang*dtime
+!print*, 'T_h2O_ice_liqcean2=',tmp_tslab_loc(i,1)
+
+
+! on remet l'accumulation a 0
+        slab_bils(i) = 0.
+! ---------------------------------------------
+! Glace interactive 
+! ---------------------------------------------
+        IF (ok_slab_sic) THEN
+! Fondre la glace si température > 0. 
+! -----------------------------------
+          IF ((tmp_tslab_loc(i,1).GT.T_h2O_ice_liq-1.8) .AND. (tmp_seaice(i).GT.0.0)) THEN
+            fonte=(tmp_tslab_loc(i,1)-T_h2O_ice_liq+1.8)*cyang &
+                /(ice_lat+ice_cap/2*(T_h2O_ice_liq-1.8-tsea_ice(i)))
+            CALL icemelt(fonte,pctsrf_slab(i),tmp_seaice(i))
+                 tmp_tslab_loc(i,1)=T_h2O_ice_liq-1.8+fonte*ice_lat/cyang
+          ENDIF 
+! fabriquer de la glace si congelation atteinte:
+! ----------------------------------------------
+          IF (tmp_tslab_loc(i,1).LT.(T_h2O_ice_liq-1.8)) THEN
+
+            IF (tmp_seaice(i).LT.h_ice_min) THEN
+! Creation glace nouvelle
+!             IF (pctsrf_slab(i).LT.(epsfra)) THEN
+                 fonte=(T_h2O_ice_liq-1.8-tmp_tslab_loc(i,1))*cyang/ice_lat
+              IF (fonte.GT.h_ice_min*ice_frac_min) THEN
+                tmp_seaice(i)=MIN(h_ice_thin,fonte/ice_frac_min)
+                tmp_seaice(i)=MAX(tmp_seaice(i),fonte/ice_frac_max)
+!             IF (fonte.GT.0) THEN
+!               tmp_seaice(i)=fonte
+                tsea_ice(i)=T_h2O_ice_liq-1.8
+                pctsrf_slab(i)=(1-pctsrf_slab(i))*fonte/tmp_seaice(i)
+!                pctsrf_slab(i)=1.
+                tmp_tslab_loc(i,1)=T_h2O_ice_liq-1.8
+              ENDIF
+            ELSE  
+! glace déjà présente 
+! Augmenter epaisseur
+              fonte=(T_h2O_ice_liq-1.8-tmp_tslab_loc(i,1))*cyang &
+                   /(ice_lat+ice_cap/2*(T_h2O_ice_liq-1.8-tsea_ice(i)))           
+              zz=tmp_seaice(i)
+              tmp_seaice(i)=MAX(zz,MIN(h_ice_thick,fonte+zz))
+! Augmenter couverture (oce libre et h>h_thick) 
+              za=1-pctsrf_slab(i)
+              zb=pctsrf_slab(i)
+              fonte=fonte*za+MAX(0.0,fonte+zz-tmp_seaice(i))*zb
+              pctsrf_slab(i)=MIN(zb+fonte/tmp_seaice(i), &
+                                    (za+zb)*ice_frac_max)
+              fonte=MAX(0.0,fonte-(pctsrf_slab(i)-zb)*tmp_seaice(i))
+! Augmenter epaisseur si couverture complete
+              tmp_seaice(i)=tmp_seaice(i)+fonte/pctsrf_slab(i)
+              tmp_tslab_loc(i,1) = T_h2O_ice_liq-1.8
+            ENDIF ! presence glace
+          ENDIF !congelation
+! vérifier limites de hauteur de glace
+          IF(tmp_seaice(i).GT.h_ice_min) THEN
+            tmp_seaice(i) = MIN(tmp_seaice(i),h_ice_max)
+          ELSE
+            tmp_seaice(i) = 0. 
+            pctsrf_slab(i)=0.
+          ENDIF! (tmp_seaice(i).GT.h_ice_min)
+       
+        ENDIF !(ok_slab_sic) Glace interactive
+! ----------------------------------
+! Ajustement convectif si > 1 layers
+! ----------------------------------
+
+        IF ((noceanmx.GT.1)) THEN
+          DO kt=1,noceanmx-1
+            kb=kt           
+            DO k=kt+1,noceanmx !look for instability
+              IF (tmp_tslab_loc(i,k).GT.tmp_tslab_loc(i,kt)) THEN
+                kb=k
+              ENDIF
+            ENDDO
+            IF (kb.GT.kt) THEN !ajust conv
+!               IF (slab_cadj.EQ.1) THEN
+!             :   t_cadj=SUM(tmp_tslab_loc(i,kt:kb)*slabh(kt:kb))/SUM(slabh(kt:kb))
+!                DO k=kt,kb
+!                  tmp_tslab_loc(i,k)=t_cadj
+!                ENDDO
+!              ELSEIF (slab_cadj.EQ.2) THEN
+                t_cadj=(tmp_tslab_loc(i,kb)-tmp_tslab_loc(i,kt))*dtime/tau_conv*cpl_pas
+                tmp_tslab_loc(i,kt)=tmp_tslab_loc(i,kt)+t_cadj
+                tmp_tslab_loc(i,kb)=tmp_tslab_loc(i,kb)-t_cadj*slabh(kt)/slabh(kb)
+              !ENDIF 
+            ENDIF
+          ENDDO 
+        ENDIF !ajust 2 layers
+!      ENDIF !pctsrf
+      ENDDO !klon
+
+! On met a jour la temperature et la glace
+    tslab  = tmp_tslab_loc
+
+
+    ENDIF !(mod(icount-1,cpl_pas).eq.0)
+
+  END SUBROUTINE interfoce_slab
+!
+!******************************************************************************  
+  SUBROUTINE icemelt(fonte,pctsrf,seaice)
+
+      use slab_ice_h
+
+
+
+     REAL, INTENT(INOUT)  :: pctsrf
+     REAL , INTENT(INOUT)   ::fonte,seaice !kg/m2
+     REAL :: hh !auxilliary
+     REAL :: ff !auxilliary
+
+
+! ice gt h_ice_thick: decrease thickness up T_h2O_ice_liq h_ice_thick
+     IF (seaice.GT.h_ice_thick) THEN
+        hh=seaice
+!        ff=fonte
+        seaice=max(h_ice_thick,hh-fonte)    
+        fonte=max(0.0,fonte+h_ice_thick-hh)
+
+!        seaice=max(0.,hh-fonte)    
+!        fonte=max(0.0,fonte-(seaice-hh))
+!     IF (seaice.LT.epsfra) THEN
+!        pctsrf=0.
+!        seaice=0.
+!        fonte=ff-hh
+!     ENDIF
+
+     ENDIF
+! ice gt h_ice_thin: partially decrease thickness
+     IF ((seaice.GE.h_ice_thin).AND.(fonte.GT.0.0)) THEN
+       hh=seaice
+       seaice=MAX(hh-0.6*fonte,h_ice_thin)
+       fonte=MAX(0.0,fonte-hh+seaice)
+     ENDIF
+! use rest T_h2O_ice_liq decrease area
+       hh=pctsrf
+       pctsrf=MIN(hh,MAX(0.0,hh-fonte/seaice))
+       fonte=MAX(0.0,fonte-(hh-pctsrf)*seaice)
+
+    END SUBROUTINE icemelt
+
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_final!(tslab_rst, seaice_rst)
+
+! This subroutine will send T_h2O_ice_liq phyredem the variables concerning the slab 
+! ocean that should be written T_h2O_ice_liq restart file.
+
+!****************************************************************************************
+
+!    REAL, DIMENSION(ngridmx,noceanmx), INTENT(OUT) :: tslab_rst
+!    REAL, DIMENSION(ngridmx), INTENT(OUT) :: seaice_rst
+
+!****************************************************************************************
+! Set the output variables
+!    tslab_rst(:,:)  = tmp_tslab(:,:)
+!    tslab_rst(:)  = tmp_tslab_loc(:)
+!    seaice_rst(:) = tmp_seaice(:)
+
+! Deallocation of all variables in module
+    DEALLOCATE(tmp_tslab, tmp_tslab_loc, tmp_pctsrf_slab)
+    DEALLOCATE(tmp_seaice, tmp_radsol, tmp_flux_o, tmp_flux_g)
+    DEALLOCATE(slab_bils, lmt_bils)
+    DEALLOCATE(dt_hdiff)
+
+  END SUBROUTINE ocean_slab_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_get_vars(ngrid,tslab_loc, seaice_loc, flux_o_loc, flux_g_loc, &
+       dt_hdiff_loc,dt_ekman_loc)
+  
+! "Get some variables from module ocean_slab_mod"
+! This subroutine prints variables T_h2O_ice_liq a external routine
+
+    INTEGER, INTENT(IN)                     :: ngrid
+    REAL, DIMENSION(ngrid,noceanmx), INTENT(OUT) :: tslab_loc
+    REAL, DIMENSION(ngrid), INTENT(OUT) :: seaice_loc
+    REAL, DIMENSION(ngrid), INTENT(OUT) :: flux_o_loc
+    REAL, DIMENSION(ngrid), INTENT(OUT) :: flux_g_loc
+    REAL, DIMENSION(ngrid,noceanmx), INTENT(OUT) :: dt_hdiff_loc
+    REAL, DIMENSION(ngrid,noceanmx), INTENT(OUT) :: dt_ekman_loc
+    INTEGER :: i
+
+
+! Set the output variables
+    tslab_loc=0.
+    dt_hdiff_loc=0.
+    dt_ekman_loc=0.
+    tslab_loc  = tmp_tslab
+    seaice_loc(:) = tmp_seaice(:)
+    flux_o_loc(:) = tmp_flux_o(:)
+    flux_g_loc(:) = tmp_flux_g(:)
+    DO i=1,noceanmx
+      dt_hdiff_loc(:,i) = dt_hdiff(:,i)*slabh(i)*1000.*4228. !Convert en W/m2
+      dt_ekman_loc(:,i) = dt_ekman(:,i)*slabh(i)*1000.*4228. 
+    ENDDO
+  
+  
+
+  END SUBROUTINE ocean_slab_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_slab_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/optci.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/optci.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/optci.F90	(revision 222)
@@ -0,0 +1,399 @@
+subroutine optci(PLEV,TLEV,DTAUI,TAUCUMI,      &
+     QXIAER,QSIAER,GIAER,COSBI,WBARI,TAUAERO,  &
+     TMID,PMID,TAUGSURF,QVAR,MUVAR)
+
+  use radinc_h
+  use radcommon_h, only: gasi,tlimit,wrefVAR,Cmk,tgasref,pfgasref,wnoi,scalep,indi,glat_ig
+  use gases_h
+  implicit none
+
+  !==================================================================
+  !     
+  !     Purpose
+  !     -------
+  !     Calculates longwave optical constants at each level. For each
+  !     layer and spectral interval in the IR it calculates WBAR, DTAU
+  !     and COSBAR. For each level it calculates TAU.
+  !     
+  !     TAUI(L,LW) is the cumulative optical depth at level L (or alternatively
+  !     at the *bottom* of layer L), LW is the spectral wavelength interval.
+  !     
+  !     TLEV(L) - Temperature at the layer boundary (i.e., level)
+  !     PLEV(L) - Pressure at the layer boundary (i.e., level)
+  !
+  !     Authors
+  !     -------
+  !     Adapted from the NASA Ames code by R. Wordsworth (2009)
+  !     
+  !==================================================================
+
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+  real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+  real*8 DTAUKI(L_LEVELS+1,L_NSPECTI,L_NGAUSS)
+  real*8 TAUI(L_NLEVRAD,L_NSPECTI,L_NGAUSS)
+  real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS)
+  real*8 PLEV(L_LEVELS)
+  real*8 TLEV(L_LEVELS)
+  real*8 TMID(L_LEVELS), PMID(L_LEVELS)
+  real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+  real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+
+  ! for aerosols
+  real*8  QXIAER(L_LEVELS+1,L_NSPECTI,NAERKIND)
+  real*8  QSIAER(L_LEVELS+1,L_NSPECTI,NAERKIND)
+  real*8  GIAER(L_LEVELS+1,L_NSPECTI,NAERKIND)
+  real*8  TAUAERO(L_LEVELS+1,NAERKIND)
+  real*8  TAUAEROLK(L_LEVELS+1,L_NSPECTI,NAERKIND)
+  real*8  TAEROS(L_LEVELS,L_NSPECTI,NAERKIND)
+
+  integer L, NW, NG, K, LK, IAER
+  integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS)
+  real*8  ANS, TAUGAS
+  real*8  DPR(L_LEVELS), U(L_LEVELS)
+  real*8  LCOEF(4), LKCOEF(L_LEVELS,4)
+
+  real*8 taugsurf(L_NSPECTI,L_NGAUSS-1)
+  real*8 DCONT,DAERO
+  double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc
+  double precision p_cross
+
+  ! variable species mixing ratio variables
+  real*8  QVAR(L_LEVELS), WRATIO(L_LEVELS), MUVAR(L_LEVELS)
+  real*8  KCOEF(4)
+  integer NVAR(L_LEVELS)
+
+  ! temporary variables for multiple aerosol calculation
+  real*8 atemp
+  real*8 btemp(L_NLAYRAD,L_NSPECTI)
+
+  ! variables for k in units m^-1
+  real*8 dz(L_LEVELS)
+  !real*8 rho !! see test below
+
+  integer igas, jgas
+
+  integer interm
+
+  !--- Kasting's CIA ----------------------------------------
+  !real*8, parameter :: Ci(L_NSPECTI)=[                         &
+  !     3.8E-5, 1.2E-5, 2.8E-6, 7.6E-7, 4.5E-7, 2.3E-7,    &
+  !     5.4E-7, 1.6E-6, 0.0,                               &
+  !     0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,            & 
+  !     0.0, 4.0E-7, 4.0E-6, 1.4E-5,    &
+  !     1.0E-5, 1.2E-6, 2.0E-7, 5.0E-8, 3.0E-8, 0.0 ] 
+  !real*8, parameter :: Ti(L_NSPECTI)=[ -2.2, -1.9,             &
+  !     -1.7, -1.7, -1.7, -1.7, -1.7, -1.7,                &
+  !     0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
+  !     -1.7,-1.7,-1.7,-1.7,-1.7,-1.7,-1.7, -1.7,0.0 ]
+  !----------------------------------------------------------
+
+  !! AS: to save time in computing continuum (see bilinearbig)
+  IF (.not.ALLOCATED(indi)) THEN
+      ALLOCATE(indi(L_NSPECTI,ngasmx,ngasmx))
+      indi = -9999  ! this initial value means "to be calculated"
+  ENDIF
+
+  !=======================================================================
+  !     Determine the total gas opacity throughout the column, for each
+  !     spectral interval, NW, and each Gauss point, NG.
+
+  taugsurf(:,:) = 0.0
+  dpr(:)        = 0.0
+  lkcoef(:,:)   = 0.0
+
+  do K=2,L_LEVELS
+     DPR(k) = PLEV(K)-PLEV(K-1)
+
+     !--- Kasting's CIA ----------------------------------------
+     !dz(k)=dpr(k)*189.02*TMID(K)/(0.03720*PMID(K))
+     ! this is CO2 path length (in cm) as written by Francois
+     ! delta_z = delta_p * R_specific * T / (g * P)
+     ! But Kasting states that W is in units of _atmosphere_ cm
+     ! So we do
+     !dz(k)=dz(k)*(PMID(K)/1013.25)
+     !dz(k)=dz(k)/100.0 ! in m for SI calc
+     !----------------------------------------------------------
+
+     ! if we have continuum opacities, we need dz
+     if(kastprof)then
+        dz(k) = dpr(k)*(1000.0d0*8.3145d0/muvar(k))*TMID(K)/(g*PMID(K))
+        U(k)  = Cmk*DPR(k)*mugaz/muvar(k) 
+     else
+        dz(k) = dpr(k)*R*TMID(K)/(glat_ig*PMID(K))*mugaz/muvar(k)
+        U(k)  = Cmk*DPR(k)*mugaz/muvar(k)     ! only Cmk line in optci.F  
+	    !JL13 the mugaz/muvar factor takes into account water meanmolecular weight if water is present
+     endif
+
+     call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, &
+          LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K))
+
+     do LK=1,4
+        LKCOEF(K,LK) = LCOEF(LK)
+     end do
+  end do                    ! levels
+
+
+  do iaer=1,naerkind
+     DO NW=1,L_NSPECTI
+        do K=2,L_LEVELS
+           TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXIAER(K,NW,IAER)
+        end do                    ! levels
+     END DO
+  end do
+
+  do NW=1,L_NSPECTI
+
+     do K=2,L_LEVELS
+
+! continuum absorption
+        DCONT = 0.0d0 
+
+        if(continuum.and.(.not.graybody))then
+           ! include continua if necessary
+           wn_cont = dble(wnoi(nw))
+           T_cont  = dble(TMID(k))
+           do igas=1,ngasmx
+
+              if(gfrac(igas).eq.-1)then ! variable
+                 p_cont  = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol
+              else
+                 p_cont  = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k)))
+              endif
+
+              dtemp=0.0d0
+              if(igas.eq.igas_N2)then
+
+                 interm = indi(nw,igas,igas)
+                 call interpolateN2N2(wn_cont,T_cont,p_cont,dtemp,.false.,interm)
+                 indi(nw,igas,igas) = interm
+
+              elseif(igas.eq.igas_H2)then
+
+                 ! first do self-induced absorption
+                 interm = indi(nw,igas,igas)
+                 call interpolateH2H2(wn_cont,T_cont,p_cont,dtemp,.false.,interm)
+                 indi(nw,igas,igas) = interm
+
+                 ! then cross-interactions with other gases
+                 do jgas=1,ngasmx
+                    p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k)))
+                    dtempc  = 0.0d0
+                    if(jgas.eq.igas_N2)then 
+                       interm = indi(nw,igas,jgas)
+                       call interpolateN2H2(wn_cont,T_cont,p_cross,p_cont,dtempc,.false.,interm)
+                       indi(nw,igas,jgas) = interm
+                    elseif(jgas.eq.igas_He)then 
+                       interm = indi(nw,igas,jgas)
+                       call interpolateH2He(wn_cont,T_cont,p_cross,p_cont,dtempc,.false.,interm)
+                       indi(nw,igas,jgas) = interm
+                    endif
+                    dtemp = dtemp + dtempc
+                 enddo
+
+              elseif(igas.eq.igas_H2O.and.T_cont.gt.200.0)then
+
+                 p_air = dble(PMID(k)*scalep) - p_cont ! note assumes background is air!
+                 if(H2Ocont_simple)then
+                    call interpolateH2Ocont_PPC(wn_cont,T_cont,p_cont,p_air,dtemp,.false.)
+                 else
+                    interm = indi(nw,igas,igas)
+                    call interpolateH2Ocont_CKD(wn_cont,T_cont,p_cont,p_air,dtemp,.false.,interm)
+                    indi(nw,igas,igas) = interm
+                 endif
+
+              endif
+
+              DCONT = DCONT + dtemp
+
+           enddo
+
+           ! Oobleck test
+           !rho = PMID(k)*scalep / (TMID(k)*286.99)
+           !if(WNOI(nw).gt.300.0 .and. WNOI(nw).lt.500.0)then
+           !   DCONT = rho * 0.125 * 4.6e-4
+           !elseif(WNOI(nw).gt.500.0 .and. WNOI(nw).lt.700.0)then
+           !   DCONT = 1000*dpr(k) * 1.0 * 4.6e-4 / g
+           !   DCONT = rho * 1.0 * 4.6e-4
+           !elseif(WNOI(nw).gt.700.0 .and. WNOI(nw).lt.900.0)then
+           !   DCONT = rho * 0.125 * 4.6e-4
+           !endif
+
+           DCONT = DCONT*dz(k)
+
+        endif
+
+! aerosol absorption
+	DAERO=SUM(TAEROS(K,NW,1:naerkind))
+
+        do ng=1,L_NGAUSS-1
+
+           ! Now compute TAUGAS
+
+           ! Interpolate between water mixing ratios
+           ! WRATIO = 0.0 if the requested water amount is equal to, or outside the
+           ! the water data range
+
+           if(L_REFVAR.eq.1)then ! added by RW for special no variable case
+              KCOEF(1) = GASI(MT(K),MP(K),1,NW,NG)
+              KCOEF(2) = GASI(MT(K),MP(K)+1,1,NW,NG)
+              KCOEF(3) = GASI(MT(K)+1,MP(K)+1,1,NW,NG)
+              KCOEF(4) = GASI(MT(K)+1,MP(K),1,NW,NG)
+           else
+
+              KCOEF(1) = GASI(MT(K),MP(K),NVAR(K),NW,NG) + WRATIO(K)*     &
+                   (GASI(MT(K),MP(K),NVAR(K)+1,NW,NG) -                   &
+                   GASI(MT(K),MP(K),NVAR(K),NW,NG))
+
+              KCOEF(2) = GASI(MT(K),MP(K)+1,NVAR(K),NW,NG) + WRATIO(K)*   &
+                   (GASI(MT(K),MP(K)+1,NVAR(K)+1,NW,NG) -                 &
+                   GASI(MT(K),MP(K)+1,NVAR(K),NW,NG))
+
+              KCOEF(3) = GASI(MT(K)+1,MP(K)+1,NVAR(K),NW,NG) + WRATIO(K)* &
+                   (GASI(MT(K)+1,MP(K)+1,NVAR(K)+1,NW,NG) -               &
+                   GASI(MT(K)+1,MP(K)+1,NVAR(K),NW,NG))
+
+              KCOEF(4) = GASI(MT(K)+1,MP(K),NVAR(K),NW,NG) + WRATIO(K)*   &
+                   (GASI(MT(K)+1,MP(K),NVAR(K)+1,NW,NG) -                 &
+                   GASI(MT(K)+1,MP(K),NVAR(K),NW,NG))
+
+           endif
+
+           ! Interpolate the gaseous k-coefficients to the requested T,P values
+
+           ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) +            &
+                LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4)
+
+           TAUGAS  = U(k)*ANS
+
+           TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT
+           DTAUKI(K,nw,ng) = TAUGAS    & 
+                             + DCONT   & ! For parameterized continuum absorption
+			     + DAERO     ! For aerosol absorption
+
+        end do
+
+        ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS),
+        ! which holds continuum opacity only
+
+        NG              = L_NGAUSS
+        DTAUKI(K,nw,ng) = 0.d0      & 
+                          + DCONT   & ! For parameterized continuum absorption
+	                  + DAERO     ! For aerosol absorption
+
+     end do
+  end do
+
+  DTAUKI(L_LEVELS+1,1:L_NSPECTI,1:L_NGAUSS)=0.d0
+  !=======================================================================
+  !     Now the full treatment for the layers, where besides the opacity
+  !     we need to calculate the scattering albedo and asymmetry factors
+
+  do iaer=1,naerkind
+    DO NW=1,L_NSPECTI
+     DO K=2,L_LEVELS+1
+           TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER)*QSIAER(K,NW,IAER)
+     ENDDO
+    ENDDO
+  end do
+  
+  DO NW=1,L_NSPECTI
+     DO L=1,L_NLAYRAD
+        K              = 2*L+1
+        btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + SUM(TAUAEROLK(K+1,NW,1:naerkind))
+     END DO ! L vertical loop
+  END DO                    ! NW spectral loop
+  
+
+  DO NW=1,L_NSPECTI
+     NG = L_NGAUSS
+     DO L=1,L_NLAYRAD
+
+        K              = 2*L+1
+        DTAUI(L,nw,ng) = DTAUKI(K,NW,NG) + DTAUKI(K+1,NW,NG)! + 1.e-50
+
+        atemp = 0.
+        if(DTAUI(L,NW,NG) .GT. 1.0D-9) then
+           do iaer=1,naerkind
+              atemp = atemp +                                     &
+                   GIAER(K,NW,IAER)   * TAUAEROLK(K,NW,IAER) +    &
+                   GIAER(K+1,NW,IAER) * TAUAEROLK(K+1,NW,IAER)
+           end do
+           WBARI(L,nw,ng) = btemp(L,nw)  / DTAUI(L,NW,NG)
+        else
+           WBARI(L,nw,ng) = 0.0D0
+           DTAUI(L,NW,NG) = 1.0D-9
+        endif
+
+        if(btemp(L,nw) .GT. 0.0d0) then
+           cosbi(L,NW,NG) = atemp/btemp(L,nw)
+        else
+           cosbi(L,NW,NG) = 0.0D0
+        end if
+
+     END DO ! L vertical loop
+
+     ! Now the other Gauss points, if needed.
+
+     DO NG=1,L_NGAUSS-1
+        IF(TAUGSURF(NW,NG) .gt. TLIMIT) THEN
+
+           DO L=1,L_NLAYRAD
+              K              = 2*L+1
+              DTAUI(L,nw,ng) = DTAUKI(K,NW,NG)+DTAUKI(K+1,NW,NG)! + 1.e-50
+
+              if(DTAUI(L,NW,NG) .GT. 1.0D-9) then
+
+                 WBARI(L,nw,ng) = btemp(L,nw)  / DTAUI(L,NW,NG)
+
+              else
+                 WBARI(L,nw,ng) = 0.0D0
+                 DTAUI(L,NW,NG) = 1.0D-9
+              endif
+
+              cosbi(L,NW,NG) = cosbi(L,NW,L_NGAUSS)
+           END DO ! L vertical loop
+        END IF
+
+     END DO                 ! NG Gauss loop
+  END DO                    ! NW spectral loop
+
+  ! Total extinction optical depths
+
+  DO NG=1,L_NGAUSS       ! full gauss loop
+     DO NW=1,L_NSPECTI       
+        TAUCUMI(1,NW,NG)=0.0D0
+        DO K=2,L_LEVELS
+           TAUCUMI(K,NW,NG)=TAUCUMI(K-1,NW,NG)+DTAUKI(K,NW,NG)
+        END DO
+     END DO                 ! end full gauss loop
+  END DO
+
+  ! be aware when comparing with textbook results 
+  ! (e.g. Pierrehumbert p. 218) that 
+  ! taucumi does not take the <cos theta>=0.5 factor into
+  ! account. It is the optical depth for a vertically 
+  ! ascending ray with angle theta = 0.
+
+  !open(127,file='taucum.out')
+  !do nw=1,L_NSPECTI
+  !   write(127,*) taucumi(L_LEVELS,nw,L_NGAUSS)
+  !enddo
+  !close(127)
+  
+!  print*,'WBARI'
+!  print*,WBARI
+!  print*,'DTAUI'
+!  print*,DTAUI
+!  call abort
+  
+
+  return
+
+
+end subroutine optci
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/optcv.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/optcv.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/optcv.F90	(revision 222)
@@ -0,0 +1,353 @@
+SUBROUTINE OPTCV(DTAUV,TAUV,TAUCUMV,PLEV,  &
+     QXVAER,QSVAER,GVAER,WBARV,COSBV,       &
+     TAURAY,TAUAERO,TMID,PMID,TAUGSURF,QVAR,MUVAR)
+
+  use radinc_h
+  use radcommon_h, only: gasv, tlimit, wrefVAR, Cmk, tgasref, pfgasref,wnov,scalep,indv,glat_ig
+  use gases_h
+
+  implicit none
+
+  !==================================================================
+  !     
+  !     Purpose
+  !     -------
+  !     Calculates shortwave optical constants at each level.
+  !     
+  !     Authors
+  !     -------
+  !     Adapted from the NASA Ames code by R. Wordsworth (2009)
+  !     
+  !==================================================================
+  !     
+  !     THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISUAL  
+  !     IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VISUAL
+  !     LAYER: WBAR, DTAU, COSBAR
+  !     LEVEL: TAU
+  !     
+  !     TAUV(L,NW,NG) is the cumulative optical depth at the top of radiation code
+  !     layer L. NW is spectral wavelength interval, ng the Gauss point index.
+  !     
+  !     TLEV(L) - Temperature at the layer boundary
+  !     PLEV(L) - Pressure at the layer boundary (i.e. level)
+  !     GASV(NT,NPS,NW,NG) - Visible k-coefficients 
+  !     
+  !-------------------------------------------------------------------
+
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+  real*8 DTAUV(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+  real*8 DTAUKV(L_LEVELS+1,L_NSPECTV,L_NGAUSS)
+  real*8 TAUV(L_NLEVRAD,L_NSPECTV,L_NGAUSS)
+  real*8 TAUCUMV(L_LEVELS,L_NSPECTV,L_NGAUSS)
+  real*8 PLEV(L_LEVELS)
+  real*8 TMID(L_LEVELS), PMID(L_LEVELS)
+  real*8 COSBV(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+  real*8 WBARV(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+
+  ! for aerosols
+  real*8  QXVAER(L_LEVELS+1,L_NSPECTV,NAERKIND)
+  real*8  QSVAER(L_LEVELS+1,L_NSPECTV,NAERKIND)
+  real*8  GVAER(L_LEVELS+1,L_NSPECTV,NAERKIND)
+  real*8  TAUAERO(L_LEVELS+1,NAERKIND)
+  real*8  TAUAEROLK(L_LEVELS+1,L_NSPECTV,NAERKIND)
+  real*8  TAEROS(L_LEVELS,L_NSPECTV,NAERKIND)
+
+  integer L, NW, NG, K, LK, IAER
+  integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS)
+  real*8  ANS, TAUGAS
+  real*8  TAURAY(L_NSPECTV)
+  real*8  TRAY(L_LEVELS,L_NSPECTV)
+  real*8  TRAYAER
+  real*8  DPR(L_LEVELS), U(L_LEVELS)
+  real*8  LCOEF(4), LKCOEF(L_LEVELS,4)
+
+  real*8 taugsurf(L_NSPECTV,L_NGAUSS-1)
+  real*8 DCONT,DAERO
+  double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc
+  double precision p_cross
+
+  ! variable species mixing ratio variables
+  real*8  QVAR(L_LEVELS), WRATIO(L_LEVELS), MUVAR(L_LEVELS)
+  real*8  KCOEF(4)
+  integer NVAR(L_LEVELS)
+
+  ! temporary variables for multiple aerosol calculation
+  real*8 atemp(L_NLAYRAD,L_NSPECTV)
+  real*8 btemp(L_NLAYRAD,L_NSPECTV)
+  real*8 ctemp(L_NLAYRAD,L_NSPECTV)
+
+  ! variables for k in units m^-1
+  real*8 dz(L_LEVELS)
+
+  integer igas, jgas
+
+  integer interm
+
+  !! AS: to save time in computing continuum (see bilinearbig)
+  IF (.not.ALLOCATED(indv)) THEN
+      ALLOCATE(indv(L_NSPECTV,ngasmx,ngasmx))
+      indv = -9999 ! this initial value means "to be calculated"
+  ENDIF
+
+  !=======================================================================
+  !     Determine the total gas opacity throughout the column, for each
+  !     spectral interval, NW, and each Gauss point, NG.
+  !     Calculate the continuum opacities, i.e., those that do not depend on
+  !     NG, the Gauss index.
+
+  taugsurf(:,:) = 0.0
+  dpr(:)        = 0.0
+  lkcoef(:,:)   = 0.0
+
+  do K=2,L_LEVELS
+     DPR(k) = PLEV(K)-PLEV(K-1)
+
+     ! if we have continuum opacities, we need dz
+     if(kastprof)then
+        dz(k) = dpr(k)*(1000.0d0*8.3145d0/muvar(k))*TMID(K)/(g*PMID(K))
+        U(k)  = Cmk*DPR(k)*mugaz/muvar(k) 
+     else
+        dz(k) = dpr(k)*R*TMID(K)/(glat_ig*PMID(K))*mugaz/muvar(k)
+        U(k)  = Cmk*DPR(k)*mugaz/muvar(k)     ! only Cmk line in optci.F  
+	    !JL13 the mugaz/muvar factor takes into account water meanmolecular weight if water is present
+     endif
+
+     call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, &
+          LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K))
+
+     do LK=1,4
+        LKCOEF(K,LK) = LCOEF(LK)
+     end do
+  end do                    ! levels
+
+
+  do iaer=1,naerkind
+     do NW=1,L_NSPECTV
+        do K=2,L_LEVELS
+           TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXVAER(K,NW,IAER)
+        end do                    ! levels
+     end do
+  end do
+  do NW=1,L_NSPECTV
+     do K=2,L_LEVELS
+        TRAY(K,NW)   = TAURAY(NW) * DPR(K)
+     end do                    ! levels
+  end do
+  
+  !     we ignore K=1...
+  do K=2,L_LEVELS
+
+     do NW=1,L_NSPECTV
+
+        TRAYAER = TRAY(K,NW)
+        !     TRAYAER is Tau RAYleigh scattering, plus AERosol opacity
+        do iaer=1,naerkind
+           TRAYAER = TRAYAER + TAEROS(K,NW,IAER)
+        end do
+
+        DCONT = 0.0 ! continuum absorption
+
+        if(continuum.and.(.not.graybody).and.callgasvis)then
+           ! include continua if necessary
+           wn_cont = dble(wnov(nw))
+           T_cont  = dble(TMID(k))
+           do igas=1,ngasmx
+
+              if(gfrac(igas).eq.-1)then ! variable
+                 p_cont  = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol
+              else
+                 p_cont  = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k)))
+              endif
+
+              dtemp=0.0
+              if(igas.eq.igas_N2)then
+
+                 interm = indv(nw,igas,igas)
+!                 call interpolateN2N2(wn_cont,T_cont,p_cont,dtemp,.false.,interm)
+                 indv(nw,igas,igas) = interm
+                 ! only goes to 500 cm^-1, so unless we're around a cold brown dwarf, this is irrelevant in the visible
+
+              elseif(igas.eq.igas_H2)then
+
+                 ! first do self-induced absorption
+                 interm = indv(nw,igas,igas)
+                 call interpolateH2H2(wn_cont,T_cont,p_cont,dtemp,.false.,interm)
+                 indv(nw,igas,igas) = interm
+
+                 ! then cross-interactions with other gases
+                 do jgas=1,ngasmx
+                    p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k)))
+                    dtempc  = 0.0
+                    if(jgas.eq.igas_N2)then 
+                       interm = indv(nw,igas,jgas)
+                       call interpolateN2H2(wn_cont,T_cont,p_cross,p_cont,dtempc,.false.,interm)
+                       indv(nw,igas,jgas) = interm
+                       ! should be irrelevant in the visible
+                    elseif(jgas.eq.igas_He)then 
+                       interm = indv(nw,igas,jgas)
+                       call interpolateH2He(wn_cont,T_cont,p_cross,p_cont,dtempc,.false.,interm)
+                       indv(nw,igas,jgas) = interm
+                    endif
+                    dtemp = dtemp + dtempc
+                 enddo
+
+              elseif(igas.eq.igas_H2O.and.T_cont.gt.200.0)then
+
+                 p_air = dble(PMID(k)*scalep) - p_cont ! note assumes background is air!
+                 if(H2Ocont_simple)then
+                    call interpolateH2Ocont_PPC(wn_cont,T_cont,p_cont,p_air,dtemp,.false.)
+                 else
+                    interm = indv(nw,igas,igas)
+                    call interpolateH2Ocont_CKD(wn_cont,T_cont,p_cont,p_air,dtemp,.false.,interm)
+                    indv(nw,igas,igas) = interm
+                 endif
+
+              endif
+
+              DCONT = DCONT + dtemp
+
+           enddo
+
+           DCONT = DCONT*dz(k)
+
+        endif
+
+        do ng=1,L_NGAUSS-1
+
+           ! Now compute TAUGAS
+
+           ! Interpolate between water mixing ratios
+           ! WRATIO = 0.0 if the requested water amount is equal to, or outside the
+           ! the water data range
+
+           if(L_REFVAR.eq.1)then ! added by RW for special no variable case
+              KCOEF(1) = GASV(MT(K),MP(K),1,NW,NG)
+              KCOEF(2) = GASV(MT(K),MP(K)+1,1,NW,NG)
+              KCOEF(3) = GASV(MT(K)+1,MP(K)+1,1,NW,NG)
+              KCOEF(4) = GASV(MT(K)+1,MP(K),1,NW,NG)
+           else
+
+              KCOEF(1) = GASV(MT(K),MP(K),NVAR(K),NW,NG) + WRATIO(K)*    &
+                   (GASV(MT(K),MP(K),NVAR(K)+1,NW,NG) -                  &
+                   GASV(MT(K),MP(K),NVAR(K),NW,NG))
+
+              KCOEF(2) = GASV(MT(K),MP(K)+1,NVAR(K),NW,NG) + WRATIO(K)*  &
+                   (GASV(MT(K),MP(K)+1,NVAR(K)+1,NW,NG) -                &
+                   GASV(MT(K),MP(K)+1,NVAR(K),NW,NG))
+
+              KCOEF(3) = GASV(MT(K)+1,MP(K)+1,NVAR(K),NW,NG) + WRATIO(K)*&
+                   (GASV(MT(K)+1,MP(K)+1,NVAR(K)+1,NW,NG) -              &
+                   GASV(MT(K)+1,MP(K)+1,NVAR(K),NW,NG))
+
+              KCOEF(4) = GASV(MT(K)+1,MP(K),NVAR(K),NW,NG) + WRATIO(K)*  &
+                   (GASV(MT(K)+1,MP(K),NVAR(K)+1,NW,NG) -                &
+                   GASV(MT(K)+1,MP(K),NVAR(K),NW,NG))
+
+           endif
+
+           ! Interpolate the gaseous k-coefficients to the requested T,P values
+
+           ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) +            &
+                LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4)
+
+           TAUGAS  = U(k)*ANS
+
+           TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT
+           DTAUKV(K,nw,ng) = TAUGAS & 
+                             + TRAYAER & ! TRAYAER includes all scattering contributions
+                             + DCONT ! For parameterized continuum aborption
+
+        end do
+
+        ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS),
+        ! which holds continuum opacity only
+
+        NG              = L_NGAUSS
+        DTAUKV(K,nw,ng) = TRAY(K,NW) + DCONT ! For parameterized continuum absorption
+
+        do iaer=1,naerkind
+           DTAUKV(K,nw,ng) = DTAUKV(K,nw,ng) +  TAEROS(K,NW,IAER)
+        end do ! a bug was here!
+
+     end do
+  end do
+
+
+  !=======================================================================
+  !     Now the full treatment for the layers, where besides the opacity
+  !     we need to calculate the scattering albedo and asymmetry factors
+
+  do iaer=1,naerkind
+    DO NW=1,L_NSPECTV
+      DO K=2,L_LEVELS   ! AS: shouldn't this be L_LEVELS+1 ? (see optci)
+           TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER) * QSVAER(K,NW,IAER)
+      ENDDO
+    ENDDO
+  end do
+
+  DO NW=1,L_NSPECTV
+     DO L=1,L_NLAYRAD-1
+        K              = 2*L+1
+	atemp(L,NW) = SUM(GVAER(K,NW,1:naerkind) * TAUAEROLK(K,NW,1:naerkind))+SUM(GVAER(K+1,NW,1:naerkind) * TAUAEROLK(K+1,NW,1:naerkind))
+        btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + SUM(TAUAEROLK(K+1,NW,1:naerkind))
+	ctemp(L,NW) = btemp(L,NW) + 0.9999*(TRAY(K,NW) + TRAY(K+1,NW))
+	btemp(L,NW) = btemp(L,NW) + TRAY(K,NW) + TRAY(K+1,NW)
+	COSBV(L,NW,1:L_NGAUSS) = atemp(L,NW)/btemp(L,NW)
+     END DO ! L vertical loop
+     
+     !last level
+     L              = L_NLAYRAD
+     K              = 2*L+1
+     atemp(L,NW)    = SUM(GVAER(K,NW,1:naerkind) * TAUAEROLK(K,NW,1:naerkind))
+     btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind))
+     ctemp(L,NW) = btemp(L,NW) + 0.9999*TRAY(K,NW)
+     btemp(L,NW) = btemp(L,NW) + TRAY(K,NW)
+     COSBV(L,NW,1:L_NGAUSS) = atemp(L,NW)/btemp(L,NW)
+     
+     
+  END DO                    ! NW spectral loop
+
+  DO NG=1,L_NGAUSS
+    DO NW=1,L_NSPECTV
+     DO L=1,L_NLAYRAD-1
+
+        K              = 2*L+1
+        DTAUV(L,nw,ng) = DTAUKV(K,NW,NG) + DTAUKV(K+1,NW,NG)
+        WBARV(L,nw,ng) = ctemp(L,NW) / DTAUV(L,nw,ng)
+
+      END DO ! L vertical loop
+
+        !     No vertical averaging on bottom layer
+
+        L              = L_NLAYRAD
+        K              = 2*L+1
+	DTAUV(L,nw,ng) = DTAUKV(K,NW,NG)
+
+        WBARV(L,NW,NG) = ctemp(L,NW) / DTAUV(L,NW,NG)
+     END DO                 ! NW spectral loop
+  END DO                    ! NG Gauss loop
+
+  ! Total extinction optical depths
+
+  DO NG=1,L_NGAUSS       ! full gauss loop
+     DO NW=1,L_NSPECTV       
+        TAUV(1,NW,NG)=0.0D0
+        DO L=1,L_NLAYRAD
+           TAUV(L+1,NW,NG)=TAUV(L,NW,NG)+DTAUV(L,NW,NG)
+        END DO
+
+        TAUCUMV(1,NW,NG)=0.0D0
+        DO K=2,L_LEVELS
+           TAUCUMV(K,NW,NG)=TAUCUMV(K-1,NW,NG)+DTAUKV(K,NW,NG)
+        END DO
+     END DO            
+  END DO                 ! end full gauss loop
+
+
+  return
+
+
+end subroutine optcv
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/orbite.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/orbite.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/orbite.F	(revision 222)
@@ -0,0 +1,52 @@
+      subroutine orbite(pls,pdist_star,pdecli)
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Distance from star and declination as a function of the stellar
+!     longitude Ls
+!     
+!     Inputs
+!     ------
+!     pls          Ls
+!
+!     Outputs
+!     -------
+!     pdist_star    Distance Star-Planet in UA
+!     pdecli        declinaison ( in radians )
+!
+!=======================================================================
+
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "comcstfi.h"
+
+c arguments:
+c ----------
+
+      REAL pday,pdist_star,pdecli,pls,i
+
+c-----------------------------------------------------------------------
+
+c Star-Planet Distance
+
+      pdist_star = p_elips/(1.+e_elips*cos(pls+timeperi))
+
+c Stellar declination
+
+c ********************* version before 01/01/2000 *******
+
+      pdecli = asin (sin(pls)*sin(obliquit*pi/180.))
+
+c ********************* version after 01/01/2000 *******
+c     i=obliquit*pi/180.
+c     pdecli=asin(sin(pls)*sin(i)/sqrt(sin(pls)**2+
+c    & cos(pls)**2*cos(i)**2))
+c ******************************************************
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/params_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/params_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/params_h.F90	(revision 222)
@@ -0,0 +1,16 @@
+      module params_h
+
+!  for use with kcm subroutines
+!  RDW 22/09/11
+
+      implicit none
+
+      double precision rc,cp_n,m_n,m_v,rmn
+      save cp_n,m_n,m_v,rmn
+
+      logical ideal_v
+      save ideal_v
+
+      parameter (rc  = 8.314462d0) ! ideal gas constant [J mol^-1 K^-1]
+
+      end module params_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phasechange_kcm.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phasechange_kcm.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phasechange_kcm.F90	(revision 222)
@@ -0,0 +1,1286 @@
+!  ----------------------------------------------------------------
+!  Purpose: Thermodynamic data on H2O, NH3
+!  Authour: Adapted from various sources by R. Wordsworth (2011)
+
+
+! ---------------------
+! NH3
+! ---------------------
+subroutine psat_NH3 ( T, p )
+!
+!  PSAT_NH3 makes a rough estimate of the vapor pressure.
+!
+!  Interpolated from www.engineeringtoolbox.com data by RDW 21/09/11 for
+!  temperatures between 223 and 323 K.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Output, double precision P, the vapor pressure, in MegaPascals.
+!
+
+  implicit none
+
+  double precision p,T
+
+  p=exp(-1.5609d-004*T**2 + 0.1236*T - 9.1530)/1d6
+
+end subroutine psat_NH3
+
+subroutine latheat_NH3 ( T, sc, sv )
+!
+!  PSAT_NH3 makes a rough estimate of the entropies of condensation /
+!  vapourisation.
+! 
+!  Interpolated from www.engineeringtoolbox.com data by RDW 21/09/11 for
+!  temperatures between 223 and 323 K.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Output, double precision sc, the entropy of condensate, in J kg^-1 K^-1.
+!            double precision sv, the entropy of gas, in J kg^-1 K^-1.
+!
+
+  implicit none
+
+  double precision T,sc,sv
+
+  sv = 0.0492*T**2 - 40.4199*T + 1.2708e+004
+  sc = -0.0215*T**2 + 28.7138*T - 5.5267e+003
+
+  !L = -11.2373*T**2 + 2.5326d+03*T + 1.4099d+06
+
+end subroutine latheat_NH3
+
+
+! ---------------------
+! H2O
+! ---------------------
+
+subroutine base ( t, rho, ab, cvb, dpdrb, dpdtb, gb, hb, pb, sb, ub )
+!
+!*******************************************************************************
+!
+!! BASE calculates quantities associated with the base Helmholtz function.
+!
+!
+!  Discussion:
+!
+!    The equation for the base Helmholtz function AB(T,RHO) is:
+!
+!      AB(T,RHO) = R * T * (
+!        - ln ( 1 - y ) 
+!        - ( beta - 1 ) / ( 1 - y ) 
+!        + ( alpha + beta + 1 ) / ( 2 * ( 1 - y )**2 )
+!        + 4 * y * ( ( Bbar / b ) - gamma ) 
+!        - 0.5 * ( alpha - beta + 3 ) 
+!        + ln ( RHO * R * T / P0 ) )
+!                                                      (Equation 2)
+!   where 
+!
+!     y = b * rho / 4, 
+!     alpha = 11,
+!     beta = 133/3, 
+!     gamma = 7/2, 
+!     P0 = 0.101325 MegaPascals = 1 atm
+!
+!   and
+!
+!     b(T) = b1 * ln(T/T0) + sum(j=0,1,3,5) b(j)*(T0/T)**j  (Equation 3)
+!
+!     Bbar(T) = sum(j=0,1,2,4) B(j)*(T0/T)**j               (Equation 4).
+!
+!   where 
+!
+!     T0=647.073 K and the coefficients b(j) and B(j) are
+!    
+!     j    b(j)                         B(j)
+!    --    -----------                  ----------
+!     0    0.7478629                    1.1278334
+!     1   -0.3540782                   -0.5944001
+!     2    0                           -5.010996
+!     3    0.007159876                  0
+!     4    0                            0.63684256
+!     5   -0.003528426                  0
+!
+!  For the derived quantities, the following relations are used:
+!
+!    Pressure:                  PB      = RHO**2 * dAB/dRHO
+!    Density derivative:        DPDRB   = 2*PB/RHO + RHO**2 * d2AB/dRHO2
+!    Temperature derivative:    DPDTB   = RHO**2 * d2AB/(dRHO dT)
+!    Specific entropy:          SB      = ( UB - AB ) / T
+!    Specific internal energy:  UB      = AB + T * SB
+!    Specific enthalpy:         HB      = UB + PB / RHO
+!    Specific heat capacity
+!      at constant volume:      CVB     = - T * d2AB/dT2
+!    Specific Gibbs function:   GB      = AB + PB / RHO
+!
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Modified:
+!
+!    03 February 2002
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Input, double precision RHO, the density, in G/CM3.
+!
+!    Output, double precision AB, the base value of the Helmholtz function,
+!    in KJ/kg.
+!
+!    Output, double precision CVB, the base value of the isochoric (constant 
+!    volume) heat capacity, in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision DPDRB, the base value of the partial
+!    derivative dP(T,RHO)/dRHO, with T held fixed, in (MegaPascals CM3)/G.
+!
+!    Output, double precision DPDTB, the base value of the partial
+!    derivative dP(T,RHO)/dT, with RHO held fixed, in 
+!    MegaPascals/degrees Kelvin.
+!
+!    Output, double precision GB, the base value of the Gibbs free energy,
+!    in KJ/kg.
+!
+!    Output, double precision HB, the base value of enthalpy, in KJ/kg.
+!
+!    Output, double precision PB, the base pressure, in MegaPascals.
+!
+!    Output, double precision SB, the base value of entropy, 
+!    in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision UB, the base value of internal energy, 
+!    in KJ/kg.
+!
+  implicit none
+!
+  double precision ab
+  double precision, parameter :: alpha = 11.0D+00
+  double precision b1
+  double precision b1t
+  double precision b1tt
+  double precision b2
+  double precision b2t
+  double precision b2tt
+  double precision, parameter :: beta = 44.333333333333D+00
+  double precision cvb
+  double precision dpdrb
+  double precision dpdtb
+  double precision dz
+  double precision dz0
+  double precision, parameter :: gamma = 3.5D+00
+  double precision gascon
+  double precision gb
+  double precision hb
+  double precision, parameter :: p_zero = 0.101325D+00
+  double precision pb
+  double precision rho
+  double precision sb
+  double precision t
+  double precision ub
+  double precision x
+  double precision y
+  double precision z
+  double precision z0
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'BASE - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+!
+!  Refuse to handle zero or negative density.
+!
+  if ( rho <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'BASE - Fatal error!'
+    write ( *, '(a)' ) '  The input density RHO must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was RHO = ', rho
+    stop
+  end if
+!
+!  Compute auxilliary quantities for Equation 2.
+!
+  call bb ( t, b1, b2, b1t, b2t, b1tt, b2tt )
+
+  y = 0.25D+00 * b1 * rho
+
+  x = 1.0D+00 - y
+!
+!  Evaluate Equation 2.
+!
+  ab =   - log ( 1.0D+00 - y ) &
+         - ( beta - 1.0D+00 ) / ( 1.0D+00 - y ) &
+         + ( alpha + beta + 1.0D+00 ) / ( 2.0D+00 * ( 1.0D+00 - y )**2 ) &
+         + 4.0D+00 * y * ( ( b2 / b1 ) - gamma ) &
+         - 0.5D+00 * ( alpha - beta + 3.0D+00 ) &
+         + log ( rho * gascon() * t / p_zero )
+!
+!  Determine quantities defined in terms of AB.
+!
+  pb = ( 1.0D+00 + alpha * y + beta * y**2 ) / ( 1.0D+00 - y )**3 &
+    + 4.0D+00 * y * ( b2 / b1 - gamma )
+
+  z0 = ( 1.0D+00 + alpha * y + beta * y**2 ) / ( 1.0D+00 - y )**3
+
+  z = z0 + 4.0D+00 * y * ( b2 / b1 - gamma )
+
+  dz0 = ( alpha + 2.0D+00 * beta * y ) / ( 1.0D+00 - y )**3 &
+    + 3.0D+00 * ( 1.0D+00 + alpha * y + beta * y**2 ) / ( 1.0D+00 - y )**4
+
+  dz = dz0 + 4.0D+00 * ( b2 / b1 - gamma )
+
+  gb = ab + pb
+
+  ub = - t * b1t * ( pb - 1.0D+00 - rho * b2 ) / b1 - rho * t * b2t
+
+  hb = pb + ub
+!
+!  An incorrect version of this equation began:
+!
+!    cvb = 2.0D+00 * ub + ( pb - 1.0D+00 ) &
+!
+!  and caused me no end of trouble.  My fault, JVB, 03 February 2002
+!
+  cvb = 2.0D+00 * ub + ( z0 - 1.0D+00 ) &
+    * ( ( t * b1t / b1 )**2 - t**2 * b1tt / b1 ) &
+    - rho * t**2 * ( b2tt - gamma * b1tt ) - ( t * b1t / b1 )**2 * y * dz0
+
+  dpdtb = pb / t + rho * ( 0.25D+00 * ( dz0 + 4.0D+00 * ( b2 / b1 - gamma ) ) &
+    * b1t + b2t - b2 / b1 * b1t )
+
+  sb = ub - ab
+
+  dpdrb = pb + y * ( dz0 + 4.0D+00 * ( b2 / b1 - gamma ) )
+!
+!  Assign dimensions.
+!
+  ab =    gascon() * t       * ab
+  cvb =   gascon()           * cvb
+  dpdrb = gascon() * t       * dpdrb
+  dpdtb = gascon() * t * rho * dpdtb
+  gb =    gascon() * t       * gb
+  hb =    gascon() * t       * hb
+  pb =    gascon() * t * rho * pb
+  sb =    gascon()           * sb
+  ub =    gascon() * t       * ub
+
+  return
+end subroutine base
+
+subroutine bb ( t, b1, b2, b1t, b2t, b1tt, b2tt )
+!
+!*******************************************************************************
+!
+!! BB calculates the B's of equations 3 and 4.  
+!
+!
+!  Discussion:
+!
+!    Here
+!
+!      b(T) = b1 * ln(T/T0) + sum(j=0,1,3,5) b(j)*(T0/T)**j  (Equation 3)
+!
+!      Bbar(T) = sum(j=0,1,2,4) B(j)*(T0/T)**j               (Equation 4).
+!
+!    where 
+!
+!      T0 = 647.073 K 
+!
+!    and the coefficients b(j) and B(j) are
+!    
+!      j    b(j)                         B(j)
+!     --    -----------                  ----------
+!      0    0.7478629                    1.1278334
+!      1   -0.3540782                   -0.5944001
+!      2    0                           -5.010996
+!      3    0.007159876                  0
+!      4    0                            0.63684256
+!      5   -0.003528426                  0
+!
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Output, double precision B1, the coefficient b from equation 3, 
+!    in CM3/G.
+!
+!    Output, double precision B2, the coefficient Bbar from equation 4, 
+!    in CM3/G.
+!
+!    Output, double precision B1T, the derivative dB1/dT, 
+!    in (CM3)/(G Degrees Kelvin).
+!
+!    Output, double precision B2T, the derivative dB2/dT, 
+!    in (CM3)/(G Degrees Kelvin).
+!
+!    Output, double precision B1TT, the second derivative of B1 with 
+!    respect to T, in (CM3)/(G (Degrees Kelvin)**2 ).
+!
+!    Output, double precision B2TT, the second derivative of B2 with 
+!    respect to T, in (CM3)/(G (Degrees Kelvin)**2 ).
+!
+  implicit none
+!
+  double precision b1
+  double precision b1t
+  double precision b1tt
+  double precision b2
+  double precision b2t
+  double precision b2tt
+  double precision, parameter, dimension ( 10 ) :: bp = (/ &
+    0.7478629D+00,   -0.3540782D+00,    0.0D+00,           0.0D+00, &
+    0.007159876D+00,  0.0D+00,         -0.003528426D+00,   0.0D+00, &
+    0.0D+00,          0.0D+00 /)
+  double precision, parameter, dimension ( 10 ) :: bq = (/ &
+    1.1278334D+00,    0.0D+00,         -0.5944001D+00,   -5.010996D+00, &
+    0.0D+00,          0.63684256D+00,   0.0D+00,          0.0D+00, &
+    0.0D+00,          0.0D+00 /)
+  integer i
+  double precision t
+  double precision, parameter :: t_ref = 647.073D+00
+  double precision v(10)
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'BB - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+!
+!  Set V(I) = ( T_REF / T )**(I-1).
+!
+  v(1) = 1.0D+00
+  do i = 2, 10
+    v(i) = v(i-1) * t_ref / t
+  end do
+!
+!  Set B1, B1T, B1TT.
+!
+  b1 = bp(1) + bp(2) * log ( 1.0D+00 / v(2) )
+  b1t = bp(2) * v(2) / t_ref
+  b1tt = 0.0D+00
+  do i = 3, 10
+    b1 = b1 + bp(i) * v(i-1)
+    b1t = b1t - dble ( i - 2 ) * bp(i) * v(i-1) / t
+    b1tt = b1tt + bp(i) * dble ( i - 2 )**2 * v(i-1) / t**2
+  end do
+
+  b1tt = b1tt -  ( b1t / t )
+!
+!  Set B2, B2T, B2TT.
+!
+  b2 = bq(1)
+  b2t = 0.0D+00
+  b2tt = 0.0D+00
+  do i = 3, 10
+    b2 = b2 + bq(i) * v(i-1)
+    b2t = b2t - dble ( i - 2 ) * bq(i) * v(i-1) / t
+    b2tt = b2tt + bq(i) * dble ( i - 2 )**2 * v(i-1) / t**2
+  end do
+
+  b2tt = b2tt - ( b2t / t )
+
+  return
+end subroutine bb
+
+
+subroutine ideal ( t, ai, cpi, cvi, gi, hi, si, ui )
+!
+!*******************************************************************************
+!
+!! IDEAL computes ideal gas thermodynamic properties of water.
+!
+!
+!  Discussion:
+!
+!    Values for thermodynamic properties of water in the ideal
+!    gas state were reported by Woolley.  The formula for the ideal gas
+!    term of the Helmholtz function approximates a term by term summation of 
+!    contributions from each of the rotation and vibration states.  
+!    The formula, equation #6 in the reference, is:
+!   
+!    A(ideal)(T) = -R * T * ( 1 + ( C(1)/Tr + C(2) ) * ln(Tr)
+!      + Sum ( 3 <= I <= 18) C(I) * Tr**(I-6)
+!   
+!    where Tr=T/100 K.  The C(i) are tabulated coefficients.  Equation
+!    6 can be used for temperatures below 3000 K, and is accurate to
+!    within the tolerance of the gas constant for 50<=T<=2000 K.
+!     
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Output, double precision AI, the Helmholtz function, in KJ/kg.
+!
+!    Output, double precision CPI, the heat capacity at constant pressure,
+!    in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision CVI, the heat capacity at constant volume,
+!    in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision GI, the Gibbs free energy, in KJ/kg.
+!
+!    Output, double precision HI, the enthalpy, in KJ/kg.
+!
+!    Output, double precision SI, the entropy, in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision UI, the internal energy, in KJ/kg.
+!
+  implicit none
+!
+  double precision ai
+  double precision, parameter, dimension ( 18 ) :: c = (/ &
+   19.730271018D+00,      20.9662681977D+00,     -0.483429455355D+00, &
+    6.05743189245D+00,    22.56023885D+00,       -9.87532442D+00, &
+   -4.3135538513D+00,      0.458155781D+00,      -0.047754901883D+00, &
+    0.0041238460633D+00,  -0.00027929052852D+00,  0.14481695261D-04, &
+   -0.56473658748D-06,     0.16200446D-07,       -0.3303822796D-09, &
+    0.451916067368D-11,   -0.370734122708D-13,    0.137546068238D-15 /)
+  double precision cpi
+  double precision cvi
+  double precision gascon
+  double precision gi
+  double precision hi
+  integer i
+  double precision si
+  double precision t
+  double precision temp
+  double precision tt
+  double precision ui
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'IDEAL - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+
+  tt = t / 100.0D+00
+
+  gi = - ( c(1) / tt + c(2) ) * log ( tt )
+  do i = 3, 18
+    gi = gi - c(i) * tt**(i-6)
+  end do
+
+  hi = c(2) + c(1) * ( 1.0D+00 - log ( tt ) ) / tt
+  do i = 3, 18
+    hi = hi + dble ( i - 6 ) * c(i) * tt**(i-6)
+  end do
+
+  cpi = c(2) - c(1) / tt
+  do i = 3, 18
+    cpi = cpi + dble ( ( i - 6 ) * ( i - 5 ) ) * c(i) * tt**(i-6)
+  end do
+
+  ai = gi - 1.0D+00
+  ui = hi - 1.0D+00
+  cvi = cpi - 1.0D+00
+  si = hi - gi
+!
+!  Assign dimensions.
+!
+  ai =  gascon() * t * ai
+  cpi = gascon()     * cpi
+  cvi = gascon()     * cvi
+  gi =  gascon() * t * gi
+  hi =  gascon() * t * hi
+  si =  gascon()     * si
+  ui =  gascon() * t * ui
+
+  return
+end subroutine ideal
+
+
+subroutine resid ( t, rho, ar, cvr, dpdrr, dpdtr, gr, hr, pr, sr, ur )
+!
+!*******************************************************************************
+!
+!! RESID calculates residual contributions to thermodynamic quantities.
+!
+!
+!  Discussion:
+!
+!    The residual function consists of 40 terms.  The first 36 are
+!    used in a global least squares fit to experimental data.
+!
+!    Three terms were added that contribute only in the immediate
+!    neighborhood of the critical point 
+!      (tk-5) <= T <= (tk+5) C
+!      0.20   <= rho <= 0.44 g/cm3, 
+!
+!    A single term was added for the region of high pressure and 
+!    low temperature: T < 75 C, P > 300 MPa.
+!
+!    Except in these limited regions, the residual function is
+!    given by the first 36 terms.  The equation is
+!   
+!      A(residual)(rho,T)=
+!        sum(i=1 to 36) (g(i)/k(i)) * (T0/T)**(l(i)) (1-exp(-rho))**(k(i))
+!      + sum(i=37 to 40) g(i)*delta(i)**(k(i))
+!        * exp(-alpha(i)*delta(i)**(k(i)) - beta(i)*tau(i)**2)
+!                                                     (Equation 5)
+!   
+!    where
+!
+!      g(i) are coefficients determined by fits to data,
+!      delta(i) are reduced densities (delta(i)=((rho-rho(i))/rho(i))
+!      tau(i) are reduced temperatures (tau(i)=((T-tau(i))/tau(i))
+!      rho(i) are specified densities.
+!      tau(i) are specified temperatures.
+!      The k(i) and l(i) are specified integers.
+!   
+!  Modified:
+!
+!    22 November 1998
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Input, double precision RHO, the density, in G/CM3.
+!
+!    Output, double precision AR, the residual contribution to the 
+!    Helmholtz function, in KJ/kg.
+!
+!    Output, double precision CVR, the residual contribution to the 
+!    isochoric (constant volume) heat capacity, in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision DPDRR, the residual contribution to 
+!    the partial derivative dP(T,RHO)/dRHO, with T held fixed, in 
+!    (MegaPascals CM3)/G.
+!
+!    Output, double precision DPDTR, the residual contribution to 
+!    the partial derivative dP(T,RHO)/dT, with RHO held fixed, 
+!    in MegaPascals/degrees Kelvin.
+!
+!    Output, double precision GR, the residual contribution to the Gibbs 
+!    function, in KJ/kg.
+!
+!    Output, double precision HR, the residual contribution to the 
+!    enthalpy, in KJ/kg.
+!
+!    Output, double precision PR, the residual contribution to the pressure, 
+!    in MegaPascals.
+!
+!    Output, double precision SR, the residual contribution to the entropy, 
+!    in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision UR, the residual contribution to the 
+!    internal energy, in KJ/kg.
+!
+  implicit none
+!
+  double precision, parameter, dimension ( 4 ) :: aad = (/ &
+    34.0D+00, 40.0D+00, 30.0D+00, 1050.0D+00 /)
+  double precision, parameter, dimension ( 4 ) :: aat = (/ &
+    20000.0D+00, 20000.0D+00, 40000.0D+00, 25.0D+00 /)
+  double precision, parameter, dimension ( 4 ) :: adz = (/ &
+    0.319D+00, 0.319D+00, 0.319D+00, 1.55D+00 /)
+  double precision ar
+  double precision att
+  double precision, parameter, dimension ( 4 ) ::  atz = (/ &
+    640.0D+00, 640.0D+00, 641.6D+00, 270.0D+00 /)
+  double precision cvr
+  double precision dadt
+  double precision ddz
+  double precision del
+  double precision dex
+  double precision dfdt
+  double precision dpdrr
+  double precision dpdtr
+  double precision e
+  double precision errtol
+  double precision ex0
+  double precision ex1
+  double precision ex2
+  double precision fct
+  double precision, parameter, dimension ( 40 ) :: g = (/ &
+    -530.62968529023D+00,  0.22744901424408D+04, 0.78779333020687D+03, &
+    -69.830527374994D+00,  0.17863832875422D+05,-0.39514731563338D+05, &
+    0.33803884280753D+05, -0.13855050202703D+05,-0.25637436613260D+06, &
+    0.48212575981415D+06, -0.34183016969660D+06, 0.12223156417448D+06, &
+    0.11797433655832D+07, -0.21734810110373D+07, 0.10829952168620D+07, &
+   -0.25441998064049D+06, -0.31377774947767D+07, 0.52911910757704D+07, &
+   -0.13802577177877D+07, -0.25109914369001D+06, 0.46561826115608D+07, &
+   -0.72752773275387D+07,  0.41774246148294D+06, 0.14016358244614D+07, &
+   -0.31555231392127D+07,  0.47929666384584D+07, 0.40912664781209D+06, &
+   -0.13626369388386D+07,  0.69625220862664D+06,-0.10834900096447D+07, &
+   -0.22722827401688D+06,  0.38365486000660D+06, 0.68833257944332D+04, &
+    0.21757245522644D+05, -0.26627944829770D+04,-0.70730418082074D+05, &
+   -0.225D+00, -1.68D+00, 0.055D+00, -93.0D+00 /)
+  double precision gascon
+  double precision gr
+  double precision hr
+  integer i
+  integer, parameter, dimension ( 40 ) :: ii = (/ &
+    0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,6,6,6,6, &
+    8,8,8,8,2,2,0,4,2,2,2,4 /)
+  integer j
+  integer, parameter, dimension ( 40 ) :: jj = (/ &
+    2,3,5,7,2,3,5,7,2,3,5,7,2,3,5,7,2,3,5,7,2,3,5,7,2,3,5,7,&
+    2,3,5,7,1,4,4,4,0,2,0,0 /)
+  integer k
+  integer l
+  integer nc
+  double precision pr
+  double precision q10
+  double precision q20
+  double precision q2a
+  double precision q5t
+  double precision qm
+  double precision qp
+  double precision qr(11)
+  double precision qt(10)
+  double precision rho
+  double precision sr
+  double precision, parameter :: s_ref = 7.6180720166752D+00
+  double precision t
+  double precision, parameter :: t_ref = 647.073D+00
+  double precision tau
+  double precision tx
+  double precision, parameter :: u_ref = - 4328.4549774261D+00
+  double precision ur
+  double precision v
+!
+  errtol = sqrt ( epsilon ( errtol ) )
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'RESID - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+!
+!  Refuse to handle zero or negative density.
+!
+  if ( rho <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'RESID - Fatal error!'
+    write ( *, '(a)' ) '  The input density RHO must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was RHO = ', rho
+    stop
+  end if
+
+  nc = 36
+  dpdrr = 0.0D+00
+  pr = 0.0D+00
+  ar = 0.0D+00
+  dadt = 0.0D+00
+  cvr = 0.0D+00
+  dpdtr = 0.0D+00
+
+  ex0 = - rho
+! ex0 = max ( ex0, - 225.0D+00 )
+! ex0 = min ( ex0, 225.0D+00 )
+  e = exp ( ex0 )
+
+  q10 = rho * rho * e
+  q20 = 1.0D+00 - e
+
+  qr(1) = 0.0D+00
+  qr(2) = q10
+  do i = 2, 10
+    qr(i+1) = qr(i) * q20
+  end do
+
+  v = t_ref / t
+  qt(1) = t / t_ref
+  do i = 2, 10
+    qt(i) = qt(i-1) * v
+  end do
+
+  do i = 1, nc
+
+    k = ii(i) + 1
+    l = jj(i)
+    qp = g(i) * qr(k+1) * qt(l+1)
+    pr = pr + qp
+
+    dpdrr = dpdrr + ( 2.0D+00 / rho - ( 1.0D+00 - e * dble ( k - 1 ) / &
+      ( 1.0D+00 - e ) ) ) * qp
+
+    ar = ar + g(i) * qr(k+2) * qt(l+1) / ( rho**2 * e * dble ( k ) &
+      * gascon ( ) * t )
+
+    dfdt = ( 1.0D+00 - e )**k * dble ( 1 - l ) * qt(l+2) / t_ref / dble ( k )
+
+    dadt = dadt + g(i) * dfdt
+
+    dpdtr = dpdtr + g(i) * dfdt * rho**2 * e * dble ( k ) / ( 1.0D+00 - e )
+
+    cvr = cvr + g(i) * dble ( l ) * dfdt / gascon()
+
+  end do
+
+  qp = 0.0D+00
+  q2a = 0.0D+00
+
+  do j = 37, 40
+
+    k = ii(j)
+    ddz = adz(j-36)
+    del = rho / ddz - 1.0D+00
+
+    if ( abs ( del ) < errtol ) then
+      del = errtol
+    end if
+
+    ex1 = - aad(j-36) * del**k
+!   ex1 = max ( ex1, - 225.0D+00 )
+!   ex1 = min ( ex1, 225.0D+00 )
+    dex = exp ( ex1 ) * del**jj(j)
+
+    att = aat(j-36)
+    tx = atz(j-36)
+    tau = ( t / tx ) - 1.0D+00
+
+    ex2 = - att * tau**2
+!   ex2 = max ( ex2, - 225.0D+00 )
+!   ex2 = min ( ex2, 225.0D+00 )
+    q10 = dex * exp ( ex2 )
+
+    qm = dble ( jj(j) ) / del - dble ( k ) * aad(j-36) * del**(k-1)
+    fct = qm * rho**2 * q10 / ddz
+
+    q5t = fct * ( 2.0D+00 / rho + qm / ddz ) - ( rho / ddz )**2 * q10 * &
+      ( dble ( jj(j) ) / del**2 + dble ( k * ( k - 1 ) ) * aad(j-36) * &
+      del**(k-2) )
+
+    dpdrr = dpdrr + q5t * g(j)
+    qp = qp + g(j) * fct
+    dadt = dadt - 2.0D+00 * g(j) * att * tau * q10 / tx
+    dpdtr = dpdtr - 2.0D+00 * g(j) * att * tau * fct / tx
+
+    q2a = q2a + t * g(j) * att * ( 4.0D+00 * ex2 + 2.0D+00 ) * q10 / tx**2
+
+    ar = ar + q10 * g(j) / ( gascon() * t )
+
+  end do
+
+  cvr = cvr + q2a / gascon()
+  pr = pr + qp
+  sr = - dadt / gascon()
+  ur = ar + sr
+!
+!  Assign dimensions.
+!
+  ar =  gascon() * t *  ar
+  cvr = gascon() *     cvr
+  sr =  gascon() *      sr
+  ur =  gascon() * t *  ur
+!
+!  Adjust energies.
+!
+  ar = ar + gascon ( ) * t * s_ref - gascon ( ) * u_ref
+  sr = sr - gascon ( ) * s_ref
+  ur = ur - gascon ( ) * u_ref
+
+  gr = ar + pr / rho
+  hr = ur + pr / rho
+
+  return
+end subroutine resid
+
+subroutine psat_H2O ( t, p )
+!
+!*******************************************************************************
+!
+!! PSAT_H2O makes a rough estimate of the vapor pressure.
+!
+!
+!  Discussion:
+!
+!    The calculation agrees with tabulated data to within
+!    0.02% for temperature to within a degree or so of the critical
+!    temperature.  The approximate vapor pressure can be refined
+!    by imposing the condition that the Gibbs functions of the vapor
+!    and liquid phases be equal.
+!
+!  Modified:
+!
+!    21 November 1998
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Output, double precision P, the vapor pressure, in MegaPascals.
+!
+  implicit none
+!
+  double precision, parameter, dimension ( 8 ) :: a = (/ &
+    -7.8889166D+00,   2.5514255D+00,   -6.716169D+00, 33.239495D+00, &
+    -105.38479D+00,   174.35319D+00,  -148.39348D+00, 48.631602D+00 /)
+  double precision b
+  integer i
+  double precision p
+  double precision q
+  double precision t
+  double precision, parameter :: t_ref = 647.25D+00
+  double precision v
+  double precision w
+  double precision z
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'PSAT_H2O - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+
+  if ( t <= 314.0D+00 ) then
+
+    p = 0.1D+00 * exp ( 6.3573118D+00 - 8858.843D+00 / t &
+      + 607.56335D+00 * t**( -0.6D+00 ) )
+
+  else
+
+    v = t / t_ref
+    w = abs ( 1.0D+00 - v )
+    b = 0.0D+00
+    do i = 1, 8
+      z = i
+      b = b + a(i) * w**( ( z + 1.0D+00 ) / 2.0D+00 )
+    end do
+
+    q = b / v
+    p = 22.093D+00 * exp ( q )
+
+  end if
+
+  return
+end subroutine psat_H2O
+
+
+subroutine tdpsdt ( t, dp )
+!
+!*******************************************************************************
+!
+!! TDPSDT computes the quantity T * dP(Sat)/dT.
+!
+!
+!  Discussion:
+!
+!    Here T is the temperature and P(Sat) is the vapor pressure.  
+!    It is used by TSAT_EST and TSAT.
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Output, double precision DP, the value T*(dP(Sat)/dT), 
+!    in MegaPascals.
+!
+  implicit none
+!
+  double precision, parameter, dimension ( 8 ) :: a = (/ &
+      -7.8889166D+00,   2.5514255D+00,   -6.716169D+00, 33.239495D+00, &
+    -105.38479D+00,   174.35319D+00,   -148.39348D+00,  48.631602D+00 /)
+  double precision b
+  double precision c
+  double precision dp
+  integer i
+  double precision q
+  double precision t
+  double precision, parameter :: t_ref = 647.25D+00
+  double precision v
+  double precision w
+  double precision y
+  double precision z
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'TDPSDT - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+
+  v = t / t_ref
+  w = 1.0D+00 - v
+  b = 0.0D+00
+  c = 0.0D+00
+  do i = 1, 8
+    z = dble ( i + 1 ) / 2.0D+00
+    y = a(i) * w**z
+    c = c + ( y / w ) * ( 0.5D+00 - 0.5D+00 * dble ( i ) - 1.0D+00 / v )
+    b = b + y
+  end do
+
+  q = b / v
+  dp = 22.093D+00 * exp ( q ) * c
+
+  return
+end subroutine tdpsdt
+
+
+
+subroutine therm ( t, rho, a, cjth, cjtt, cp, cv, dpdr, dpdt, g, h, p, s, u )
+!
+!*******************************************************************************
+!
+!! THERM calculates thermodynamic functions given temperature and density.
+!
+!
+!  Discussion:
+!
+!    Thermodynamic values were calculated from an analytic equation
+!    that approximates the Helmholtz function (specific Helmholtz
+!    energy) for ordinary water and steam, of the form A=A(rho,T)
+!    where A is the Helmholtz function, rho the density, and T
+!    the absolute (thermodynamic) temperature.  Any thermodynamic
+!    value for any state, liquid, vapor or metastable, may be
+!    calculated by differentiation of this equation in accord with
+!    the first and second laws of thermodynamics.
+! 
+!    The International Association for the Properties of Steam
+!    has provisionally accepted this formulation for the range
+!    273.15 <= T <= 1273.15 degrees Kelvin, where, for 423.15 <= T,
+!    the maximum pressure is Pmax = 1500 MPa = 15000 bar, and for
+!    273.15 <= T < 423.15, the maximum pressure is
+!    Pmax = 100 * (5 + (T-273.15)/15) MPa.
+! 
+!    Close to the critical point, a small region is excluded:
+!    Abs(T-Tk) < 1, abs((rho-rhok)/rhok) < 0.3.
+! 
+!    The equation has a wider useful range, namely, fluid states
+!    of pure, undissociated water and steam defined by
+!    260 <= T <= 2500 K and 0 <= P <= 3000 MPa.
+! 
+!    Thermodynamic property values for specific volume, density,
+!    specific internal energy, specific enthalpy, and specific
+!    entropy of water and steam were tabulated over the range
+!    0 <= t <= 2000 C, 0 <= P <= 3000 MPa.  The reference
+!    state is the liquid at the triple point, for which the
+!    internal energy and entropy have been assigned the value zero.
+!     
+!    Thermodynamic quantities are determined from the Helmholtz function
+!    A(rho,T), which is computed as the sum of three terms:
+!
+!      A(rho,T) = A(base)(rho,T) + A(residual)(rho,T) + A(ideal)(T)
+!                                                       (Equation 1)
+!
+!    Because A(rho,T) is everywhere single valued and analytic,
+!    we can derive closed form relations for all other properties.
+!    In the following, unless otherwise indicated, the independent
+!    variables are temperature T and density RHO, and differentiation
+!    with respect to one variable is to imply that the other is fixed.
+! 
+!    Pressure:                  P       = RHO**2 * dA/dRHO
+!    Density derivative:        dP/dRHO = 2*P/RHO + RHO**2 * d2A/dRHO2
+!    Temperature derivative:    dP/dT   = RHO**2 * d2A/(dRHO dT)
+!    Specific entropy:          S       = - dA/dT
+!    Specific internal energy:  U       = A + T*S
+!    Specific enthalpy:         H       = U + P/RHO
+!    Specific heat capacity
+!      at constant volume:      Cv      = - T * d2A/dT2
+!    Specific Gibbs function:   G       = A + P/RHO
+!    Specific heat capacity
+!      at constant pressure:    Cp      = Cv + (T*(dP/dT)**2)/(RHO**2*dP/dRHO)
+!    Speed of sound:            Omega   = Sqrt ((Cp/Cv) * dP/dRHO)
+!    Second virial coefficient: B       = 1/(2*R*T) * (d2P/dRHO2) (at RHO=0)
+!    Isothermal Joule-Thomson
+!      coefficient:             DeltaT  = (dH/dP) (fixed T) =
+!                                         (1/RHO)-(T*dP/dT)/(RHO**2*dP/dRHO)
+!    Joule-Thomson coefficient: Mu      = (dT/dP) (fixed H) = DeltaT/Cp
+!    Isentropic temperature-
+!      pressure coefficient:    BetaS   = (dT/dP) (fixed S) =
+!                                         (DeltaT - 1/RHO)/Cp
+!   
+!  Modified:
+!
+!    19 November 1998
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Parameters:
+!
+!    Input, double precision T, the temperature, in degrees Kelvin.
+!
+!    Input, double precision RHO, the fluid density, in G/CM3.
+!
+!    Output, double precision A, the Helmholtz function, in KJ/kg.
+!
+!    Output, double precision CJTH, the Joule-Thomson coefficient,
+!    in K/MegaPascals.
+!
+!    Output, double precision CJTT, the isothermal Joule-Thomson coefficient,
+!    in CM3/G.
+!
+!    Output, double precision CP, the isobaric (constant pressure) heat
+!    capacity, in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision CV, the isochoric (constant volume) heat capacity,
+!    in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision DPDR, the partial derivative 
+!    dP(T,RHO)/dRHO, with T held fixed, in MegaPascals*CM3/G.
+!
+!    Output, double precision DPDT, the partial derivative 
+!    dP(T,RHO)/dT, with RHO held fixed, in MegaPascals/degrees Kelvin.
+!
+!    Output, double precision G, the Gibbs free energy, in KJ/kg.
+!
+!    Output, double precision H, the enthalpy, in KJ/kg.
+!
+!    Output, double precision P, the pressure, in MegaPascals.
+!
+!    Output, double precision S, the entropy, in KJ/(kg degrees Kelvin).
+!
+!    Output, double precision U, the internal energy, in KJ/kg.
+!
+  implicit none
+!
+  double precision a
+  double precision ab
+  double precision ai
+  double precision ar
+  double precision cjth
+  double precision cjtt
+  double precision cp
+  double precision cpi
+  double precision cv
+  double precision cvb
+  double precision cvi
+  double precision cvr
+  logical, parameter :: debug = .false.
+!  logical, parameter :: debug = .true.
+  double precision dpdr
+  double precision dpdrb
+  double precision dpdrr
+  double precision dpdt
+  double precision dpdtb
+  double precision dpdtr
+  double precision g
+  double precision gb
+  double precision gi
+  double precision gr
+  double precision h
+  double precision hb
+  double precision hi
+  double precision hr
+  double precision p
+  double precision pb
+  double precision pr
+  double precision rho
+  double precision s
+  double precision sb
+  double precision si
+  double precision sr
+  double precision t
+  double precision u
+  double precision ub
+  double precision ui
+  double precision ur
+!
+!  Refuse to handle zero or negative temperatures.
+!
+  if ( t <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'THERM - Fatal error!'
+    write ( *, '(a)' ) '  The input temperature T must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was T = ', t
+    stop
+  end if
+!
+!  Refuse to handle zero or negative density.
+!
+  if ( rho <= 0.0D+00 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'THERM - Fatal error!'
+    write ( *, '(a)' ) '  The input density RHO must be positive.'
+    write ( *, '(a,g14.6)' ) '  Input value was RHO = ', rho
+    stop
+  end if
+
+  call ideal ( t, ai, cpi, cvi, gi, hi, si, ui )
+
+  call resid ( t, rho, ar, cvr, dpdrr, dpdtr, gr, hr, pr, sr, ur )
+
+  call base ( t, rho, ab, cvb, dpdrb, dpdtb, gb, hb, pb, sb, ub )
+
+  a =       ab +    ar +  ai
+  cv =     cvb +   cvr + cvi
+
+  if ( debug ) then
+    write ( *, * ) ' '
+    write ( *, * ) 'THERM:'
+    write ( *, * ) '  CVB = ', cvb
+    write ( *, * ) '  CVR = ', cvr
+    write ( *, * ) '  CVI = ', cvi
+    write ( *, * ) '  CV  = ', cv
+  end if
+
+
+  dpdr = dpdrb + dpdrr
+  dpdt = dpdtb + dpdtr
+  p =       pb +    pr
+  s =       sb +    sr +  si
+  u =       ub +    ur +  ui
+
+  if ( debug ) then
+    write ( *, * ) ' '
+    write ( *, * ) 'THERM:'
+    write ( *, * ) '  UB = ', ub
+    write ( *, * ) '  UR = ', ur
+    write ( *, * ) '  UI = ', ui
+  end if
+
+  g = a + p / rho
+  h = u + p / rho
+  cp = cv + t * dpdt**2 / ( dpdr * rho**2 )
+  cjtt = 1.0D+00 / rho - t * dpdt / ( dpdr * rho**2 )
+  cjth = - cjtt / cp
+
+  return
+end subroutine therm
+
+function gascon ( )
+!
+!*******************************************************************************
+!
+!! GASCON returns the value of the specific gas constant.
+!
+!
+!  Note:
+!
+!    The specific gas constant R is related to the universal gas
+!    constant R-bar = 8.31441 J/(mol degrees Kelvin) by the molar mass 
+!    M = 18.0152 g/mol:
+!
+!      R = R-bar / M.
+!
+!  Reference:
+!
+!    Lester Haar, John Gallagher and George Kell,
+!    NBS/NRC Steam Tables:
+!    Thermodynamic and Transport Properties and Computer Programs
+!      for Vapor and Liquid States of Water in SI Units,
+!    Hemisphere Publishing Corporation, Washington, 1984,
+!    TJ270.H3
+!
+!    C A Meyer, R B McClintock, G J Silvestri, R C Spencer,
+!    ASME Steam Tables: Thermodynamic and Transport Properties of Steam,
+!    American Society of Mechanical Engineers, 1967.
+!
+!  Parameters:
+!
+!    Output, double precision GASCON, the value of the specific gas 
+!    constant, in J/(g degrees Kelvin).
+!
+  implicit none
+!
+  double precision gascon
+!
+  gascon = 0.461522D+00
+ 
+  return
+end function gascon
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phyetat0.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phyetat0.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phyetat0.F90	(revision 222)
@@ -0,0 +1,399 @@
+subroutine phyetat0 (ngrid,fichnom,tab0,Lmodif,nsoil,nq, &
+                     day_ini,time,tsurf,tsoil, &
+                     emis,q2,qsurf,cloudfrac,totcloudfrac,hice, &
+                     rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+
+
+  USE infotrac, ONLY: tname
+  USE surfdat_h, only: phisfi, albedodat, zmea, zstd, zsig, zgam, zthe
+  use iostart, only: nid_start, open_startphy, close_startphy, &
+                     get_field, get_var, inquire_field, &
+                     inquire_dimension, inquire_dimension_length
+  use slab_ice_h, only: noceanmx
+
+  implicit none
+
+!======================================================================
+! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+!  Adaptation à Mars : Yann Wanherdrick 
+! Objet: Lecture de l etat initial pour la physique
+!======================================================================
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "dimphys.h"
+#include "planete.h"
+#include "comcstfi.h"
+
+!======================================================================
+!  INTEGER nbsrf !Mars nbsrf a 1 au lieu de 4
+!  PARAMETER (nbsrf=1) ! nombre de sous-fractions pour une maille
+!======================================================================
+!  Arguments:
+!  ---------
+!  inputs:
+  integer,intent(in) :: ngrid
+  character*(*),intent(in) :: fichnom ! "startfi.nc" file
+  integer,intent(in) :: tab0
+  integer,intent(in) :: Lmodif
+  integer,intent(in) :: nsoil ! # of soil layers
+  integer,intent(in) :: nq
+  integer,intent(in) :: day_ini
+  real,intent(in) :: time
+
+!  outputs:
+  real,intent(out) :: tsurf(ngrid) ! surface temperature
+  real,intent(out) :: tsoil(ngrid,nsoil) ! soil temperature
+  real,intent(out) :: emis(ngrid) ! surface emissivity
+  real,intent(out) :: q2(ngrid, llm+1) ! 
+  real,intent(out) :: qsurf(ngrid,nq) ! tracers on surface
+! real co2ice(ngrid) ! co2 ice cover
+  real,intent(out) :: cloudfrac(ngrid,nlayermx)
+  real,intent(out) :: hice(ngrid), totcloudfrac(ngrid)
+  real,intent(out) :: pctsrf_sic(ngrid),tslab(ngrid,noceanmx)  
+  real,intent(out) :: tsea_ice(ngrid),sea_ice(ngrid)
+  real,intent(out) :: rnat(ngrid)
+
+!======================================================================
+!  Local variables:
+
+!      INTEGER radpas
+!      REAL co2_ppm
+!      REAL solaire
+
+      real xmin,xmax ! to display min and max of a field
+!
+      INTEGER ig,iq,lmax
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf
+!      integer isoil 
+!      INTEGER length
+!      PARAMETER (length=100)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+      CHARACTER*1 yes
+!
+      REAL p_rad,p_omeg,p_g,p_cpp,p_mugaz,p_daysec
+      INTEGER nqold
+
+! flag which identifies if 'startfi.nc' file is using old names (qsurf01,...)
+!      logical :: oldtracernames=.false.
+      integer :: count
+      character(len=30) :: txt ! to store some text
+      
+      INTEGER :: indextime=1 ! index of selected time, default value=1
+      logical :: found
+
+!
+! ALLOCATE ARRAYS IN surfdat_h
+!
+IF (.not. ALLOCATED(albedodat)) ALLOCATE(albedodat(ngrid))
+IF (.not. ALLOCATED(phisfi)) ALLOCATE(phisfi(ngrid))
+IF (.not. ALLOCATED(zmea)) ALLOCATE(zmea(ngrid))
+IF (.not. ALLOCATED(zstd)) ALLOCATE(zstd(ngrid))
+IF (.not. ALLOCATED(zsig)) ALLOCATE(zsig(ngrid))
+IF (.not. ALLOCATED(zgam)) ALLOCATE(zgam(ngrid))
+IF (.not. ALLOCATED(zthe)) ALLOCATE(zthe(ngrid))
+
+
+! open physics initial state file:
+call open_startphy(fichnom)
+
+
+! possibility to modify tab_cntrl in tabfi
+write(*,*)
+write(*,*) 'TABFI in phyeta0: Lmodif=',Lmodif," tab0=",tab0
+call tabfi (ngrid,nid_start,Lmodif,tab0,day_ini,lmax,p_rad, &
+                   p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
+
+!c
+!c Lecture des latitudes (coordonnees):
+!c
+!      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
+!      IF (ierr.NE.NF_NOERR) THEN
+!         PRINT*, 'phyetat0: Le champ <latitude> est absent'
+!         CALL abort
+!      ENDIF
+!#ifdef NC_DOUBLE
+!      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,sta,ngrid,lati)
+!#else
+!      ierr = NF_GET_VARA_REAL(nid,nvarid,sta,ngrid,lati)
+!#endif
+!      IF (ierr.NE.NF_NOERR) THEN
+!         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+!         CALL abort
+!      ENDIF
+!c
+!c Lecture des longitudes (coordonnees):
+!c
+!      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
+!      IF (ierr.NE.NF_NOERR) THEN
+!         PRINT*, 'phyetat0: Le champ <longitude> est absent'
+!         CALL abort
+!      ENDIF
+!#ifdef NC_DOUBLE
+!      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,sta,ngrid,long)
+!#else
+!      ierr = NF_GET_VARA_REAL(nid,nvarid,sta,ngrid,long)
+!#endif
+!      IF (ierr.NE.NF_NOERR) THEN
+!         PRINT*, 'phyetat0: Lecture echouee pour <longitude>'
+!         CALL abort
+!      ENDIF
+!c
+!c Lecture des aires des mailles:
+!c
+!      ierr = NF_INQ_VARID (nid, "area", nvarid)
+!      IF (ierr.NE.NF_NOERR) THEN
+!         PRINT*, 'phyetat0: Le champ <area> est absent'
+!         CALL abort
+!      ENDIF
+!#ifdef NC_DOUBLE
+!      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,sta,ngrid,area)
+!#else
+!      ierr = NF_GET_VARA_REAL(nid,nvarid,sta,ngrid,area)
+!#endif
+!      IF (ierr.NE.NF_NOERR) THEN
+!         PRINT*, 'phyetat0: Lecture echouee pour <area>'
+!         CALL abort
+!      ENDIF
+!      xmin = 1.0E+20
+!      xmax = -1.0E+20
+!      xmin = MINVAL(area)
+!      xmax = MAXVAL(area)
+!      PRINT*,'Aires des mailles <area>:', xmin, xmax
+
+! Load surface geopotential:
+call get_field("phisfi",phisfi,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <phisfi>"
+  call abort
+else
+  write(*,*) "phyetat0: surface geopotential <phisfi> range:", &
+             minval(phisfi), maxval(phisfi)
+endif
+
+! Load bare ground albedo:
+call get_field("albedodat",albedodat,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <albedodat>"
+  call abort
+else
+  write(*,*) "phyetat0: Bare ground albedo <albedodat> range:", &
+             minval(albedodat), maxval(albedodat)
+endif
+
+! ZMEA
+call get_field("ZMEA",zmea,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <ZMEA>"
+  call abort
+else
+  write(*,*) "phyetat0: <ZMEA> range:", &
+             minval(zmea), maxval(zmea)
+endif
+
+! ZSTD
+call get_field("ZSTD",zstd,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <ZSTD>"
+  call abort
+else
+  write(*,*) "phyetat0: <ZSTD> range:", &
+             minval(zstd), maxval(zstd)
+endif
+
+! ZSIG
+call get_field("ZSIG",zsig,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <ZSIG>"
+  call abort
+else
+  write(*,*) "phyetat0: <ZSIG> range:", &
+             minval(zsig), maxval(zsig)
+endif
+
+! ZGAM
+call get_field("ZGAM",zgam,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <ZGAM>"
+  call abort
+else
+  write(*,*) "phyetat0: <ZGAM> range:", &
+             minval(zgam), maxval(zgam)
+endif
+
+! ZTHE
+call get_field("ZTHE",zthe,found)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <ZTHE>"
+  call abort
+else
+  write(*,*) "phyetat0: <ZTHE> range:", &
+             minval(zthe), maxval(zthe)
+endif
+
+! Surface temperature :
+call get_field("tsurf",tsurf,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <tsurf>"
+  call abort
+else
+  write(*,*) "phyetat0: Surface temperature <tsurf> range:", &
+             minval(tsurf), maxval(tsurf)
+endif
+
+! Surface emissivity
+call get_field("emis",emis,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <emis>"
+  call abort
+else
+  write(*,*) "phyetat0: Surface emissivity <emis> range:", &
+             minval(emis), maxval(emis)
+endif
+
+! Cloud fraction (added by BC 2010)
+call get_field("cloudfrac",cloudfrac,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <cloudfrac>"
+  call abort
+else
+  write(*,*) "phyetat0: Cloud fraction <cloudfrac> range:", &
+             minval(cloudfrac), maxval(cloudfrac)
+endif
+
+! Total cloud fraction (added by BC 2010)
+call get_field("totcloudfrac",totcloudfrac,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <totcloudfrac>"
+  call abort
+else
+  write(*,*) "phyetat0: Total cloud fraction <totcloudfrac> range:", &
+             minval(totcloudfrac), maxval(totcloudfrac)
+endif
+
+! Height of oceanic ice (added by BC 2010)
+call get_field("hice",hice,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <hice>"
+!  call abort
+      do ig=1,ngrid
+      hice(ig)=0.
+      enddo
+else
+  write(*,*) "phyetat0: Height of oceanic ice <hice> range:", &
+             minval(hice), maxval(hice)
+endif
+
+! SLAB OCEAN (added by BC 2014)
+! nature of the surface
+call get_field("rnat",rnat,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <rnat>"
+      do ig=1,ngrid
+        rnat(ig)=1.
+      enddo
+else
+      do ig=1,ngrid
+        if((nint(rnat(ig)).eq.2).or.(nint(rnat(ig)).eq.0))then
+          rnat(ig)=0.
+        else
+          rnat(ig)=1.
+        endif      
+      enddo
+
+  write(*,*) "phyetat0: Nature of surface <rnat> range:", &
+             minval(rnat), maxval(rnat)
+endif
+! Pourcentage of sea ice cover
+call get_field("pctsrf_sic",pctsrf_sic,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <pctsrf_sic>"
+      do ig=1,ngrid
+      pctsrf_sic(ig)=0.
+      enddo
+else
+  write(*,*) "phyetat0: Pourcentage of sea ice cover <pctsrf_sic> range:", &
+             minval(pctsrf_sic), maxval(pctsrf_sic)
+endif
+! Slab ocean temperature (2 layers)
+call get_field("tslab",tslab,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <tslab>"
+      do ig=1,ngrid
+      do iq=1,noceanmx
+      tslab(ig,iq)=tsurf(ig)
+      enddo
+      enddo
+else
+  write(*,*) "phyetat0: Slab ocean temperature <tslab> range:", &
+             minval(tslab), maxval(tslab)
+endif
+! Oceanic ice temperature
+call get_field("tsea_ice",tsea_ice,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <tsea_ice>"
+      do ig=1,ngrid
+      tsea_ice(ig)=273.15-1.8
+      enddo
+else
+  write(*,*) "phyetat0: Oceanic ice temperature <tsea_ice> range:", &
+             minval(tsea_ice), maxval(tsea_ice)
+endif
+!  Oceanic ice quantity (kg/m^2)
+call get_field("sea_ice",sea_ice,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <sea_ice>"
+      do ig=1,ngrid
+      tsea_ice(ig)=0.
+      enddo
+else
+  write(*,*) "phyetat0: Oceanic ice quantity <sea_ice> range:", &
+             minval(sea_ice), maxval(sea_ice)
+endif
+
+
+
+
+! pbl wind variance
+call get_field("q2",q2,found,indextime)
+if (.not.found) then
+  write(*,*) "phyetat0: Failed loading <q2>"
+  call abort
+else
+  write(*,*) "phyetat0: PBL wind variance <q2> range:", &
+             minval(q2), maxval(q2)
+endif
+
+! tracer on surface
+if (nq.ge.1) then
+  do iq=1,nq
+    txt=tname(iq)
+    if (txt.eq."h2o_vap") then
+      ! There is no surface tracer for h2o_vap;
+      ! "h2o_ice" should be loaded instead
+      txt="h2o_ice"
+      write(*,*) 'phyetat0: loading surface tracer', &
+                           ' h2o_ice instead of h2o_vap'
+    endif
+    call get_field(txt,qsurf(:,iq),found,indextime)
+    if (.not.found) then
+      write(*,*) "phyetat0: Failed loading <",trim(txt),">"
+      write(*,*) "         ",trim(txt)," is set to zero"
+    else
+      write(*,*) "phyetat0: Surface tracer <",trim(txt),"> range:", &
+                 minval(qsurf(:,iq)), maxval(qsurf(:,iq))
+    endif
+  enddo
+endif ! of if (nq.ge.1)
+
+
+! Call to soil_settings, in order to read soil temperatures,
+! as well as thermal inertia and volumetric heat capacity
+call soil_settings(nid_start,ngrid,nsoil,tsurf,tsoil,indextime)
+!
+! close file:
+!
+call close_startphy
+
+END SUBROUTINE phyetat0
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phyredem.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phyredem.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/phyredem.F90	(revision 222)
@@ -0,0 +1,222 @@
+module phyredem
+
+implicit none
+
+contains
+
+subroutine physdem0(filename,lonfi,latfi,nsoil,ngrid,nlay,nq, &
+                         phystep,day_ini,time,airefi, &
+                         alb,ith,pzmea,pzstd,pzsig,pzgam,pzthe)
+! create physics restart file and write time-independent variables
+  use comsoil_h, only: volcapa, mlayer
+  use comgeomfi_h, only: area
+  use surfdat_h, only: zmea, zstd, zsig, zgam, zthe, &
+                       albedice, emisice, emissiv, &
+                       iceradius, dtemisice, phisfi
+  use iostart, only : open_restartphy, close_restartphy, & 
+                      put_var, put_field, length
+  use mod_grid_phy_lmdz, only : klon_glo
+
+  implicit none
+#include "planete.h"
+#include "comcstfi.h"
+  character(len=*), intent(in) :: filename
+  real,intent(in) :: lonfi(ngrid)
+  real,intent(in) :: latfi(ngrid)
+  integer,intent(in) :: nsoil
+  integer,intent(in) :: ngrid
+  integer,intent(in) :: nlay
+  integer,intent(in) :: nq
+  real,intent(in) :: phystep
+  real,intent(in) :: day_ini
+  real,intent(in) :: time
+  real,intent(in) :: airefi(ngrid)
+  real,intent(in) :: alb(ngrid)
+  real,intent(in) :: ith(ngrid,nsoil)
+  real,intent(in) :: pzmea(ngrid)
+  real,intent(in) :: pzstd(ngrid)
+  real,intent(in) :: pzsig(ngrid)
+  real,intent(in) :: pzgam(ngrid)
+  real,intent(in) :: pzthe(ngrid)
+ 
+  real :: tab_cntrl(length) ! nb "length=100" defined in iostart module
+  
+  ! Create physics start file
+  call open_restartphy(filename)
+
+! tab_cntrl() contains run parameters
+  tab_cntrl(:)=0 ! initialization
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! Fill control array tab_cntrl(:) with paramleters for this run
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! Informations on the physics grid
+  tab_cntrl(1) = float(klon_glo)  ! number of nodes on physics grid
+  tab_cntrl(2) = float(nlay) ! number of atmospheric layers
+  tab_cntrl(3) = day_ini + int(time)         ! final day 
+  tab_cntrl(4) = time -int(time)            ! final time of day
+
+! Informations about Mars, used by dynamics and physics
+  tab_cntrl(5) = rad      ! radius of Mars (m) ~3397200
+  tab_cntrl(6) = omeg     ! rotation rate (rad.s-1)
+  tab_cntrl(7) = g        ! gravity (m.s-2) ~3.72
+  tab_cntrl(8) = mugaz    ! Molar mass of the atmosphere (g.mol-1) ~43.49
+  tab_cntrl(9) = rcp      !  = r/cp  ~0.256793 (=kappa dans dynamique)
+  tab_cntrl(10) = daysec  ! length of a sol (s)  ~88775
+
+  tab_cntrl(11) = phystep  ! time step in the physics
+  tab_cntrl(12) = 0.
+  tab_cntrl(13) = 0.
+
+! Informations about Mars, only for physics
+  tab_cntrl(14) = year_day  ! length of year (sols) ~668.6
+  tab_cntrl(15) = periastr  ! min. star-planet distance (AU)
+  tab_cntrl(16) = apoastr   ! max. star-planet distance (AU) 
+  tab_cntrl(17) = peri_day  ! date of periastron (sols since N. spring)
+  tab_cntrl(18) = obliquit  ! Obliquity of the planet (deg) ~23.98
+
+! Boundary layer and turbulence
+  tab_cntrl(19) = z0        ! surface roughness (m) ~0.01
+  tab_cntrl(20) = lmixmin   ! mixing length ~100
+  tab_cntrl(21) = emin_turb ! minimal energy ~1.e-8
+
+! Optical properties of polar caps and ground emissivity
+  tab_cntrl(22) = albedice(1)  ! Albedo of northern cap ~0.5
+  tab_cntrl(23) = albedice(2)  ! Albedo of southern cap ~0.5
+  tab_cntrl(24) = emisice(1)   ! Emissivity of northern cap ~0.95
+  tab_cntrl(25) = emisice(2)   ! Emissivity of southern cap ~0.95
+  tab_cntrl(26) = emissiv      ! Emissivity of martian soil ~.95
+  tab_cntrl(31) = iceradius(1) ! mean scat radius of CO2 snow (north)
+  tab_cntrl(32) = iceradius(2) ! mean scat radius of CO2 snow (south)
+  tab_cntrl(33) = dtemisice(1) ! time scale for snow metamorphism (north)
+  tab_cntrl(34) = dtemisice(2) ! time scale for snow metamorphism (south)
+
+  tab_cntrl(28) = 0. 
+  tab_cntrl(29) = 0.
+  tab_cntrl(30) = 0.
+
+! Soil properties:
+  tab_cntrl(35) = volcapa ! soil volumetric heat capacity
+
+  call put_var("controle","Control parameters",tab_cntrl)
+  
+  ! Write the mid-layer depths
+  call put_var("soildepth","Soil mid-layer depth",mlayer)
+  
+  ! Write longitudes
+  call put_field("longitude","Longitudes of physics grid",lonfi)
+  
+  ! Write latitudes
+  call put_field("latitude","Latitudes of physics grid",latfi)
+  
+  ! Write mesh areas
+  call put_field("area","Mesh area",area)
+  
+  ! Write surface geopotential
+  call put_field("phisfi","Geopotential at the surface",phisfi)
+  
+  ! Write surface albedo
+  call put_field("albedodat","Albedo of bare ground",alb)
+  
+  ! Subgrid topogaphy variables
+  call put_field("ZMEA","Relief: mean relief",zmea)
+  call put_field("ZSTD","Relief: standard deviation",zstd)
+  call put_field("ZSIG","Relief: sigma parameter",zsig)
+  call put_field("ZGAM","Relief: gamma parameter",zgam)
+  call put_field("ZTHE","Relief: theta parameter",zthe)
+  
+  ! Soil thermal inertia
+  call put_field("inertiedat","Soil thermal inertia",ith)
+  
+  ! Close file
+  call close_restartphy
+  
+end subroutine physdem0
+
+subroutine physdem1(filename,nsoil,ngrid,nlay,nq, &
+                    phystep,time,tsurf,tsoil,emis,q2,qsurf, &
+                    cloudfrac,totcloudfrac,hice, &
+                    rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+  ! write time-dependent variable to restart file
+  use iostart, only : open_restartphy, close_restartphy, & 
+                      put_var, put_field
+  use infotrac, only: tname
+  use slab_ice_h, only: noceanmx
+
+  implicit none
+!======================================================================
+!#include "temps.h"
+#include "comcstfi.h"
+#include "planete.h"
+#include "callkeys.h"
+!======================================================================
+  character(len=*),intent(in) :: filename
+  integer,intent(in) :: nsoil
+  integer,intent(in) :: ngrid
+  integer,intent(in) :: nlay
+  integer,intent(in) :: nq
+  real,intent(in) :: phystep
+  real,intent(in) :: time
+  real,intent(in) :: tsurf(ngrid)
+  real,intent(in) :: tsoil(ngrid,nsoil)
+  real,intent(in) :: emis(ngrid)
+  real,intent(in) :: q2(ngrid,nlay+1)
+  real,intent(in) :: qsurf(ngrid,nq)
+  real,intent(in) :: cloudfrac(ngrid,nlay)
+  real,intent(in) :: totcloudfrac(ngrid)
+  real,intent(in) :: hice(ngrid)
+  real,intent(in) :: rnat(ngrid)
+  real,intent(in) :: pctsrf_sic(ngrid)
+  real,intent(in) :: tslab(ngrid,noceanmx)
+  real,intent(in) :: tsea_ice(ngrid)
+  real,intent(in) :: sea_ice(ngrid)
+
+  integer :: iq
+  
+  ! Open file
+  call open_restartphy(filename)
+
+  ! First variable to write must be "Time", in order to correctly
+  ! set time counter in file
+  !call put_var("Time","Temps de simulation",time)
+  
+  ! Surface temperature
+  call put_field("tsurf","Surface temperature",tsurf)
+  
+  ! Soil temperature
+  call put_field("tsoil","Soil temperature",tsoil)
+  
+  ! Emissivity of the surface
+  call put_field("emis","Surface emissivity",emis)
+  
+  ! Planetary Boundary Layer
+  call put_field("q2","pbl wind variance",q2)
+  
+! cloud fraction and sea ice (NB: these should be optional... to be improved)
+  call put_field("cloudfrac","Cloud fraction",cloudfrac)
+  call put_field("totcloudfrac","Total fraction",totcloudfrac)
+  call put_field("hice","Height of oceanic ice",hice)
+
+ !Slab ocean 
+ if(ok_slab_ocean) then
+   call put_field("rnat","Nature of surface",rnat)
+   call put_field("pctsrf_sic","Pourcentage sea ice",pctsrf_sic)
+   call put_field("tslab","Temperature slab ocean",tslab)
+   call put_field("tsea_ice","Temperature sea ice",tsea_ice)
+   call put_field("sea_ice","Sea ice mass",sea_ice)
+ endif!(ok_slab_ocean)
+
+
+! tracers
+  if (nq>0) then
+    do iq=1,nq
+      call put_field(tname(iq),"tracer on surface",qsurf(:,iq))
+    enddo
+  endif ! of if (nq>0)
+
+! close file
+      CALL close_restartphy
+!$OMP BARRIER
+
+end subroutine physdem1
+
+end module phyredem
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/physiq.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/physiq.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/physiq.F90	(revision 222)
@@ -0,0 +1,2273 @@
+      subroutine physiq(ngrid,nlayer,nq,   &
+                  nametrac,                & 
+                  firstcall,lastcall,      &
+                  pday,ptime,ptimestep,    &
+                  pplev,pplay,pphi,        &
+                  pu,pv,pt,pq,             &
+                  pw,                      &
+                  pdu,pdv,pdt,pdq,pdpsrf,tracerdyn)
+ 
+      use radinc_h, only : L_NSPECTI,L_NSPECTV,naerkind
+      use watercommon_h, only : RLVTT, Psat_water,epsi
+      use gases_h, only: gnom, gfrac
+      use radcommon_h, only: sigma, eclipse, glat, grav
+      use radii_mod, only: h2o_reffrad, co2_reffrad, h2o_cloudrad
+      use aerosol_mod, only: iaero_co2, iaero_h2o
+      use surfdat_h, only: phisfi, albedodat, zmea, zstd, zsig, zgam, zthe, &
+                           dryness, watercaptag
+      use comdiurn_h, only: coslat, sinlat, coslon, sinlon
+      use comsaison_h, only: mu0, fract, dist_star, declin
+      use comsoil_h, only: nsoilmx, layer, mlayer, inertiedat
+      USE comgeomfi_h, only: long, lati, area, totarea, totarea_planet
+      USE tracer_h, only: noms, mmol, radius, rho_q, qext, &
+                          alpha_lift, alpha_devil, qextrhor, &
+                          igcm_h2o_ice, igcm_h2o_vap, igcm_dustbin, &
+                          igcm_co2_ice
+      use control_mod, only: ecritphy, iphysiq, nday
+      use phyredem, only: physdem0, physdem1
+      use slab_ice_h
+      use ocean_slab_mod, only :ocean_slab_init, ocean_slab_ice, &
+                                ocean_slab_get_vars,ocean_slab_final
+      use surf_heat_transp_mod,only :init_masquv
+      use planetwide_mod, only: planetwide_minval,planetwide_maxval,planetwide_sumval
+      use mod_phys_lmdz_para, only : is_master
+
+
+      implicit none
+
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Central subroutine for all the physics parameterisations in the
+!     universal model. Originally adapted from the Mars LMDZ model.
+!
+!     The model can be run without or with tracer transport
+!     depending on the value of "tracer" in file "callphys.def".
+!
+!
+!   It includes:
+!
+!      1.  Initialization:
+!      1.1 Firstcall initializations
+!      1.2 Initialization for every call to physiq
+!      1.2.5 Compute mean mass and cp, R and thermal conduction coeff.
+!      2. Compute radiative transfer tendencies
+!         (longwave and shortwave).
+!      4. Vertical diffusion (turbulent mixing):
+!      5. Convective adjustment
+!      6. Condensation and sublimation of gases (currently just CO2).
+!      7. TRACERS
+!       7a. water and water ice
+!       7c. other schemes for tracer transport (lifting, sedimentation)
+!       7d. updates (pressure variations, surface budget)
+!      9. Surface and sub-surface temperature calculations
+!     10. Write outputs :
+!           - "startfi", "histfi" if it's time
+!           - Saving statistics if "callstats = .true."
+!           - Output any needed variables in "diagfi" 
+!     10. Diagnostics: mass conservation of tracers, radiative energy balance etc.
+!
+!   arguments
+!   ---------
+!
+!   input
+!   -----
+!    ecri                  period (in dynamical timestep) to write output
+!    ngrid                 Size of the horizontal grid.
+!                          All internal loops are performed on that grid.
+!    nlayer                Number of vertical layers.
+!    nq                    Number of advected fields
+!    firstcall             True at the first call
+!    lastcall              True at the last call
+!    pday                  Number of days counted from the North. Spring
+!                          equinoxe.
+!    ptime                 Universal time (0<ptime<1): ptime=0.5 at 12:00 UT
+!    ptimestep             timestep (s)
+!    pplay(ngrid,nlayer)   Pressure at the middle of the layers (Pa)
+!    pplev(ngrid,nlayer+1) intermediate pressure levels (pa)
+!    pphi(ngrid,nlayer)    Geopotential at the middle of the layers (m2s-2)
+!    pu(ngrid,nlayer)      u component of the wind (ms-1)
+!    pv(ngrid,nlayer)      v component of the wind (ms-1)
+!    pt(ngrid,nlayer)      Temperature (K)
+!    pq(ngrid,nlayer,nq)   Advected fields
+!    pudyn(ngrid,nlayer)    \
+!    pvdyn(ngrid,nlayer)     \ Dynamical temporal derivative for the
+!    ptdyn(ngrid,nlayer)     / corresponding variables
+!    pqdyn(ngrid,nlayer,nq) /
+!    pw(ngrid,?)           vertical velocity
+!
+!   output
+!   ------
+!
+!    pdu(ngrid,nlayermx)        \
+!    pdv(ngrid,nlayermx)         \  Temporal derivative of the corresponding
+!    pdt(ngrid,nlayermx)         /  variables due to physical processes.
+!    pdq(ngrid,nlayermx)        /
+!    pdpsrf(ngrid)             /
+!    tracerdyn                 call tracer in dynamical part of GCM ?
+!
+!
+!     Authors
+!     -------
+!           Frederic Hourdin	15/10/93
+!           Francois Forget	1994
+!           Christophe Hourdin	02/1997 
+!           Subroutine completely rewritten by F. Forget (01/2000)
+!           Water ice clouds: Franck Montmessin (update 06/2003)
+!           Radiatively active tracers: J.-B. Madeleine (10/2008-06/2009)
+!           New correlated-k radiative scheme: R. Wordsworth (2009)
+!           Many specifically Martian subroutines removed: R. Wordsworth (2009)       
+!           Improved water cycle: R. Wordsworth / B. Charnay (2010)
+!           To F90: R. Wordsworth (2010)
+!           New turbulent diffusion scheme: J. Leconte (2012)
+!           Loops converted to F90 matrix format: J. Leconte (2012)
+!           No more ngridmx/nqmx, F90 commons and adaptation to parallel: A. Spiga (2012)
+!==================================================================
+
+
+!    0.  Declarations :
+!    ------------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "planete.h"
+!#include "control.h"
+#include "netcdf.inc"
+
+! Arguments :
+! -----------
+
+!   inputs:
+!   -------
+      integer,intent(in) :: ngrid ! number of atmospheric columns
+      integer,intent(in) :: nlayer ! number of atmospheric layers
+      integer,intent(in) :: nq ! number of tracers
+      character*20,intent(in) :: nametrac(nq) ! name of the tracer from dynamics
+      logical,intent(in) :: firstcall ! signals first call to physics
+      logical,intent(in) :: lastcall ! signals last call to physics
+      real,intent(in) :: pday ! number of elapsed sols since reference Ls=0
+      real,intent(in) :: ptime ! "universal time", given as fraction of sol (e.g.: 0.5 for noon)
+      real,intent(in) :: ptimestep ! physics timestep (s)
+      real,intent(in) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa)
+      real,intent(in) :: pplay(ngrid,nlayer) ! mid-layer pressure (Pa)
+      real,intent(in) :: pphi(ngrid,nlayer) ! geopotential at mid-layer (m2s-2)
+      real,intent(in) :: pu(ngrid,nlayer) ! zonal wind component (m/s)
+      real,intent(in) :: pv(ngrid,nlayer) ! meridional wind component (m/s)
+      real,intent(in) :: pt(ngrid,nlayer) ! temperature (K)
+      real,intent(in) :: pq(ngrid,nlayer,nq) ! tracers (.../kg_of_air)
+      real,intent(in) :: pw(ngrid,nlayer)    ! vertical velocity (m/s)
+
+
+
+!   outputs:
+!   --------
+!     physical tendencies
+      real,intent(out) :: pdu(ngrid,nlayer) ! zonal wind tendency (m/s/s)
+      real,intent(out) :: pdv(ngrid,nlayer) ! meridional wind tendency (m/s/s)
+      real,intent(out) :: pdt(ngrid,nlayer) ! temperature tendency (K/s)
+      real,intent(out) :: pdq(ngrid,nlayer,nq) ! tracer tendencies (../kg/s)
+      real,intent(out) :: pdpsrf(ngrid) ! surface pressure tendency (Pa/s)
+      logical,intent(out) :: tracerdyn ! signal to the dynamics to advect tracers or not
+
+! Local saved variables:
+! ----------------------
+!     aerosol (dust or ice) extinction optical depth  at reference wavelength 
+!     "longrefvis" set in dimradmars.h , for one of the "naerkind"  kind of
+!      aerosol optical properties:
+!      real aerosol(ngrid,nlayermx,naerkind) 
+!     this is now internal to callcorrk and hence no longer needed here
+
+      integer day_ini                ! Initial date of the run (sol since Ls=0) 
+      integer icount                 ! counter of calls to physiq during the run.
+      real, dimension(:),allocatable,save ::  tsurf  ! Surface temperature (K)
+      real, dimension(:,:),allocatable,save ::  tsoil  ! sub-surface temperatures (K)
+      real, dimension(:),allocatable,save :: albedo ! Surface albedo
+
+      real,dimension(:),allocatable,save :: albedo0 ! Surface albedo
+      real,dimension(:),allocatable,save :: rnat ! added by BC
+
+      real,dimension(:),allocatable,save :: emis ! Thermal IR surface emissivity
+      real,dimension(:,:),allocatable,save :: dtrad ! Net atm. radiative heating rate (K.s-1)
+      real,dimension(:),allocatable,save :: fluxrad_sky ! rad. flux from sky absorbed by surface (W.m-2)
+      real,dimension(:),allocatable,save :: fluxrad ! Net radiative surface flux (W.m-2)
+      real,dimension(:),allocatable,save :: capcal ! surface heat capacity (J m-2 K-1)
+      real,dimension(:),allocatable,save :: fluxgrd ! surface conduction flux (W.m-2)
+      real,dimension(:,:),allocatable,save :: qsurf ! tracer on surface (e.g. kg.m-2)
+      real,dimension(:,:),allocatable,save :: q2 ! Turbulent Kinetic Energy 
+
+      save day_ini, icount
+
+! Local variables :
+! -----------------
+
+!     aerosol (dust or ice) extinction optical depth  at reference wavelength 
+!     for the "naerkind" optically active aerosols:
+      real aerosol(ngrid,nlayermx,naerkind) 
+      real zh(ngrid,nlayermx)      ! potential temperature (K)
+
+      character*80 fichier 
+      integer l,ig,ierr,iq,iaer
+      
+      !!! this is saved for diagnostic
+      real,dimension(:),allocatable,save :: fluxsurf_lw ! incident LW (IR) surface flux (W.m-2)
+      real,dimension(:),allocatable,save :: fluxsurf_sw ! incident SW (stellar) surface flux (W.m-2)
+      real,dimension(:),allocatable,save :: fluxtop_lw ! Outgoing LW (IR) flux to space (W.m-2)
+      real,dimension(:),allocatable,save :: fluxabs_sw ! Absorbed SW (stellar) flux (W.m-2)
+      real,dimension(:),allocatable,save :: fluxtop_dn
+      real,dimension(:),allocatable,save :: fluxdyn ! horizontal heat transport by dynamics  
+      real,dimension(:,:),allocatable,save :: OLR_nu ! Outgoing LW radition in each band (Normalized to the band width (W/m2/cm-1)
+      real,dimension(:,:),allocatable,save :: OSR_nu ! Outgoing SW radition in each band (Normalized to the band width (W/m2/cm-1)
+      real,dimension(:,:),allocatable,save :: zdtlw ! (K/s)
+      real,dimension(:,:),allocatable,save :: zdtsw ! (K/s)
+      real,dimension(:),allocatable,save :: sensibFlux ! turbulent flux given by the atm to the surface
+
+      real zls                       ! solar longitude (rad)
+      real zday                      ! date (time since Ls=0, in martian days)
+      real zzlay(ngrid,nlayermx)   ! altitude at the middle of the layers
+      real zzlev(ngrid,nlayermx+1) ! altitude at layer boundaries
+      real latvl1,lonvl1             ! Viking Lander 1 point (for diagnostic)
+
+!     Tendencies due to various processes:
+      real dqsurf(ngrid,nq)
+      real cldtlw(ngrid,nlayermx)                           ! (K/s) LW heating rate for clear areas
+      real cldtsw(ngrid,nlayermx)                           ! (K/s) SW heating rate for clear areas
+      real zdtsurf(ngrid)                                   ! (K/s)
+      real dtlscale(ngrid,nlayermx)
+      real zdvdif(ngrid,nlayermx),zdudif(ngrid,nlayermx)  ! (m.s-2)
+      real zdhdif(ngrid,nlayermx), zdtsdif(ngrid)         ! (K/s)
+      real zdtdif(ngrid,nlayermx)			      ! (K/s)
+      real zdvadj(ngrid,nlayermx),zduadj(ngrid,nlayermx)  ! (m.s-2)
+      real zdhadj(ngrid,nlayermx)                           ! (K/s)
+      real zdtgw(ngrid,nlayermx)                            ! (K/s)
+      real zdtmr(ngrid,nlayermx)
+      real zdugw(ngrid,nlayermx),zdvgw(ngrid,nlayermx)    ! (m.s-2)
+      real zdtc(ngrid,nlayermx),zdtsurfc(ngrid)
+      real zdvc(ngrid,nlayermx),zduc(ngrid,nlayermx)
+      real zdumr(ngrid,nlayermx),zdvmr(ngrid,nlayermx)
+      real zdtsurfmr(ngrid)
+      
+      real zdmassmr(ngrid,nlayermx),zdpsrfmr(ngrid)
+      real zdmassmr_col(ngrid)
+
+      real zdqdif(ngrid,nlayermx,nq), zdqsdif(ngrid,nq)
+      real zdqevap(ngrid,nlayermx)
+      real zdqsed(ngrid,nlayermx,nq), zdqssed(ngrid,nq)
+      real zdqdev(ngrid,nlayermx,nq), zdqsdev(ngrid,nq)
+      real zdqadj(ngrid,nlayermx,nq)
+      real zdqc(ngrid,nlayermx,nq)
+      real zdqmr(ngrid,nlayermx,nq),zdqsurfmr(ngrid,nq)
+      real zdqlscale(ngrid,nlayermx,nq)
+      real zdqslscale(ngrid,nq)
+      real zdqchim(ngrid,nlayermx,nq)
+      real zdqschim(ngrid,nq)
+
+      real zdteuv(ngrid,nlayermx)    ! (K/s)
+      real zdtconduc(ngrid,nlayermx) ! (K/s)
+      real zdumolvis(ngrid,nlayermx)
+      real zdvmolvis(ngrid,nlayermx)
+      real zdqmoldiff(ngrid,nlayermx,nq)
+
+!     Local variables for local calculations:
+      real zflubid(ngrid)
+      real zplanck(ngrid),zpopsk(ngrid,nlayermx)
+      real zdum1(ngrid,nlayermx)
+      real zdum2(ngrid,nlayermx)
+      real ztim1,ztim2,ztim3, z1,z2
+      real ztime_fin
+      real zdh(ngrid,nlayermx)
+      real gmplanet
+      real taux(ngrid),tauy(ngrid)
+
+      integer length
+      parameter (length=100)
+
+! local variables only used for diagnostics (output in file "diagfi" or "stats")
+! ------------------------------------------------------------------------------
+      real ps(ngrid), zt(ngrid,nlayermx)
+      real zu(ngrid,nlayermx),zv(ngrid,nlayermx)
+      real zq(ngrid,nlayermx,nq)
+      character*2 str2
+      character*5 str5
+      real zdtadj(ngrid,nlayermx)
+      real zdtdyn(ngrid,nlayermx)
+      real,allocatable,dimension(:,:),save :: ztprevious
+      real reff(ngrid,nlayermx) ! effective dust radius (used if doubleq=T)
+      real qtot1,qtot2            ! total aerosol mass
+      integer igmin, lmin
+      logical tdiag
+
+      real zplev(ngrid,nlayermx+1),zplay(ngrid,nlayermx)
+      real zstress(ngrid), cd
+      real hco2(nq), tmean, zlocal(nlayermx)
+      real vmr(ngrid,nlayermx) ! volume mixing ratio
+
+      real time_phys
+
+!     reinstated by RW for diagnostic
+      real,allocatable,dimension(:),save :: tau_col
+      
+!     included by RW to reduce insanity of code
+      real ISR,ASR,OLR,GND,DYN,GSR,Ts1,Ts2,Ts3,TsS
+
+!     included by RW to compute tracer column densities
+      real qcol(ngrid,nq)
+
+!     included by RW for H2O precipitation
+      real zdtrain(ngrid,nlayermx)
+      real zdqrain(ngrid,nlayermx,nq)
+      real zdqsrain(ngrid)
+      real zdqssnow(ngrid)
+      real rainout(ngrid)
+
+!     included by RW for H2O Manabe scheme
+      real dtmoist(ngrid,nlayermx)
+      real dqmoist(ngrid,nlayermx,nq)
+
+      real qvap(ngrid,nlayermx)
+      real dqvaplscale(ngrid,nlayermx)
+      real dqcldlscale(ngrid,nlayermx)
+      real rneb_man(ngrid,nlayermx)
+      real rneb_lsc(ngrid,nlayermx)
+
+!     included by RW to account for surface cooling by evaporation
+      real dtsurfh2olat(ngrid)
+
+
+!     to test energy conservation (RW+JL)
+      real mass(ngrid,nlayermx),massarea(ngrid,nlayermx)
+      real dEtot, dEtots, AtmToSurf_TurbFlux
+      real,save :: dEtotSW, dEtotsSW, dEtotLW, dEtotsLW
+      real dEzRadsw(ngrid,nlayermx),dEzRadlw(ngrid,nlayermx),dEzdiff(ngrid,nlayermx)
+      real dEdiffs(ngrid),dEdiff(ngrid)
+      real madjdE(ngrid), lscaledE(ngrid),madjdEz(ngrid,nlayermx), lscaledEz(ngrid,nlayermx)
+!JL12 conservation test for mean flow kinetic energy has been disabled temporarily
+      real dtmoist_max,dtmoist_min
+      
+      real dItot, dItot_tmp, dVtot, dVtot_tmp
+
+!     included by BC for evaporation     
+      real qevap(ngrid,nlayermx,nq)
+      real tevap(ngrid,nlayermx)
+      real dqevap1(ngrid,nlayermx)
+      real dtevap1(ngrid,nlayermx)
+
+!     included by BC for hydrology
+      real,allocatable,save :: hice(:)
+
+!     included by RW to test water conservation (by routine)
+      real h2otot
+      real dWtot, dWtot_tmp, dWtots, dWtots_tmp
+      real h2o_surf_all
+      logical watertest
+      save watertest
+
+!     included by RW for RH diagnostic
+      real qsat(ngrid,nlayermx), RH(ngrid,nlayermx), H2Omaxcol(ngrid),psat_tmp
+
+!     included by RW for hydrology
+      real dqs_hyd(ngrid,nq)
+      real zdtsurf_hyd(ngrid)
+
+!     included by RW for water cycle conservation tests
+      real icesrf,liqsrf,icecol,vapcol
+
+!     included by BC for double radiative transfer call
+      logical clearsky
+      real zdtsw1(ngrid,nlayermx)
+      real zdtlw1(ngrid,nlayermx)
+      real fluxsurf_lw1(ngrid)     
+      real fluxsurf_sw1(ngrid)  
+      real fluxtop_lw1(ngrid)    
+      real fluxabs_sw1(ngrid)  
+      real tau_col1(ngrid)
+      real OLR_nu1(ngrid,L_NSPECTI)
+      real OSR_nu1(ngrid,L_NSPECTV)
+      real tf, ntf
+
+!     included by BC for cloud fraction computations
+      real,allocatable,dimension(:,:),save :: cloudfrac
+      real,allocatable,dimension(:),save :: totcloudfrac
+
+!     included by RW for vdifc water conservation test
+      real nconsMAX
+      real vdifcncons(ngrid)
+      real cadjncons(ngrid)
+
+!      double precision qsurf_hist(ngrid,nq)
+      real,allocatable,dimension(:,:),save :: qsurf_hist
+
+!     included by RW for temp convadj conservation test
+      real playtest(nlayermx)
+      real plevtest(nlayermx)
+      real ttest(nlayermx)
+      real qtest(nlayermx)
+      integer igtest
+
+!     included by RW for runway greenhouse 1D study
+      real muvar(ngrid,nlayermx+1)
+
+!     included by RW for variable H2O particle sizes
+      real,allocatable,dimension(:,:,:),save :: reffrad ! aerosol effective radius (m)
+      real,allocatable,dimension(:,:,:),save :: nueffrad ! aerosol effective radius variance
+!      real :: nueffrad_dummy(ngrid,nlayermx,naerkind) !! AS. This is temporary. Check below why.
+      real :: reffh2oliq(ngrid,nlayermx) ! liquid water particles effective radius (m)
+      real :: reffh2oice(ngrid,nlayermx) ! water ice particles effective radius (m)
+   !   real reffH2O(ngrid,nlayermx)
+      real reffcol(ngrid,naerkind)
+
+!     included by RW for sourceevol
+      real,allocatable,dimension(:),save :: ice_initial
+      real delta_ice,ice_tot
+      real,allocatable,dimension(:),save :: ice_min
+      
+      integer num_run
+      logical,save :: ice_update
+
+!     included by MS to compute the daily average of rings shadowing
+      integer, parameter :: nb_hours = 1536 ! set how many times per day are used
+      real :: pas
+      integer :: m
+      ! temporary variables computed at each step of this average 
+      real :: ptime_day ! Universal time in sol fraction 
+      real :: tmp_zls   ! solar longitude
+      real, dimension(:), allocatable :: tmp_fract ! day fraction of the time interval 
+      real, dimension(:), allocatable :: tmp_mu0 ! equivalent solar angle
+
+!     included by BC for slab ocean
+      real, dimension(:),allocatable,save ::  pctsrf_sic
+      real, dimension(:,:),allocatable,save :: tslab
+      real, dimension(:),allocatable,save ::  tsea_ice
+      real, dimension(:),allocatable,save :: sea_ice
+      real, dimension(:),allocatable,save :: zmasq
+      integer, dimension(:),allocatable,save ::knindex 
+
+      real :: tsurf2(ngrid)
+      real :: flux_o(ngrid),flux_g(ngrid),fluxgrdocean(ngrid)
+      real :: dt_ekman(ngrid,noceanmx),dt_hdiff(ngrid,noceanmx)
+      real :: flux_sens_lat(ngrid)
+      real :: qsurfint(ngrid,nq)
+
+
+!=======================================================================
+
+! 1. Initialisation
+! -----------------
+
+!  1.1   Initialisation only at first call
+!  ---------------------------------------
+      if (firstcall) then
+
+        !!! ALLOCATE SAVED ARRAYS
+        ALLOCATE(tsurf(ngrid))
+        ALLOCATE(tsoil(ngrid,nsoilmx))    
+        ALLOCATE(albedo(ngrid))          
+        ALLOCATE(albedo0(ngrid))          
+        ALLOCATE(rnat(ngrid))         
+        ALLOCATE(emis(ngrid))   
+        ALLOCATE(dtrad(ngrid,nlayermx))
+        ALLOCATE(fluxrad_sky(ngrid))
+        ALLOCATE(fluxrad(ngrid))    
+        ALLOCATE(capcal(ngrid))    
+        ALLOCATE(fluxgrd(ngrid))  
+        ALLOCATE(qsurf(ngrid,nq))  
+        ALLOCATE(q2(ngrid,nlayermx+1)) 
+        ALLOCATE(ztprevious(ngrid,nlayermx))
+        ALLOCATE(cloudfrac(ngrid,nlayermx))
+        ALLOCATE(totcloudfrac(ngrid))
+        ALLOCATE(hice(ngrid))
+        ALLOCATE(qsurf_hist(ngrid,nq))
+        ALLOCATE(reffrad(ngrid,nlayermx,naerkind))
+        ALLOCATE(nueffrad(ngrid,nlayermx,naerkind))
+        ALLOCATE(ice_initial(ngrid))
+        ALLOCATE(ice_min(ngrid)) 
+        ALLOCATE(fluxsurf_lw(ngrid))
+        ALLOCATE(fluxsurf_sw(ngrid))
+        ALLOCATE(fluxtop_lw(ngrid))
+        ALLOCATE(fluxabs_sw(ngrid))
+        ALLOCATE(fluxtop_dn(ngrid))
+        ALLOCATE(fluxdyn(ngrid))
+        ALLOCATE(OLR_nu(ngrid,L_NSPECTI))
+        ALLOCATE(OSR_nu(ngrid,L_NSPECTV))
+        ALLOCATE(sensibFlux(ngrid))
+        ALLOCATE(zdtlw(ngrid,nlayermx))
+        ALLOCATE(zdtsw(ngrid,nlayermx))
+        ALLOCATE(tau_col(ngrid))
+        ALLOCATE(pctsrf_sic(ngrid))
+        ALLOCATE(tslab(ngrid,noceanmx))
+        ALLOCATE(tsea_ice(ngrid))
+        ALLOCATE(sea_ice(ngrid))
+        ALLOCATE(zmasq(ngrid))
+        ALLOCATE(knindex(ngrid))
+!        ALLOCATE(qsurfint(ngrid,nqmx))
+
+
+        !! this is defined in comsaison_h
+        ALLOCATE(mu0(ngrid))
+        ALLOCATE(fract(ngrid))
+
+            
+         !! this is defined in radcommon_h
+         ALLOCATE(eclipse(ngrid))
+         ALLOCATE(glat(ngrid))
+
+!        variables set to 0
+!        ~~~~~~~~~~~~~~~~~~
+         dtrad(:,:) = 0.0
+         fluxrad(:) = 0.0
+         tau_col(:) = 0.0
+         zdtsw(:,:) = 0.0
+         zdtlw(:,:) = 0.0
+
+!        initialize aerosol indexes 
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+            call iniaerosol()
+
+      
+!        initialize tracer names, indexes and properties
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         tracerdyn=tracer
+         IF (.NOT.ALLOCATED(noms)) ALLOCATE(noms(nq)) !! because noms is an argument of physdem1
+                                                      !! whether or not tracer is on
+         if (tracer) then
+            call initracer(ngrid,nq,nametrac)
+         endif ! end tracer
+
+! 
+
+!        read startfi (initial parameters)
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         call phyetat0(ngrid,"startfi.nc",0,0,nsoilmx,nq,   &
+               day_ini,time_phys,tsurf,tsoil,emis,q2,qsurf,   &
+               cloudfrac,totcloudfrac,hice,  &
+               rnat,pctsrf_sic,tslab, tsea_ice,sea_ice)
+
+         if (pday.ne.day_ini) then
+           write(*,*) "ERROR in physiq.F90:"
+           write(*,*) "bad synchronization between physics and dynamics"
+           write(*,*) "dynamics day: ",pday
+           write(*,*) "physics day:  ",day_ini
+           stop
+         endif
+
+         write (*,*) 'In physiq day_ini =', day_ini
+
+!        Initialize albedo and orbital calculation
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         call surfini(ngrid,nq,qsurf,albedo0)
+         call iniorbit(apoastr,periastr,year_day,peri_day,obliquit)
+
+         albedo(:)=albedo0(:)
+
+         if(tlocked)then
+            print*,'Planet is tidally locked at resonance n=',nres
+            print*,'Make sure you have the right rotation rate!!!'
+         endif
+
+!        Initialize oceanic variables
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+         if (ok_slab_ocean)then
+
+           call ocean_slab_init(ngrid,ptimestep, tslab, &
+                sea_ice, pctsrf_sic)
+
+            knindex(:) = 0
+
+            do ig=1,ngrid
+              zmasq(ig)=1
+              knindex(ig) = ig
+              if (nint(rnat(ig)).eq.0) then
+                 zmasq(ig)=0
+              endif
+            enddo
+
+
+           CALL init_masquv(zmasq)
+
+
+         endif
+
+
+!        initialize soil 
+!        ~~~~~~~~~~~~~~~
+         if (callsoil) then
+            call soil(ngrid,nsoilmx,firstcall,lastcall,inertiedat, &
+                ptimestep,tsurf,tsoil,capcal,fluxgrd)
+
+            if (ok_slab_ocean) then
+               do ig=1,ngrid
+                  if (nint(rnat(ig)).eq.2) then
+                    capcal(ig)=capcalocean
+                    if (pctsrf_sic(ig).gt.0.5) then
+                      capcal(ig)=capcalseaice
+                      if (qsurf(ig,igcm_h2o_ice).gt.0.) then
+                        capcal(ig)=capcalsno
+                      endif
+                    endif
+                  endif
+               enddo
+            endif
+
+
+
+
+         else
+            print*,'WARNING! Thermal conduction in the soil turned off'
+            capcal(:)=1.e6
+            fluxgrd(:)=intheat
+            print*,'Flux from ground = ',intheat,' W m^-2'
+         endif
+         icount=1
+
+!        decide whether to update ice at end of run
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         ice_update=.false.
+         if(sourceevol)then
+            open(128,file='num_run',form='formatted', &
+                     status="old",iostat=ierr)
+            if (ierr.ne.0) then
+              write(*,*) "physiq: Error! No num_run file!"
+              write(*,*) " (which is needed for sourceevol option)"
+              stop
+            endif
+            read(128,*) num_run 
+            close(128)
+        
+            if(num_run.ne.0.and.mod(num_run,2).eq.0)then
+            !if(num_run.ne.0.and.mod(num_run,3).eq.0)then
+               print*,'Updating ice at end of this year!'
+               ice_update=.true.
+               ice_min(:)=1.e4
+            endif  
+         endif
+
+!  In newstart now, will have to be remove (BC 2014)
+!        define surface as continent or ocean
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         if (.not.ok_slab_ocean) then
+           rnat(:)=1.
+           do ig=1,ngrid
+!             if(iceball.or.oceanball.or.(inertiedat(ig,1).gt.1.E4))then
+             if(inertiedat(ig,1).gt.1.E4)then
+               rnat(ig)=0
+             endif
+           enddo
+
+           print*,'WARNING! Surface type currently decided by surface inertia'
+           print*,'This should be improved e.g. in newstart.F'
+         endif!(.not.ok_slab_ocean)
+
+!        initialise surface history variable 
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         qsurf_hist(:,:)=qsurf(:,:)
+
+!        initialise variable for dynamical heating diagnostic
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         ztprevious(:,:)=pt(:,:)
+
+!        Set temperature just above condensation temperature (for Early Mars)
+!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         if(nearco2cond) then
+            write(*,*)' WARNING! Starting at Tcond+1K'
+            do l=1, nlayer
+               do ig=1,ngrid
+                  pdt(ig,l)= ((-3167.8)/(log(.01*pplay(ig,l))-23.23)+4     &
+                      -pt(ig,l)) / ptimestep
+               enddo
+            enddo
+         endif
+
+         if(meanOLR)then
+            ! to record global radiative balance
+            call system('rm -f rad_bal.out')
+            ! to record global mean/max/min temperatures
+            call system('rm -f tem_bal.out')
+            ! to record global hydrological balance
+            call system('rm -f h2o_bal.out')
+         endif
+
+         watertest=.false.
+         if(water)then
+            ! initialise variables for water cycle
+
+            if(enertest)then
+               watertest = .true.
+            endif
+
+            if(ice_update)then
+               ice_initial(:)=qsurf(:,igcm_h2o_ice)
+            endif
+
+         endif
+         call su_watercycle ! even if we don't have a water cycle, we might
+                            ! need epsi for the wvp definitions in callcorrk.F
+
+         if (ngrid.ne.1) then ! no need to create a restart file in 1d
+           call physdem0("restartfi.nc",long,lati,nsoilmx,ngrid,nlayer,nq, &
+                         ptimestep,pday+nday,time_phys,area, &
+                         albedodat,inertiedat,zmea,zstd,zsig,zgam,zthe)
+         endif
+         
+      endif        !  (end of "if firstcall")
+
+! ---------------------------------------------------
+! 1.2   Initializations done at every physical timestep:
+! ---------------------------------------------------
+!     Initialize various variables
+!     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      
+      pdu(1:ngrid,1:nlayermx) = 0.0
+      pdv(1:ngrid,1:nlayermx) = 0.0
+      if ( .not.nearco2cond ) then
+         pdt(1:ngrid,1:nlayermx) = 0.0
+      endif
+      pdq(1:ngrid,1:nlayermx,1:nq) = 0.0
+      pdpsrf(1:ngrid)       = 0.0
+      zflubid(1:ngrid)      = 0.0
+      zdtsurf(1:ngrid)      = 0.0
+      dqsurf(1:ngrid,1:nq)= 0.0
+      flux_sens_lat(1:ngrid) = 0.0
+      taux(1:ngrid) = 0.0
+      tauy(1:ngrid) = 0.0
+
+
+
+
+      zday=pday+ptime ! compute time, in sols (and fraction thereof)
+
+!     Compute Stellar Longitude (Ls)
+!     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      if (season) then
+         call stellarlong(zday,zls)
+      else
+         call stellarlong(float(day_ini),zls)
+      end if
+
+
+
+!    Compute variations of g with latitude (oblate case)
+!
+        if (oblate .eqv. .false.) then
+           glat(:) = g
+        else if (flatten .eq. 0.0 .or. J2 .eq. 0.0 .or. Rmean .eq. 0.0 .or. MassPlanet .eq. 0.0) then
+        print*,'I need values for flatten, J2, Rmean and MassPlanet to compute glat (else set oblate=.false.)'
+
+        call abort
+        else
+
+        gmplanet = MassPlanet*grav*1e24
+        do ig=1,ngrid
+           glat(ig)= gmplanet/(Rmean**2) * (1.D0 + 0.75 *J2 - 2.0*flatten/3. + (2.*flatten - 15./4.* J2) * cos(2. * (pi/2. - lati(ig)))) 
+        end do
+        endif
+
+!!      write(*,*) 'lati, glat =',lati(1)*180./pi,glat(1), lati(ngrid/2)*180./pi, glat(ngrid/2)
+
+
+
+!     Compute geopotential between layers
+!     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      zzlay(1:ngrid,1:nlayermx)=pphi(1:ngrid,1:nlayermx)
+      do l=1,nlayermx         
+      zzlay(1:ngrid,l)= zzlay(1:ngrid,l)/glat(1:ngrid)
+      enddo
+
+      zzlev(1:ngrid,1)=0.
+      zzlev(1:ngrid,nlayer+1)=1.e7    ! dummy top of last layer above 10000 km...
+
+      do l=2,nlayer
+         do ig=1,ngrid
+            z1=(pplay(ig,l-1)+pplev(ig,l))/(pplay(ig,l-1)-pplev(ig,l))
+            z2=(pplev(ig,l)+pplay(ig,l))/(pplev(ig,l)-pplay(ig,l))
+            zzlev(ig,l)=(z1*zzlay(ig,l-1)+z2*zzlay(ig,l))/(z1+z2)
+         enddo
+      enddo
+!     Potential temperature calculation may not be the same in physiq and dynamic...
+
+!     Compute potential temperature
+!     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      do l=1,nlayer         
+         do ig=1,ngrid
+            zpopsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**rcp
+            zh(ig,l)=pt(ig,l)/zpopsk(ig,l)
+            mass(ig,l)  = (pplev(ig,l) - pplev(ig,l+1))/glat(ig)
+	    massarea(ig,l)=mass(ig,l)*area(ig)
+         enddo
+      enddo
+
+
+!-----------------------------------------------------------------------
+!    2. Compute radiative tendencies
+!-----------------------------------------------------------------------
+
+      if (callrad) then
+         if( mod(icount-1,iradia).eq.0.or.lastcall) then
+
+!          Compute local stellar zenith angles
+!          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           call orbite(zls,dist_star,declin)
+
+           if (tlocked) then
+              ztim1=SIN(declin)
+!              ztim2=COS(declin)*COS(2.*pi*(zday/year_day) - zls*nres)
+!              ztim3=-COS(declin)*SIN(2.*pi*(zday/year_day) - zls*nres)
+! JL12 corrects tidally resonant cases. nres=omega_rot/omega_orb
+              ztim2=COS(declin)*COS(2.*pi*(zday/year_day)*nres - zls)
+              ztim3=-COS(declin)*SIN(2.*pi*(zday/year_day)*nres - zls)
+
+              call stelang(ngrid,sinlon,coslon,sinlat,coslat,    &
+               ztim1,ztim2,ztim3,mu0,fract, flatten)
+
+           elseif (diurnal) then
+               ztim1=SIN(declin)
+               ztim2=COS(declin)*COS(2.*pi*(zday-.5))
+               ztim3=-COS(declin)*SIN(2.*pi*(zday-.5))
+
+               call stelang(ngrid,sinlon,coslon,sinlat,coslat,    &
+               ztim1,ztim2,ztim3,mu0,fract, flatten)
+           else if(diurnal .eqv. .false.) then
+
+               call mucorr(ngrid,declin,lati,mu0,fract,10000.,rad,flatten)
+               ! WARNING: this function appears not to work in 1D
+
+           endif 
+           
+           !! Eclipse incoming sunlight (e.g. Saturn ring shadowing)
+
+           if(rings_shadow) then 
+                write(*,*) 'Rings shadow activated'
+                if(diurnal .eqv. .false.) then ! we need to compute the daily average insolation 
+                    pas = 1./nb_hours
+                    ptime_day = 0.
+                    fract(:) = 0.
+                    ALLOCATE(tmp_fract(ngrid))
+                    ALLOCATE(tmp_mu0(ngrid))
+                    tmp_fract(:) = 0.
+                    eclipse(:) = 0.
+                    tmp_mu0(:) = 0.
+                    
+                    do m=1, nb_hours
+                        ptime_day = m*pas
+                        call stellarlong(pday+ptime_day,tmp_zls)
+                        call orbite(tmp_zls,dist_star,declin)
+                        ztim1=SIN(declin)
+                        ztim2=COS(declin)*COS(2.*pi*(pday+ptime_day-.5))
+                        ztim3=-COS(declin)*SIN(2.*pi*(pday+ptime_day-.5))
+                  
+                        call stelang(ngrid,sinlon,coslon,sinlat,coslat,    &
+                                 ztim1,ztim2,ztim3,tmp_mu0,tmp_fract, flatten)
+                  
+                        call rings(ngrid, declin, ptime_day, rad, flatten, eclipse)
+                  
+                        fract(:) = fract(:) + (1.-eclipse(:))*tmp_fract(:) !! fract prend en compte l'ombre des anneaux et l'alternance jour/nuit
+                    enddo
+                
+                    DEALLOCATE(tmp_fract)
+                    DEALLOCATE(tmp_mu0)
+            
+                    fract(:) = fract(:)/nb_hours
+                 
+                 else   
+                    call rings(ngrid, declin, ptime, rad, 0., eclipse)
+                    fract(:) = fract(:) * (1.-eclipse)
+                 endif
+            else
+                 eclipse(:) = 0.0
+            endif
+
+           if (corrk) then
+
+!          a) Call correlated-k radiative transfer scheme
+!          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+              if(kastprof)then
+                 print*,'kastprof should not = true here'
+                 call abort
+              endif
+	      if(water) then
+                  muvar(1:ngrid,1:nlayermx)=mugaz/(1.e0+(1.e0/epsi-1.e0)*pq(1:ngrid,1:nlayermx,igcm_h2o_vap)) 
+		  muvar(1:ngrid,nlayermx+1)=mugaz/(1.e0+(1.e0/epsi-1.e0)*pq(1:ngrid,nlayermx,igcm_h2o_vap)) 
+		  ! take into account water effect on mean molecular weight
+	      else
+                  muvar(1:ngrid,1:nlayermx+1)=mugaz
+	      endif 
+      
+!             standard callcorrk
+
+
+
+
+              if(ok_slab_ocean) then
+                tsurf2(:)=tsurf(:) 
+                do ig=1,ngrid
+                  if (nint(rnat(ig))==0) then
+                    tsurf(ig)=((1.-pctsrf_sic(ig))*tslab(ig,1)**4+pctsrf_sic(ig)*tsea_ice(ig)**4)**0.25
+                  endif
+                enddo
+              endif!(ok_slab_ocean)
+                
+
+                clearsky=.false.
+                call callcorrk(ngrid,nlayer,pq,nq,qsurf,                   &
+                      albedo,emis,mu0,pplev,pplay,pt,                    &
+                      tsurf,fract,dist_star,aerosol,muvar,               &
+                      zdtlw,zdtsw,fluxsurf_lw,fluxsurf_sw,fluxtop_lw,    &
+                      fluxabs_sw,fluxtop_dn,OLR_nu,OSR_nu,               &
+                      tau_col,cloudfrac,totcloudfrac,                    &
+                      clearsky,firstcall,lastcall)      
+
+!             Option to call scheme once more for clear regions
+                if(CLFvarying)then
+
+                 ! ---> PROBLEMS WITH ALLOCATED ARRAYS 
+                 ! (temporary solution in callcorrk: do not deallocate if CLFvarying ...)
+                   clearsky=.true.
+                   call callcorrk(ngrid,nlayer,pq,nq,qsurf,                  &
+                      albedo,emis,mu0,pplev,pplay,pt,                      &
+                      tsurf,fract,dist_star,aerosol,muvar,                 &
+                      zdtlw1,zdtsw1,fluxsurf_lw1,fluxsurf_sw1,fluxtop_lw1, &
+                      fluxabs_sw1,fluxtop_dn,OLR_nu1,OSR_nu1,              &
+                      tau_col1,cloudfrac,totcloudfrac,                     &
+                      clearsky,firstcall,lastcall)
+                   clearsky = .false.  ! just in case.     
+
+
+                 ! Sum the fluxes and heating rates from cloudy/clear cases
+                   do ig=1,ngrid
+                      tf=totcloudfrac(ig)
+                      ntf=1.-tf
+                    
+                    fluxsurf_lw(ig) = ntf*fluxsurf_lw1(ig) + tf*fluxsurf_lw(ig)
+                    fluxsurf_sw(ig) = ntf*fluxsurf_sw1(ig) + tf*fluxsurf_sw(ig)
+                    fluxtop_lw(ig)  = ntf*fluxtop_lw1(ig)  + tf*fluxtop_lw(ig)
+                    fluxabs_sw(ig)  = ntf*fluxabs_sw1(ig)  + tf*fluxabs_sw(ig)
+                    tau_col(ig)     = ntf*tau_col1(ig)     + tf*tau_col(ig)
+                    
+                    zdtlw(ig,1:nlayermx) = ntf*zdtlw1(ig,1:nlayermx) + tf*zdtlw(ig,1:nlayermx)
+                    zdtsw(ig,1:nlayermx) = ntf*zdtsw1(ig,1:nlayermx) + tf*zdtsw(ig,1:nlayermx)
+
+                    OSR_nu(ig,1:L_NSPECTV) = ntf*OSR_nu1(ig,1:L_NSPECTV) + tf*OSR_nu(ig,1:L_NSPECTV)		       
+                    OLR_nu(ig,1:L_NSPECTI) = ntf*OLR_nu1(ig,1:L_NSPECTI) + tf*OLR_nu(ig,1:L_NSPECTI)		       
+
+                 enddo
+
+              endif !CLFvarying
+
+              if(ok_slab_ocean) then
+                tsurf(:)=tsurf2(:)
+              endif!(ok_slab_ocean)
+
+
+!             Radiative flux from the sky absorbed by the surface (W.m-2)
+              GSR=0.0
+              fluxrad_sky(1:ngrid)=emis(1:ngrid)*fluxsurf_lw(1:ngrid)+fluxsurf_sw(1:ngrid)*(1.-albedo(1:ngrid))
+
+              !if(noradsurf)then ! no lower surface; SW flux just disappears
+              !   GSR = SUM(fluxsurf_sw(1:ngrid)*area(1:ngrid))/totarea
+              !   fluxrad_sky(1:ngrid)=emis(1:ngrid)*fluxsurf_lw(1:ngrid)
+              !   print*,'SW lost in deep atmosphere = ',GSR,' W m^-2'
+              !endif
+
+!             Net atmospheric radiative heating rate (K.s-1)
+              dtrad(1:ngrid,1:nlayermx)=zdtsw(1:ngrid,1:nlayermx)+zdtlw(1:ngrid,1:nlayermx)
+
+           elseif(newtonian)then
+
+!          b) Call Newtonian cooling scheme
+!          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+              call newtrelax(ngrid,mu0,sinlat,zpopsk,pt,pplay,pplev,dtrad,firstcall)
+
+              zdtsurf(1:ngrid) = +(pt(1:ngrid,1)-tsurf(1:ngrid))/ptimestep
+              ! e.g. surface becomes proxy for 1st atmospheric layer ?
+
+           else
+
+!          c) Atmosphere has no radiative effect
+!          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+              fluxtop_dn(1:ngrid)  = fract(1:ngrid)*mu0(1:ngrid)*Fat1AU/dist_star**2
+              if(ngrid.eq.1)then ! / by 4 globally in 1D case...
+                 fluxtop_dn(1)  = fract(1)*Fat1AU/dist_star**2/2.0
+              endif
+              fluxsurf_sw(1:ngrid) = fluxtop_dn(1:ngrid)
+              fluxrad_sky(1:ngrid) = fluxtop_dn(1:ngrid)*(1.-albedo(1:ngrid))
+              fluxtop_lw(1:ngrid)  = emis(1:ngrid)*sigma*tsurf(1:ngrid)**4
+              ! radiation skips the atmosphere entirely
+
+
+              dtrad(1:ngrid,1:nlayermx)=0.0
+              ! hence no atmospheric radiative heating
+
+           endif                ! if corrk
+
+        endif ! of if(mod(icount-1,iradia).eq.0)
+       
+
+!    Transformation of the radiative tendencies
+!    ------------------------------------------
+
+        zplanck(1:ngrid)=tsurf(1:ngrid)*tsurf(1:ngrid)
+        zplanck(1:ngrid)=emis(1:ngrid)*sigma*zplanck(1:ngrid)*zplanck(1:ngrid)
+        fluxrad(1:ngrid)=fluxrad_sky(1:ngrid)-zplanck(1:ngrid)
+        pdt(1:ngrid,1:nlayermx)=pdt(1:ngrid,1:nlayermx)+dtrad(1:ngrid,1:nlayermx)
+
+!-------------------------
+! test energy conservation
+         if(enertest)then
+	    call planetwide_sumval(cpp*massarea(:,:)*zdtsw(:,:)/totarea_planet,dEtotSW)
+	    call planetwide_sumval(cpp*massarea(:,:)*zdtlw(:,:)/totarea_planet,dEtotLW)
+	    call planetwide_sumval(fluxsurf_sw(:)*(1.-albedo(:))*area(:)/totarea_planet,dEtotsSW) !JL13 carefull, albedo can have changed since the last time we called corrk
+	    call planetwide_sumval((fluxsurf_lw(:)*emis(:)-zplanck(:))*area(:)/totarea_planet,dEtotsLW)
+	    dEzRadsw(:,:)=cpp*mass(:,:)*zdtsw(:,:)
+	    dEzRadlw(:,:)=cpp*mass(:,:)*zdtlw(:,:)
+	    if (is_master) then
+            	print*,'---------------------------------------------------------------'
+            	print*,'In corrk SW atmospheric heating       =',dEtotSW,' W m-2'
+            	print*,'In corrk LW atmospheric heating       =',dEtotLW,' W m-2'
+            	print*,'atmospheric net rad heating (SW+LW)   =',dEtotLW+dEtotSW,' W m-2'
+            	print*,'In corrk SW surface heating           =',dEtotsSW,' W m-2'
+            	print*,'In corrk LW surface heating           =',dEtotsLW,' W m-2'
+            	print*,'surface net rad heating (SW+LW)       =',dEtotsLW+dEtotsSW,' W m-2'
+	    endif
+         endif
+!-------------------------
+
+      endif ! of if (callrad)
+
+!-----------------------------------------------------------------------
+!    4. Vertical diffusion (turbulent mixing):
+!    -----------------------------------------
+
+      if (calldifv) then
+      
+         zflubid(1:ngrid)=fluxrad(1:ngrid)+fluxgrd(1:ngrid)
+
+         zdum1(1:ngrid,1:nlayermx)=0.0
+         zdum2(1:ngrid,1:nlayermx)=0.0
+
+
+!JL12 the following if test is temporarily there to allow us to compare the old vdifc with turbdiff	 
+	 if (UseTurbDiff) then
+	 
+           call turbdiff(ngrid,nlayer,nq,rnat,       &
+              ptimestep,capcal,lwrite,               &
+              pplay,pplev,zzlay,zzlev,z0,            &
+              pu,pv,pt,zpopsk,pq,tsurf,emis,qsurf,   &
+              zdum1,zdum2,pdt,pdq,zflubid,           &
+              zdudif,zdvdif,zdtdif,zdtsdif,          &
+	      sensibFlux,q2,zdqdif,zdqevap,zdqsdif,  &
+              taux,tauy,lastcall)
+
+	 else
+	 
+           zdh(1:ngrid,1:nlayermx)=pdt(1:ngrid,1:nlayermx)/zpopsk(1:ngrid,1:nlayermx)
+ 
+           call vdifc(ngrid,nlayer,nq,rnat,zpopsk,   &
+              ptimestep,capcal,lwrite,               &
+              pplay,pplev,zzlay,zzlev,z0,            &
+              pu,pv,zh,pq,tsurf,emis,qsurf,          &
+              zdum1,zdum2,zdh,pdq,zflubid,           &
+              zdudif,zdvdif,zdhdif,zdtsdif,          &
+	      sensibFlux,q2,zdqdif,zdqsdif,          &
+              taux,tauy,lastcall)
+
+           zdtdif(1:ngrid,1:nlayermx)=zdhdif(1:ngrid,1:nlayermx)*zpopsk(1:ngrid,1:nlayermx) ! for diagnostic only
+	   zdqevap(1:ngrid,1:nlayermx)=0.
+
+         end if !turbdiff
+
+         pdv(1:ngrid,1:nlayermx)=pdv(1:ngrid,1:nlayermx)+zdvdif(1:ngrid,1:nlayermx)
+         pdu(1:ngrid,1:nlayermx)=pdu(1:ngrid,1:nlayermx)+zdudif(1:ngrid,1:nlayermx)
+         pdt(1:ngrid,1:nlayermx)=pdt(1:ngrid,1:nlayermx)+zdtdif(1:ngrid,1:nlayermx)
+         zdtsurf(1:ngrid)=zdtsurf(1:ngrid)+zdtsdif(1:ngrid)
+
+         if(ok_slab_ocean)then
+            flux_sens_lat(1:ngrid)=(zdtsdif(1:ngrid)*capcal(1:ngrid)-fluxrad(1:ngrid))
+         endif
+
+
+
+         if (tracer) then 
+           pdq(1:ngrid,1:nlayermx,1:nq)=pdq(1:ngrid,1:nlayermx,1:nq)+ zdqdif(1:ngrid,1:nlayermx,1:nq)
+           dqsurf(1:ngrid,1:nq)=dqsurf(1:ngrid,1:nq) + zdqsdif(1:ngrid,1:nq)
+         end if ! of if (tracer)
+
+         !-------------------------
+         ! test energy conservation
+         if(enertest)then
+	    dEzdiff(:,:)=cpp*mass(:,:)*zdtdif(:,:)
+            do ig = 1, ngrid
+	       dEdiff(ig)=SUM(dEzdiff (ig,:))+ sensibFlux(ig)! subtract flux to the ground
+	       dEzdiff(ig,1)= dEzdiff(ig,1)+ sensibFlux(ig)! subtract flux to the ground
+            enddo
+	    call planetwide_sumval(dEdiff(:)*area(:)/totarea_planet,dEtot)
+	    dEdiffs(:)=capcal(:)*zdtsdif(:)-zflubid(:)-sensibFlux(:)
+	    call planetwide_sumval(dEdiffs(:)*area(:)/totarea_planet,dEtots)
+	    call planetwide_sumval(sensibFlux(:)*area(:)/totarea_planet,AtmToSurf_TurbFlux)
+	    if (is_master) then
+             if (UseTurbDiff) then
+	       	print*,'In TurbDiff sensible flux (atm=>surf) =',AtmToSurf_TurbFlux,' W m-2'
+               	print*,'In TurbDiff non-cons atm nrj change   =',dEtot,' W m-2'
+               	print*,'In TurbDiff (correc rad+latent heat) surf nrj change =',dEtots,' W m-2'
+	     else
+	       	print*,'In vdifc sensible flux (atm=>surf)    =',AtmToSurf_TurbFlux,' W m-2'
+               	print*,'In vdifc non-cons atm nrj change      =',dEtot,' W m-2'
+               	print*,'In vdifc (correc rad+latent heat) surf nrj change =',dEtots,' W m-2'
+	     end if
+	    endif ! of if (is_master)
+! JL12 note that the black body radiative flux emitted by the surface has been updated by the implicit scheme
+!    but not given back elsewhere
+         endif
+         !-------------------------
+
+         !-------------------------
+         ! test water conservation
+         if(watertest.and.water)then
+	    call planetwide_sumval(massarea(:,:)*zdqdif(:,:,igcm_h2o_vap)*ptimestep/totarea_planet,dWtot_tmp)
+	    call planetwide_sumval(zdqsdif(:,igcm_h2o_vap)*area(:)*ptimestep/totarea_planet,dWtots_tmp)
+            do ig = 1, ngrid
+	       vdifcncons(ig)=SUM(mass(ig,:)*zdqdif(ig,:,igcm_h2o_vap))
+	    Enddo
+	    call planetwide_sumval(massarea(:,:)*zdqdif(:,:,igcm_h2o_ice)*ptimestep/totarea_planet,dWtot)
+	    call planetwide_sumval(zdqsdif(:,igcm_h2o_ice)*area(:)*ptimestep/totarea_planet,dWtots)
+	    dWtot = dWtot + dWtot_tmp
+	    dWtots = dWtots + dWtots_tmp
+            do ig = 1, ngrid
+	       vdifcncons(ig)=vdifcncons(ig) + SUM(mass(ig,:)*zdqdif(ig,:,igcm_h2o_ice))
+	    Enddo	    
+	    call planetwide_maxval(vdifcncons(:),nconsMAX)
+
+	    if (is_master) then
+            	print*,'---------------------------------------------------------------'
+            	print*,'In difv atmospheric water change        =',dWtot,' kg m-2'
+            	print*,'In difv surface water change            =',dWtots,' kg m-2'
+            	print*,'In difv non-cons factor                 =',dWtot+dWtots,' kg m-2'
+            	print*,'In difv MAX non-cons factor             =',nconsMAX,' kg m-2 s-1'
+	    endif
+
+         endif
+         !-------------------------
+
+      else    
+
+         if(.not.newtonian)then
+
+            zdtsurf(1:ngrid) = zdtsurf(1:ngrid) + (fluxrad(1:ngrid) + fluxgrd(1:ngrid))/capcal(1:ngrid)
+
+         endif
+
+      endif ! of if (calldifv)
+
+
+!-----------------------------------------------------------------------
+!   5. Dry convective adjustment:
+!   -----------------------------
+
+      if(calladj) then
+
+         zdh(1:ngrid,1:nlayermx) = pdt(1:ngrid,1:nlayermx)/zpopsk(1:ngrid,1:nlayermx)
+         zduadj(1:ngrid,1:nlayermx)=0.0
+         zdvadj(1:ngrid,1:nlayermx)=0.0
+         zdhadj(1:ngrid,1:nlayermx)=0.0
+
+
+         call convadj(ngrid,nlayer,nq,ptimestep,    &
+              pplay,pplev,zpopsk,                   &
+              pu,pv,zh,pq,                          &
+              pdu,pdv,zdh,pdq,                      &
+              zduadj,zdvadj,zdhadj,                 &
+              zdqadj)
+
+         pdu(1:ngrid,1:nlayermx) = pdu(1:ngrid,1:nlayermx) + zduadj(1:ngrid,1:nlayermx)
+         pdv(1:ngrid,1:nlayermx) = pdv(1:ngrid,1:nlayermx) + zdvadj(1:ngrid,1:nlayermx)
+         pdt(1:ngrid,1:nlayermx)    = pdt(1:ngrid,1:nlayermx) + zdhadj(1:ngrid,1:nlayermx)*zpopsk(1:ngrid,1:nlayermx)
+         zdtadj(1:ngrid,1:nlayermx) = zdhadj(1:ngrid,1:nlayermx)*zpopsk(1:ngrid,1:nlayermx) ! for diagnostic only
+
+         if(tracer) then 
+            pdq(1:ngrid,1:nlayermx,1:nq) = pdq(1:ngrid,1:nlayermx,1:nq) + zdqadj(1:ngrid,1:nlayermx,1:nq) 
+         end if
+
+         !-------------------------
+         ! test energy conservation
+         if(enertest)then
+	    call planetwide_sumval(cpp*massarea(:,:)*zdtadj(:,:)/totarea_planet,dEtot)
+            if (is_master) print*,'In convadj atmospheric energy change  =',dEtot,' W m-2'
+         endif
+         !-------------------------
+
+         !-------------------------
+         ! test water conservation
+         if(watertest)then
+	    call planetwide_sumval(massarea(:,:)*zdqadj(:,:,igcm_h2o_vap)*ptimestep/totarea_planet,dWtot_tmp)
+            do ig = 1, ngrid
+	       cadjncons(ig)=SUM(mass(ig,:)*zdqadj(ig,:,igcm_h2o_vap))
+	    Enddo
+	    call planetwide_sumval(massarea(:,:)*zdqadj(:,:,igcm_h2o_ice)*ptimestep/totarea_planet,dWtot)
+	    dWtot = dWtot + dWtot_tmp
+            do ig = 1, ngrid
+	       cadjncons(ig)=cadjncons(ig) + SUM(mass(ig,:)*zdqadj(ig,:,igcm_h2o_ice))
+	    Enddo	    
+	    call planetwide_maxval(cadjncons(:),nconsMAX)
+
+            if (is_master) then
+	    	print*,'In convadj atmospheric water change     =',dWtot,' kg m-2'
+            	print*,'In convadj MAX non-cons factor          =',nconsMAX,' kg m-2 s-1'
+	    endif
+         endif
+         !-------------------------
+         
+      endif ! of if(calladj)
+
+!-----------------------------------------------------------------------
+!   6. Carbon dioxide condensation-sublimation:
+!   -------------------------------------------
+
+      if (co2cond) then
+         if (.not.tracer) then
+            print*,'We need a CO2 ice tracer to condense CO2'
+            call abort
+         endif
+         call condense_cloud(ngrid,nlayer,nq,ptimestep,   &
+              capcal,pplay,pplev,tsurf,pt,                  &
+              pphi,pdt,pdu,pdv,zdtsurf,pu,pv,pq,pdq,        &
+              qsurf(1,igcm_co2_ice),albedo,emis,            &
+              zdtc,zdtsurfc,pdpsrf,zduc,zdvc,               &
+              zdqc)
+
+         pdt(1:ngrid,1:nlayermx)=pdt(1:ngrid,1:nlayermx)+zdtc(1:ngrid,1:nlayermx)
+         pdv(1:ngrid,1:nlayermx)=pdv(1:ngrid,1:nlayermx)+zdvc(1:ngrid,1:nlayermx)
+         pdu(1:ngrid,1:nlayermx)=pdu(1:ngrid,1:nlayermx)+zduc(1:ngrid,1:nlayermx)
+         zdtsurf(1:ngrid) = zdtsurf(1:ngrid) + zdtsurfc(1:ngrid)
+
+         pdq(1:ngrid,1:nlayermx,1:nq)=pdq(1:ngrid,1:nlayermx,1:nq)+ zdqc(1:ngrid,1:nlayermx,1:nq) 
+         ! Note: we do not add surface co2ice tendency
+         ! because qsurf(:,igcm_co2_ice) is updated in condens_co2cloud
+
+         !-------------------------
+         ! test energy conservation
+         if(enertest)then
+	    call planetwide_sumval(cpp*massarea(:,:)*zdtc(:,:)/totarea_planet,dEtot)
+	    call planetwide_sumval(capcal(:)*zdtsurfc(:)*area(:)/totarea_planet,dEtots)
+	    if (is_master) then
+	    	print*,'In co2cloud atmospheric energy change   =',dEtot,' W m-2'
+            	print*,'In co2cloud surface energy change       =',dEtots,' W m-2'
+	    endif
+         endif
+         !-------------------------
+
+      endif  ! of if (co2cond)
+
+
+!-----------------------------------------------------------------------
+!   7. Specific parameterizations for tracers 
+!   -----------------------------------------
+
+      if (tracer) then 
+
+!   7a. Water and ice
+!     ---------------
+         if (water) then
+
+!        ----------------------------------------
+!        Water ice condensation in the atmosphere
+!        ----------------------------------------
+            if(watercond.and.(RLVTT.gt.1.e-8))then
+
+!             ----------------
+!             Moist convection
+!             ----------------
+
+	       dqmoist(1:ngrid,1:nlayermx,1:nq)=0.
+	       dtmoist(1:ngrid,1:nlayermx)=0.
+
+	       call moistadj(ngrid,nq,pt,pq,pdq,pplev,pplay,dtmoist,dqmoist,ptimestep,rneb_man)
+
+               pdq(1:ngrid,1:nlayermx,igcm_h2o_vap) = pdq(1:ngrid,1:nlayermx,igcm_h2o_vap)   &
+	                  +dqmoist(1:ngrid,1:nlayermx,igcm_h2o_vap)
+               pdq(1:ngrid,1:nlayermx,igcm_h2o_ice) =pdq(1:ngrid,1:nlayermx,igcm_h2o_ice)     &
+                          +dqmoist(1:ngrid,1:nlayermx,igcm_h2o_ice)
+               pdt(1:ngrid,1:nlayermx) = pdt(1:ngrid,1:nlayermx)+dtmoist(1:ngrid,1:nlayermx)
+
+               !-------------------------
+               ! test energy conservation
+               if(enertest)then
+		  call planetwide_sumval(cpp*massarea(:,:)*dtmoist(:,:)/totarea_planet,dEtot)
+		  call planetwide_maxval(dtmoist(:,:),dtmoist_max)
+		  call planetwide_minval(dtmoist(:,:),dtmoist_min)
+		  madjdEz(:,:)=cpp*mass(:,:)*dtmoist(:,:)
+                  do ig=1,ngrid
+                     madjdE(ig) = cpp*SUM(mass(:,:)*dtmoist(:,:))
+                  enddo
+		  if (is_master) then
+                  	print*,'In moistadj atmospheric energy change   =',dEtot,' W m-2'
+                  	print*,'In moistadj MAX atmospheric energy change   =',dtmoist_max*ptimestep,'K/step'
+                  	print*,'In moistadj MIN atmospheric energy change   =',dtmoist_min*ptimestep,'K/step'
+		  endif
+		  
+		! test energy conservation
+		  call planetwide_sumval(massarea(:,:)*dqmoist(:,:,igcm_h2o_vap)*ptimestep/totarea_planet+	&
+		  	massarea(:,:)*dqmoist(:,:,igcm_h2o_ice)*ptimestep/totarea_planet,dWtot)
+		  if (is_master) print*,'In moistadj atmospheric water change    =',dWtot,' kg m-2'
+               endif
+               !-------------------------
+	       
+
+!        --------------------------------
+!        Large scale condensation/evaporation
+!        --------------------------------
+               call largescale(ngrid,nq,ptimestep,pplev,pplay,pt,pq,pdt,pdq,dtlscale,dqvaplscale,dqcldlscale,rneb_lsc)
+
+               pdt(1:ngrid,1:nlayermx) = pdt(1:ngrid,1:nlayermx)+dtlscale(1:ngrid,1:nlayermx)
+               pdq(1:ngrid,1:nlayermx,igcm_h2o_vap) = pdq(1:ngrid,1:nlayermx,igcm_h2o_vap)+dqvaplscale(1:ngrid,1:nlayermx)
+               pdq(1:ngrid,1:nlayermx,igcm_h2o_ice) = pdq(1:ngrid,1:nlayermx,igcm_h2o_ice)+dqcldlscale(1:ngrid,1:nlayermx)
+
+               !-------------------------
+               ! test energy conservation
+               if(enertest)then
+                  lscaledEz(:,:) = cpp*mass(:,:)*dtlscale(:,:)
+                  do ig=1,ngrid
+                     lscaledE(ig) = cpp*SUM(mass(:,:)*dtlscale(:,:))
+                  enddo
+		  call planetwide_sumval(cpp*massarea(:,:)*dtlscale(:,:)/totarea_planet,dEtot)
+!		  if(isnan(dEtot)) then ! NB: isnan() is not a standard function...
+!		     print*,'Nan in largescale, abort'
+!                     STOP
+!		  endif
+		  if (is_master) print*,'In largescale atmospheric energy change =',dEtot,' W m-2'
+
+               ! test water conservation
+		  call planetwide_sumval(massarea(:,:)*dqvaplscale(:,:)*ptimestep/totarea_planet+	&
+		  	SUM(massarea(:,:)*dqcldlscale(:,:))*ptimestep/totarea_planet,dWtot)
+		  if (is_master) print*,'In largescale atmospheric water change  =',dWtot,' kg m-2'
+               endif
+               !-------------------------
+
+               ! compute cloud fraction
+               do l = 1, nlayer
+                  do ig=1,ngrid
+                     cloudfrac(ig,l)=MAX(rneb_lsc(ig,l),rneb_man(ig,l)) 
+                  enddo
+               enddo
+
+            endif                ! of if (watercondense)
+           
+
+!        --------------------------------
+!        Water ice / liquid precipitation
+!        --------------------------------
+            if(waterrain)then
+
+               zdqrain(1:ngrid,1:nlayermx,1:nq) = 0.0
+               zdqsrain(1:ngrid)    = 0.0
+               zdqssnow(1:ngrid)    = 0.0
+
+               call rain(ngrid,nq,ptimestep,pplev,pplay,pt,pdt,pq,pdq,            &
+                   zdtrain,zdqrain,zdqsrain,zdqssnow,cloudfrac)
+
+               pdq(1:ngrid,1:nlayermx,igcm_h2o_vap) = pdq(1:ngrid,1:nlayermx,igcm_h2o_vap) &
+	             +zdqrain(1:ngrid,1:nlayermx,igcm_h2o_vap)
+               pdq(1:ngrid,1:nlayermx,igcm_h2o_ice) = pdq(1:ngrid,1:nlayermx,igcm_h2o_ice) &
+	             +zdqrain(1:ngrid,1:nlayermx,igcm_h2o_ice)
+               pdt(1:ngrid,1:nlayermx) = pdt(1:ngrid,1:nlayermx)+zdtrain(1:ngrid,1:nlayermx)
+               dqsurf(1:ngrid,igcm_h2o_vap) = dqsurf(1:ngrid,igcm_h2o_vap)+zdqsrain(1:ngrid) ! a bug was here
+               dqsurf(1:ngrid,igcm_h2o_ice) = dqsurf(1:ngrid,igcm_h2o_ice)+zdqssnow(1:ngrid)
+               rainout(1:ngrid)             = zdqsrain(1:ngrid)+zdqssnow(1:ngrid) ! diagnostic   
+
+               !-------------------------
+               ! test energy conservation
+               if(enertest)then
+		  call planetwide_sumval(cpp*massarea(:,:)*zdtrain(:,:)/totarea_planet,dEtot)
+		  if (is_master) print*,'In rain atmospheric T energy change       =',dEtot,' W m-2'
+		  call planetwide_sumval(massarea(:,:)*zdqrain(:,:,igcm_h2o_ice)/totarea_planet*RLVTT/cpp,dItot_tmp)
+		  call planetwide_sumval(area(:)*zdqssnow(:)/totarea_planet*RLVTT/cpp,dItot)
+		  dItot = dItot + dItot_tmp
+		  call planetwide_sumval(massarea(:,:)*zdqrain(:,:,igcm_h2o_vap)*ptimestep/totarea_planet,dVtot_tmp)
+		  call planetwide_sumval(area(:)*zdqsrain(:)/totarea_planet*RLVTT/cpp,dVtot)
+		  dVtot = dVtot + dVtot_tmp
+		  dEtot = dItot + dVtot
+		  if (is_master) then
+                  	print*,'In rain dItot =',dItot,' W m-2'
+                  	print*,'In rain dVtot =',dVtot,' W m-2'
+                  	print*,'In rain atmospheric L energy change       =',dEtot,' W m-2'
+		  endif
+
+               ! test water conservation
+		  call planetwide_sumval(massarea(:,:)*zdqrain(:,:,igcm_h2o_vap)*ptimestep/totarea_planet+	&
+		  	massarea(:,:)*zdqrain(:,:,igcm_h2o_ice)*ptimestep/totarea_planet,dWtot)
+		  call planetwide_sumval((zdqsrain(:)+zdqssnow(:))*area(:)*ptimestep/totarea_planet,dWtots)
+		  if (is_master) then
+                  	print*,'In rain atmospheric water change        =',dWtot,' kg m-2'
+                  	print*,'In rain surface water change            =',dWtots,' kg m-2'
+                  	print*,'In rain non-cons factor                 =',dWtot+dWtots,' kg m-2'
+		  endif
+              endif
+              !-------------------------
+
+            end if                 ! of if (waterrain)
+         end if                    ! of if (water)
+
+
+!   7c. Aerosol particles
+!     -------------------
+!        ------------- 
+!        Sedimentation
+!        ------------- 
+        if (sedimentation) then 
+           zdqsed(1:ngrid,1:nlayermx,1:nq) = 0.0
+           zdqssed(1:ngrid,1:nq)  = 0.0
+
+
+           !-------------------------
+           ! find qtot
+           if(watertest)then
+              iq=igcm_h2o_ice
+	      call planetwide_sumval(massarea(:,:)*pq(:,:,iq)*ptimestep/totarea_planet,dWtot)
+	      call planetwide_sumval(massarea(:,:)*pdq(:,:,iq)*ptimestep/totarea_planet,dWtots)
+	      if (is_master) then
+	      	print*,'Before sedim pq  =',dWtot,' kg m-2'
+              	print*,'Before sedim pdq =',dWtots,' kg m-2'
+	      endif
+           endif
+           !-------------------------
+
+           call callsedim(ngrid,nlayer,ptimestep,           &
+                pplev,zzlev,pt,pdt,pq,pdq,zdqsed,zdqssed,nq)
+
+           !-------------------------
+           ! find qtot
+           if(watertest)then
+              iq=igcm_h2o_ice
+	      call planetwide_sumval(massarea(:,:)*pq(:,:,iq)*ptimestep/totarea_planet,dWtot)
+	      call planetwide_sumval(massarea(:,:)*pdq(:,:,iq)*ptimestep/totarea_planet,dWtots)
+	      if (is_master) then
+              	print*,'After sedim pq  =',dWtot,' kg m-2'
+              	print*,'After sedim pdq =',dWtots,' kg m-2'
+  	      endif
+           endif
+           !-------------------------
+
+           ! for now, we only allow H2O ice to sediment
+              ! and as in rain.F90, whether it falls as rain or snow depends
+              ! only on the surface temperature
+           pdq(1:ngrid,1:nlayermx,1:nq) = pdq(1:ngrid,1:nlayermx,1:nq) + zdqsed(1:ngrid,1:nlayermx,1:nq)
+           dqsurf(1:ngrid,1:nq) = dqsurf(1:ngrid,1:nq) + zdqssed(1:ngrid,1:nq)
+
+           !-------------------------
+           ! test water conservation
+           if(watertest)then
+	      call planetwide_sumval(massarea(:,:)*(zdqsed(:,:,igcm_h2o_vap)+zdqsed(:,:,igcm_h2o_ice))*ptimestep/totarea_planet,dWtot)
+	      call planetwide_sumval((zdqssed(:,igcm_h2o_vap)+zdqssed(:,igcm_h2o_ice))*area(:)*ptimestep/totarea_planet,dWtots)
+	      if (is_master) then
+              	print*,'In sedim atmospheric ice change         =',dWtot,' kg m-2'
+              	print*,'In sedim surface ice change             =',dWtots,' kg m-2'
+              	print*,'In sedim non-cons factor                =',dWtot+dWtots,' kg m-2'
+	      endif
+           endif
+           !-------------------------
+
+        end if   ! of if (sedimentation)
+
+
+!   7d. Updates
+!     ---------
+
+!       -----------------------------------
+!       Updating atm mass and tracer budget
+!       -----------------------------------
+
+         if(mass_redistrib) then
+
+            zdmassmr(1:ngrid,1:nlayermx) = mass(1:ngrid,1:nlayermx) * &
+	       (   zdqevap(1:ngrid,1:nlayermx)                          &
+	         + zdqrain(1:ngrid,1:nlayermx,igcm_h2o_vap)             &
+		 + dqmoist(1:ngrid,1:nlayermx,igcm_h2o_vap)             &
+		 + dqvaplscale(1:ngrid,1:nlayermx) )
+
+            do ig = 1, ngrid
+	       zdmassmr_col(ig)=SUM(zdmassmr(ig,1:nlayermx))
+            enddo
+            
+	    call writediagfi(ngrid,"mass_evap","mass gain"," ",3,zdmassmr)
+	    call writediagfi(ngrid,"mass_evap_col","mass gain col"," ",2,zdmassmr_col)
+	    call writediagfi(ngrid,"mass","mass"," ",3,mass)
+
+	    call mass_redistribution(ngrid,nlayer,nq,ptimestep,   &
+                       rnat,capcal,pplay,pplev,pt,tsurf,pq,qsurf,     &
+		       pu,pv,pdt,zdtsurf,pdq,pdu,pdv,zdmassmr,  &
+		       zdtmr,zdtsurfmr,zdpsrfmr,zdumr,zdvmr,zdqmr,zdqsurfmr)
+	 
+
+            pdq(1:ngrid,1:nlayermx,1:nq) = pdq(1:ngrid,1:nlayermx,1:nq) + zdqmr(1:ngrid,1:nlayermx,1:nq)
+            dqsurf(1:ngrid,1:nq)         = dqsurf(1:ngrid,1:nq) + zdqsurfmr(1:ngrid,1:nq)
+            pdt(1:ngrid,1:nlayermx)        = pdt(1:ngrid,1:nlayermx) + zdtmr(1:ngrid,1:nlayermx)
+            pdu(1:ngrid,1:nlayermx)        = pdu(1:ngrid,1:nlayermx) + zdumr(1:ngrid,1:nlayermx)
+            pdv(1:ngrid,1:nlayermx)        = pdv(1:ngrid,1:nlayermx) + zdvmr(1:ngrid,1:nlayermx)
+	    pdpsrf(1:ngrid)                = pdpsrf(1:ngrid) + zdpsrfmr(1:ngrid)
+            zdtsurf(1:ngrid)               = zdtsurf(1:ngrid) + zdtsurfmr(1:ngrid)
+	    
+!	    print*,'after mass redistrib, q=',pq(211,1:nlayermx,igcm_h2o_vap)+ptimestep*pdq(211,1:nlayermx,igcm_h2o_vap) 
+	 endif
+
+
+!   7e. Ocean
+!     ---------
+
+!       ---------------------------------
+!       Slab_ocean
+!       ---------------------------------
+      if (ok_slab_ocean)then
+
+         do ig=1,ngrid
+            qsurfint(:,igcm_h2o_ice)=qsurf(:,igcm_h2o_ice)
+         enddo
+
+         call ocean_slab_ice(ptimestep, &
+               ngrid, knindex, tsea_ice, fluxrad, &
+               zdqssnow, qsurf(:,igcm_h2o_ice), &
+               -zdqsdif(:,igcm_h2o_vap), &
+               flux_sens_lat,tsea_ice, pctsrf_sic, &
+               taux,tauy,icount)
+
+
+         call ocean_slab_get_vars(ngrid,tslab, &
+               sea_ice, flux_o, &
+               flux_g, dt_hdiff, &
+               dt_ekman)
+
+            do ig=1,ngrid
+               if (nint(rnat(ig)).eq.1)then
+               tslab(ig,1) = 0.
+               tslab(ig,2) = 0.
+               tsea_ice(ig) = 0.
+               sea_ice(ig) = 0.
+               pctsrf_sic(ig) = 0.
+               qsurf(ig,igcm_h2o_ice)=qsurfint(ig,igcm_h2o_ice)
+               endif
+            enddo
+
+
+      endif! (ok_slab_ocean)
+
+!       ---------------------------------
+!       Updating tracer budget on surface
+!       ---------------------------------
+
+         if(hydrology)then
+            
+            call hydrol(ngrid,nq,ptimestep,rnat,tsurf,qsurf,dqsurf,dqs_hyd,    &
+               capcal,albedo0,albedo,mu0,zdtsurf,zdtsurf_hyd,hice,pctsrf_sic,  &
+               sea_ice)
+            ! note: for now, also changes albedo in the subroutine
+
+            zdtsurf(1:ngrid) = zdtsurf(1:ngrid) + zdtsurf_hyd(1:ngrid)
+            qsurf(1:ngrid,1:nq) = qsurf(1:ngrid,1:nq) + ptimestep*dqs_hyd(1:ngrid,1:nq)
+            ! when hydrology is used, other dqsurf tendencies are all added to dqs_hyd inside
+
+            !-------------------------
+            ! test energy conservation
+            if(enertest)then
+	       call planetwide_sumval(area(:)*capcal(:)*zdtsurf_hyd(:)/totarea_planet,dEtots)
+	       if (is_master) print*,'In hydrol surface energy change     =',dEtots,' W m-2'
+            endif
+            !-------------------------
+
+            !-------------------------
+            ! test water conservation
+            if(watertest)then
+	       call planetwide_sumval(dqs_hyd(:,igcm_h2o_ice)*area(:)*ptimestep/totarea_planet,dWtots)
+	       if (is_master) print*,'In hydrol surface ice change            =',dWtots,' kg m-2'
+	       call planetwide_sumval(dqs_hyd(:,igcm_h2o_vap)*area(:)*ptimestep/totarea_planet,dWtots)
+	       if (is_master) then
+               	print*,'In hydrol surface water change          =',dWtots,' kg m-2'
+               	print*,'---------------------------------------------------------------'
+	       endif
+            endif
+            !-------------------------
+
+         ELSE     ! of if (hydrology)
+
+            qsurf(1:ngrid,1:nq)=qsurf(1:ngrid,1:nq)+ptimestep*dqsurf(1:ngrid,1:nq)
+
+         END IF   ! of if (hydrology)
+
+         ! Add qsurf to qsurf_hist, which is what we save in
+         ! diagfi.nc etc. At the same time, we set the water 
+         ! content of ocean gridpoints back to zero, in order
+         ! to avoid rounding errors in vdifc, rain
+         qsurf_hist(:,:) = qsurf(:,:)
+
+         if(ice_update)then
+            ice_min(1:ngrid)=min(ice_min(1:ngrid),qsurf(1:ngrid,igcm_h2o_ice))
+         endif
+
+      endif   !  of if (tracer) 
+
+!-----------------------------------------------------------------------
+!   9. Surface and sub-surface soil temperature
+!-----------------------------------------------------------------------
+
+!     Increment surface temperature
+
+      if(ok_slab_ocean)then
+         do ig=1,ngrid
+           if (nint(rnat(ig)).eq.0)then
+             zdtsurf(ig)= (tslab(ig,1)              &
+             + pctsrf_sic(ig)*(tsea_ice(ig)-tslab(ig,1))-tsurf(ig))/ptimestep
+           endif
+           tsurf(ig)=tsurf(ig)+ptimestep*zdtsurf(ig)
+         enddo
+   
+      else
+        tsurf(1:ngrid)=tsurf(1:ngrid)+ptimestep*zdtsurf(1:ngrid) 
+      endif!(ok_slab_ocean)
+
+!     Compute soil temperatures and subsurface heat flux
+      if (callsoil) then
+         call soil(ngrid,nsoilmx,.false.,lastcall,inertiedat,   &
+                ptimestep,tsurf,tsoil,capcal,fluxgrd)     
+      endif
+
+
+      if (ok_slab_ocean) then
+            do ig=1,ngrid
+               fluxgrdocean(ig)=fluxgrd(ig)
+               if (nint(rnat(ig)).eq.0) then
+               capcal(ig)=capcalocean
+               fluxgrd(ig)=0.
+               fluxgrdocean(ig)=pctsrf_sic(ig)*flux_g(ig)+(1-pctsrf_sic(ig))*(dt_hdiff(ig,1)+dt_ekman(ig,1))
+                 do iq=1,nsoilmx
+                    tsoil(ig,iq)=tsurf(ig)
+                 enddo
+                 if (pctsrf_sic(ig).gt.0.5) then
+                   capcal(ig)=capcalseaice
+                   if (qsurf(ig,igcm_h2o_ice).gt.0.) then
+                   capcal(ig)=capcalsno
+                   endif
+                 endif
+               endif
+            enddo
+      endif !(ok_slab_ocean)
+
+!-------------------------
+! test energy conservation
+      if(enertest)then
+	 call planetwide_sumval(area(:)*capcal(:)*zdtsurf(:)/totarea_planet,dEtots)	 
+	 if (is_master) print*,'Surface energy change                 =',dEtots,' W m-2'
+      endif
+!-------------------------
+
+!-----------------------------------------------------------------------
+!  10. Perform diagnostics and write output files
+!-----------------------------------------------------------------------
+
+!    -------------------------------
+!    Dynamical fields incrementation
+!    -------------------------------
+!    For output only: the actual model integration is performed in the dynamics
+ 
+      ! temperature, zonal and meridional wind
+      zt(1:ngrid,1:nlayermx) = pt(1:ngrid,1:nlayermx) + pdt(1:ngrid,1:nlayermx)*ptimestep
+      zu(1:ngrid,1:nlayermx) = pu(1:ngrid,1:nlayermx) + pdu(1:ngrid,1:nlayermx)*ptimestep
+      zv(1:ngrid,1:nlayermx) = pv(1:ngrid,1:nlayermx) + pdv(1:ngrid,1:nlayermx)*ptimestep
+
+      ! diagnostic
+      zdtdyn(1:ngrid,1:nlayermx)     = pt(1:ngrid,1:nlayermx)-ztprevious(1:ngrid,1:nlayermx)
+      ztprevious(1:ngrid,1:nlayermx) = zt(1:ngrid,1:nlayermx)
+
+      if(firstcall)then
+         zdtdyn(1:ngrid,1:nlayermx)=0.0
+      endif
+
+      ! dynamical heating diagnostic
+      do ig=1,ngrid
+         fluxdyn(ig)= SUM(zdtdyn(ig,:) *mass(ig,:))*cpp/ptimestep
+      enddo
+
+      ! tracers
+      zq(1:ngrid,1:nlayermx,1:nq) = pq(1:ngrid,1:nlayermx,1:nq) + pdq(1:ngrid,1:nlayermx,1:nq)*ptimestep
+
+      ! surface pressure
+      ps(1:ngrid) = pplev(1:ngrid,1) + pdpsrf(1:ngrid)*ptimestep
+
+      ! pressure
+      do l=1,nlayer
+          zplev(1:ngrid,l) = pplev(1:ngrid,l)/pplev(1:ngrid,1)*ps(:)
+          zplay(1:ngrid,l) = pplay(1:ngrid,l)/pplev(1:ngrid,1)*ps(1:ngrid)
+      enddo
+
+!     ---------------------------------------------------------
+!     Surface and soil temperature information
+!     ---------------------------------------------------------
+
+      call planetwide_sumval(area(:)*tsurf(:)/totarea_planet,Ts1)
+      call planetwide_minval(tsurf(:),Ts2)
+      call planetwide_maxval(tsurf(:),Ts3)
+      if(callsoil)then
+         TsS = SUM(area(:)*tsoil(:,nsoilmx))/totarea        ! mean temperature at bottom soil layer
+           print*,'  ave[Tsurf]     min[Tsurf]     max[Tsurf]     ave[Tdeep]'
+           print*,Ts1,Ts2,Ts3,TsS
+      else
+      	if (is_master) then
+           print*,'  ave[Tsurf]     min[Tsurf]     max[Tsurf]'
+           print*,Ts1,Ts2,Ts3
+	endif
+      end if
+
+!     ---------------------------------------------------------
+!     Check the energy balance of the simulation during the run
+!     ---------------------------------------------------------
+
+      if(corrk)then
+
+	 call planetwide_sumval(area(:)*fluxtop_dn(:)/totarea_planet,ISR)
+	 call planetwide_sumval(area(:)*fluxabs_sw(:)/totarea_planet,ASR)
+	 call planetwide_sumval(area(:)*fluxtop_lw(:)/totarea_planet,OLR)
+	 call planetwide_sumval(area(:)*fluxgrd(:)/totarea_planet,GND)
+	 call planetwide_sumval(area(:)*fluxdyn(:)/totarea_planet,DYN)
+         do ig=1,ngrid
+            if(fluxtop_dn(ig).lt.0.0)then
+               print*,'fluxtop_dn has gone crazy'
+               print*,'fluxtop_dn=',fluxtop_dn(ig)
+               print*,'tau_col=',tau_col(ig)
+               print*,'aerosol=',aerosol(ig,:,:)
+               print*,'temp=   ',pt(ig,:)
+               print*,'pplay=  ',pplay(ig,:)
+               call abort
+            endif
+         end do
+                     
+         if(ngrid.eq.1)then
+            DYN=0.0
+         endif
+	 
+	 if (is_master) then
+         	print*,'  ISR            ASR            OLR            GND            DYN [W m^-2]'
+         	print*, ISR,ASR,OLR,GND,DYN
+	 endif
+
+         if(enertest .and. is_master)then
+            print*,'SW flux/heating difference SW++ - ASR = ',dEtotSW+dEtotsSW-ASR,' W m-2'
+            print*,'LW flux/heating difference LW++ - OLR = ',dEtotLW+dEtotsLW+OLR,' W m-2'
+            print*,'LW energy balance LW++ + ASR = ',dEtotLW+dEtotsLW+ASR,' W m-2'
+         endif
+
+         if(meanOLR .and. is_master)then
+            if((ngrid.gt.1) .or. (mod(icount-1,ecritphy).eq.0))then
+               ! to record global radiative balance
+               open(92,file="rad_bal.out",form='formatted',position='append')
+               write(92,*) zday,ISR,ASR,OLR
+               close(92)
+               open(93,file="tem_bal.out",form='formatted',position='append')
+               if(callsoil)then
+               	write(93,*) zday,Ts1,Ts2,Ts3,TsS
+	       else
+	        write(93,*) zday,Ts1,Ts2,Ts3
+	       endif
+               close(93)
+            endif
+         endif
+
+      endif
+
+
+!     ------------------------------------------------------------------
+!     Diagnostic to test radiative-convective timescales in code
+!     ------------------------------------------------------------------
+      if(testradtimes)then
+         open(38,file="tau_phys.out",form='formatted',position='append')
+         ig=1
+         do l=1,nlayer
+            write(38,*) -1./pdt(ig,l),pt(ig,l),pplay(ig,l)
+         enddo
+         close(38)
+         print*,'As testradtimes enabled,'
+         print*,'exiting physics on first call'
+         call abort
+      endif
+
+!     ---------------------------------------------------------
+!     Compute column amounts (kg m-2) if tracers are enabled
+!     ---------------------------------------------------------
+      if(tracer)then
+         qcol(1:ngrid,1:nq)=0.0
+         do iq=1,nq
+           do ig=1,ngrid
+              qcol(ig,iq) = SUM( zq(ig,1:nlayermx,iq) * mass(ig,1:nlayermx))
+           enddo
+         enddo
+
+         ! Generalised for arbitrary aerosols now. (LK)
+         reffcol(1:ngrid,1:naerkind)=0.0
+         if(co2cond.and.(iaero_co2.ne.0))then
+            call co2_reffrad(ngrid,nq,zq,reffrad(1,1,iaero_co2))
+            do ig=1,ngrid
+               reffcol(ig,iaero_co2) = SUM(zq(ig,1:nlayermx,igcm_co2_ice)*reffrad(ig,1:nlayermx,iaero_co2)*mass(ig,1:nlayermx))
+            enddo
+         endif
+         if(water.and.(iaero_h2o.ne.0))then
+            call h2o_reffrad(ngrid,zq(1,1,igcm_h2o_ice),zt, &
+                             reffrad(1,1,iaero_h2o),nueffrad(1,1,iaero_h2o))
+            do ig=1,ngrid
+               reffcol(ig,iaero_h2o) = SUM(zq(ig,1:nlayermx,igcm_h2o_ice)*reffrad(ig,1:nlayermx,iaero_h2o)*mass(ig,1:nlayermx))
+            enddo
+         endif
+
+      endif
+
+!     ---------------------------------------------------------
+!     Test for water conservation if water is enabled
+!     ---------------------------------------------------------
+
+      if(water)then
+
+	 call planetwide_sumval(area(:)*qsurf_hist(:,igcm_h2o_ice)/totarea_planet,icesrf)
+	 call planetwide_sumval(area(:)*qsurf_hist(:,igcm_h2o_vap)/totarea_planet,liqsrf)
+	 call planetwide_sumval(area(:)*qcol(:,igcm_h2o_ice)/totarea_planet,icecol)
+	 call planetwide_sumval(area(:)*qcol(:,igcm_h2o_vap)/totarea_planet,vapcol)
+
+         h2otot = icesrf + liqsrf + icecol + vapcol
+	 
+	 if (is_master) then
+         	print*,' Total water amount [kg m^-2]: ',h2otot
+         	print*,' Surface ice    Surface liq.   Atmos. con.     Atmos. vap. [kg m^-2] '
+         	print*, icesrf,liqsrf,icecol,vapcol
+	 endif
+
+         if(meanOLR .and. is_master)then
+            if((ngrid.gt.1) .or. (mod(icount-1,ecritphy).eq.0))then
+               ! to record global water balance
+               open(98,file="h2o_bal.out",form='formatted',position='append')
+               write(98,*) zday,icesrf,liqsrf,icecol,vapcol
+               close(98)
+            endif
+         endif
+
+      endif
+
+!     ---------------------------------------------------------
+!     Calculate RH for diagnostic if water is enabled
+!     ---------------------------------------------------------
+
+      if(water)then
+         do l = 1, nlayer
+            do ig=1,ngrid
+               call Psat_water(zt(ig,l),pplay(ig,l),psat_tmp,qsat(ig,l))
+               RH(ig,l) = zq(ig,l,igcm_h2o_vap) / qsat(ig,l)
+            enddo
+         enddo
+
+         ! compute maximum possible H2O column amount (100% saturation)
+         do ig=1,ngrid
+               H2Omaxcol(ig) = SUM( qsat(ig,:) * mass(ig,:))
+         enddo
+
+      endif
+
+
+           print*,'--> Ls =',zls*180./pi
+!        -------------------------------------------------------------------
+!        Writing NetCDF file  "RESTARTFI" at the end of the run
+!        -------------------------------------------------------------------
+!        Note: 'restartfi' is stored just before dynamics are stored
+!              in 'restart'. Between now and the writting of 'restart',
+!              there will have been the itau=itau+1 instruction and
+!              a reset of 'time' (lastacll = .true. when itau+1= itaufin)
+!              thus we store for time=time+dtvr
+
+         if(lastcall) then
+            ztime_fin = ptime + ptimestep/(float(iphysiq)*daysec)
+
+
+!           Update surface ice distribution to iterate to steady state if requested
+            if(ice_update)then
+
+               do ig=1,ngrid
+
+                  delta_ice = (qsurf(ig,igcm_h2o_ice)-ice_initial(ig))
+
+                  ! add multiple years of evolution
+                  qsurf_hist(ig,igcm_h2o_ice) = qsurf_hist(ig,igcm_h2o_ice) + delta_ice*icetstep 
+
+                  ! if ice has gone -ve, set to zero
+                  if(qsurf_hist(ig,igcm_h2o_ice).lt.0.0)then
+                     qsurf_hist(ig,igcm_h2o_ice) = 0.0 
+                  endif
+
+                  ! if ice is seasonal, set to zero (NEW)
+                  if(ice_min(ig).lt.0.01)then
+                     qsurf_hist(ig,igcm_h2o_ice) = 0.0 
+                  endif
+
+               enddo
+
+               ! enforce ice conservation
+               ice_tot= SUM(qsurf_hist(:,igcm_h2o_ice)*area(:) )
+               qsurf_hist(:,igcm_h2o_ice) = qsurf_hist(:,igcm_h2o_ice)*(icesrf/ice_tot)
+
+            endif
+
+            if (ngrid.ne.1) then
+              write(*,*)'PHYSIQ: for physdem ztime_fin =',ztime_fin
+!#ifdef CPP_PARA
+!! for now in parallel we use a different routine to write restartfi.nc
+!            call phyredem(ngrid,"restartfi.nc",           &
+!                    ptimestep,pday,ztime_fin,tsurf,tsoil,emis,q2,qsurf_hist, &
+!                    cloudfrac,totcloudfrac,hice)
+!#else
+!            call physdem1(ngrid,"restartfi.nc",long,lati,nsoilmx,nq,            &
+!                    ptimestep,pday,ztime_fin,tsurf,tsoil,emis,q2,qsurf_hist, &
+!                    area,albedodat,inertiedat,zmea,zstd,zsig,zgam,zthe,      &
+!                    cloudfrac,totcloudfrac,hice,noms)
+!#endif
+              call physdem1("restartfi.nc",nsoilmx,ngrid,nlayer,nq, &
+                      ptimestep,ztime_fin, &
+                      tsurf,tsoil,emis,q2,qsurf_hist, &
+                      cloudfrac,totcloudfrac,hice, &
+                      rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+            endif
+
+            if(ok_slab_ocean) then
+              call ocean_slab_final!(tslab, seaice)
+            end if
+
+         
+         endif ! of if (lastcall)
+
+
+!        -----------------------------------------------------------------
+!        Saving statistics :
+!        -----------------------------------------------------------------
+!        ("stats" stores and accumulates 8 key variables in file "stats.nc"
+!        which can later be used to make the statistic files of the run:
+!        "stats")          only possible in 3D runs !
+
+         
+         if (callstats) then
+
+            call wstats(ngrid,"ps","Surface pressure","Pa",2,ps)
+            call wstats(ngrid,"tsurf","Surface temperature","K",2,tsurf)
+            call wstats(ngrid,"fluxsurf_lw",                               &
+                        "Thermal IR radiative flux to surface","W.m-2",2,  &
+                         fluxsurf_lw)
+!            call wstats(ngrid,"fluxsurf_sw",                               &
+!                        "Solar radiative flux to surface","W.m-2",2,       &
+!                         fluxsurf_sw_tot)
+            call wstats(ngrid,"fluxtop_lw",                                &
+                        "Thermal IR radiative flux to space","W.m-2",2,    &
+                        fluxtop_lw)
+!            call wstats(ngrid,"fluxtop_sw",                                &
+!                        "Solar radiative flux to space","W.m-2",2,         &
+!                        fluxtop_sw_tot)
+
+            call wstats(ngrid,"ISR","incoming stellar rad.","W m-2",2,fluxtop_dn)
+            call wstats(ngrid,"ASR","absorbed stellar rad.","W m-2",2,fluxabs_sw)
+            call wstats(ngrid,"OLR","outgoing longwave rad.","W m-2",2,fluxtop_lw)
+            call wstats(ngrid,"ALB","Surface albedo"," ",2,albedo)
+            call wstats(ngrid,"p","Pressure","Pa",3,pplay)
+            call wstats(ngrid,"temp","Atmospheric temperature","K",3,zt)
+            call wstats(ngrid,"u","Zonal (East-West) wind","m.s-1",3,zu)
+            call wstats(ngrid,"v","Meridional (North-South) wind","m.s-1",3,zv)
+            call wstats(ngrid,"w","Vertical (down-up) wind","m.s-1",3,pw)
+            call wstats(ngrid,"q2","Boundary layer eddy kinetic energy","m2.s-2",3,q2)
+
+           if (tracer) then
+             do iq=1,nq
+                call wstats(ngrid,noms(iq),noms(iq),'kg/kg',3,zq(1,1,iq))
+                call wstats(ngrid,trim(noms(iq))//'_surf',trim(noms(iq))//'_surf',  & 
+                          'kg m^-2',2,qsurf(1,iq) )
+
+                call wstats(ngrid,trim(noms(iq))//'_col',trim(noms(iq))//'_col',    & 
+                          'kg m^-2',2,qcol(1,iq) )
+!                call wstats(ngrid,trim(noms(iq))//'_reff',                          & 
+!                          trim(noms(iq))//'_reff',                                   & 
+!                          'm',3,reffrad(1,1,iq))
+              end do
+            if (water) then
+               vmr=zq(1:ngrid,1:nlayermx,igcm_h2o_vap)*mugaz/mmol(igcm_h2o_vap)
+               call wstats(ngrid,"vmr_h2ovapor",                           &
+                          "H2O vapour volume mixing ratio","mol/mol",       & 
+                          3,vmr)
+            endif ! of if (water)
+
+           endif !tracer 
+
+          if(watercond.and.CLFvarying)then
+             call wstats(ngrid,"rneb_man","H2O cloud fraction (conv)"," ",3,rneb_man)
+             call wstats(ngrid,"rneb_lsc","H2O cloud fraction (large scale)"," ",3,rneb_lsc)
+             call wstats(ngrid,"CLF","H2O cloud fraction"," ",3,cloudfrac)
+             call wstats(ngrid,"CLFt","H2O column cloud fraction"," ",2,totcloudfrac)
+             call wstats(ngrid,"RH","relative humidity"," ",3,RH)
+          endif
+
+
+
+           if (ok_slab_ocean) then
+            call wstats(ngrid,"dt_hdiff1","dt_hdiff1","K/s",2,dt_hdiff(:,1))
+            call wstats(ngrid,"dt_hdiff2","dt_hdiff2","K/s",2,dt_hdiff(:,2))
+            call wstats(ngrid,"dt_ekman1","dt_ekman1","K/s",2,dt_ekman(:,1))
+            call wstats(ngrid,"dt_ekman2","dt_ekman2","K/s",2,dt_ekman(:,2))
+            call wstats(ngrid,"tslab1","tslab1","K",2,tslab(:,1))
+            call wstats(ngrid,"tslab2","tslab2","K",2,tslab(:,2))
+            call wstats(ngrid,"pctsrf_sic","pct ice/sea","",2,pctsrf_sic)
+            call wstats(ngrid,"tsea_ice","tsea_ice","K",2,tsea_ice)
+            call wstats(ngrid,"sea_ice","sea ice","kg/m2",2,sea_ice)
+            call wstats(ngrid,"rnat","nature of the surface","",2,rnat)
+           endif! (ok_slab_ocean)
+
+            if(lastcall) then
+              write (*,*) "Writing stats..."
+              call mkstats(ierr)
+            endif
+          endif !if callstats
+
+
+!        ----------------------------------------------------------------------
+!        output in netcdf file "DIAGFI", containing any variable for diagnostic
+!        (output with  period "ecritphy", set in "run.def")
+!        ----------------------------------------------------------------------
+!        writediagfi can also be called from any other subroutine for any variable.
+!        but its preferable to keep all the calls in one place...
+
+        call writediagfi(ngrid,"Ls","solar longitude","deg",0,zls*180./pi)
+        call writediagfi(ngrid,"tsurf","Surface temperature","K",2,tsurf)
+        call writediagfi(ngrid,"ps","Surface pressure","Pa",2,ps)
+        call writediagfi(ngrid,"temp","temperature","K",3,zt)
+        call writediagfi(ngrid,"teta","potential temperature","K",3,zh)
+        call writediagfi(ngrid,"u","Zonal wind","m.s-1",3,zu)
+        call writediagfi(ngrid,"v","Meridional wind","m.s-1",3,zv)
+        call writediagfi(ngrid,"w","Vertical wind","m.s-1",3,pw)
+        call writediagfi(ngrid,"p","Pressure","Pa",3,pplay)
+
+!     Subsurface temperatures
+!        call writediagsoil(ngrid,"tsurf","Surface temperature","K",2,tsurf)
+!        call writediagsoil(ngrid,"temp","temperature","K",3,tsoil)
+
+!     Oceanic layers
+        if(ok_slab_ocean) then
+          call writediagfi(ngrid,"pctsrf_sic","pct ice/sea","",2,pctsrf_sic)
+          call writediagfi(ngrid,"tsea_ice","tsea_ice","K",2,tsea_ice)
+          call writediagfi(ngrid,"sea_ice","sea ice","kg/m2",2,sea_ice)
+          call writediagfi(ngrid,"tslab1","tslab1","K",2,tslab(:,1))
+          call writediagfi(ngrid,"tslab2","tslab2","K",2,tslab(:,2))
+          call writediagfi(ngrid,"dt_hdiff1","dt_hdiff1","K/s",2,dt_hdiff(:,1))
+          call writediagfi(ngrid,"dt_hdiff2","dt_hdiff2","K/s",2,dt_hdiff(:,2))
+          call writediagfi(ngrid,"dt_ekman1","dt_ekman1","K/s",2,dt_ekman(:,1))
+          call writediagfi(ngrid,"dt_ekman2","dt_ekman2","K/s",2,dt_ekman(:,2))
+          call writediagfi(ngrid,"rnat","nature of the surface","",2,rnat)
+          call writediagfi(ngrid,"sensibFlux","sensible heat flux","w.m^-2",2,sensibFlux)
+          call writediagfi(ngrid,"latentFlux","latent heat flux","w.m^-2",2,zdqsdif(:,igcm_h2o_vap)*RLVTT)
+       endif! (ok_slab_ocean)
+
+!     Total energy balance diagnostics
+        if(callrad.and.(.not.newtonian))then
+           call writediagfi(ngrid,"ALB","Surface albedo"," ",2,albedo)
+           call writediagfi(ngrid,"ISR","incoming stellar rad.","W m-2",2,fluxtop_dn)
+           call writediagfi(ngrid,"ASR","absorbed stellar rad.","W m-2",2,fluxabs_sw)
+           call writediagfi(ngrid,"OLR","outgoing longwave rad.","W m-2",2,fluxtop_lw)
+           call writediagfi(ngrid,"shad","rings"," ", 2, fract)
+!           call writediagfi(ngrid,"ASRcs","absorbed stellar rad (cs).","W m-2",2,fluxabs_sw1)
+!           call writediagfi(ngrid,"OLRcs","outgoing longwave rad (cs).","W m-2",2,fluxtop_lw1)
+!           call writediagfi(ngrid,"fluxsurfsw","sw surface flux.","W m-2",2,fluxsurf_sw)
+!           call writediagfi(ngrid,"fluxsurflw","lw back radiation.","W m-2",2,fluxsurf_lw)
+!           call writediagfi(ngrid,"fluxsurfswcs","sw surface flux (cs).","W m-2",2,fluxsurf_sw1)
+!           call writediagfi(ngrid,"fluxsurflwcs","lw back radiation (cs).","W m-2",2,fluxsurf_lw1)
+           if(ok_slab_ocean) then
+             call writediagfi(ngrid,"GND","heat flux from ground","W m-2",2,fluxgrdocean)
+           else
+             call writediagfi(ngrid,"GND","heat flux from ground","W m-2",2,fluxgrd)
+           endif!(ok_slab_ocean)
+           call writediagfi(ngrid,"DYN","dynamical heat input","W m-2",2,fluxdyn)
+	 endif
+	
+	if(enertest) then
+	  if (calldifv) then
+	     call writediagfi(ngrid,"q2","turbulent kinetic energy","J.kg^-1",3,q2)
+!	     call writediagfi(ngrid,"dEzdiff","turbulent diffusion heating (-sensible flux)","w.m^-2",3,dEzdiff)
+!	     call writediagfi(ngrid,"dEdiff","integrated turbulent diffusion heating (-sensible flux)","w.m^-2",2,dEdiff)
+!	     call writediagfi(ngrid,"dEdiffs","In TurbDiff (correc rad+latent heat) surf nrj change","w.m^-2",2,dEdiffs)
+	     call writediagfi(ngrid,"sensibFlux","sensible heat flux","w.m^-2",2,sensibFlux)
+	  endif
+	  if (corrk) then
+	     call writediagfi(ngrid,"dEzradsw","radiative heating","w.m^-2",3,dEzradsw)
+	     call writediagfi(ngrid,"dEzradlw","radiative heating","w.m^-2",3,dEzradlw)
+	  endif 
+          if(watercond) then
+!	     call writediagfi(ngrid,"lscaledEz","heat from largescale","W m-2",3,lscaledEz) 
+!	     call writediagfi(ngrid,"madjdEz","heat from moistadj","W m-2",3,madjdEz)
+	     call writediagfi(ngrid,"lscaledE","heat from largescale","W m-2",2,lscaledE) 
+	     call writediagfi(ngrid,"madjdE","heat from moistadj","W m-2",2,madjdE)
+	     call writediagfi(ngrid,"qsatatm","atm qsat"," ",3,qsat)
+!	     call writediagfi(ngrid,"h2o_max_col","maximum H2O column amount","kg.m^-2",2,H2Omaxcol)
+          endif 
+        endif
+
+!     Temporary inclusions for heating diagnostics
+!        call writediagfi(ngrid,"zdtdyn","Dyn. heating","T s-1",3,zdtdyn)
+        call writediagfi(ngrid,"zdtsw","SW heating","T s-1",3,zdtsw)
+        call writediagfi(ngrid,"zdtlw","LW heating","T s-1",3,zdtlw)
+        call writediagfi(ngrid,"dtrad","radiative heating","K s-1",3,dtrad)
+
+        ! debugging
+        !call writediagfi(ngrid,'rnat','Terrain type',' ',2,real(rnat))
+        !call writediagfi(ngrid,'pphi','Geopotential',' ',3,pphi)
+
+!     Output aerosols
+        if (igcm_co2_ice.ne.0.and.iaero_co2.ne.0) &
+	  call writediagfi(ngrid,'CO2ice_reff','CO2ice_reff','m',3,reffrad(1,1,iaero_co2))
+        if (igcm_h2o_ice.ne.0.and.iaero_h2o.ne.0) &
+	  call writediagfi(ngrid,'H2Oice_reff','H2Oice_reff','m',3,reffrad(:,:,iaero_h2o))
+        if (igcm_co2_ice.ne.0.and.iaero_co2.ne.0) &
+	  call writediagfi(ngrid,'CO2ice_reffcol','CO2ice_reffcol','um kg m^-2',2,reffcol(1,iaero_co2))
+        if (igcm_h2o_ice.ne.0.and.iaero_h2o.ne.0) &
+	  call writediagfi(ngrid,'H2Oice_reffcol','H2Oice_reffcol','um kg m^-2',2,reffcol(1,iaero_h2o))
+
+!     Output tracers
+       if (tracer) then
+        do iq=1,nq
+          call writediagfi(ngrid,noms(iq),noms(iq),'kg/kg',3,zq(1,1,iq))
+!          call writediagfi(ngrid,trim(noms(iq))//'_surf',trim(noms(iq))//'_surf',  & 
+!                          'kg m^-2',2,qsurf(1,iq) )
+          call writediagfi(ngrid,trim(noms(iq))//'_surf',trim(noms(iq))//'_surf',  & 
+                          'kg m^-2',2,qsurf_hist(1,iq) )
+          call writediagfi(ngrid,trim(noms(iq))//'_col',trim(noms(iq))//'_col',    & 
+                          'kg m^-2',2,qcol(1,iq) )
+
+          if(watercond.or.CLFvarying)then
+             call writediagfi(ngrid,"rneb_man","H2O cloud fraction (conv)"," ",3,rneb_man)
+             call writediagfi(ngrid,"rneb_lsc","H2O cloud fraction (large scale)"," ",3,rneb_lsc)
+             call writediagfi(ngrid,"CLF","H2O cloud fraction"," ",3,cloudfrac)
+             call writediagfi(ngrid,"CLFt","H2O column cloud fraction"," ",2,totcloudfrac)
+	     call writediagfi(ngrid,"RH","relative humidity"," ",3,RH)
+          endif
+
+          if(waterrain)then
+             call writediagfi(ngrid,"rain","rainfall","kg m-2 s-1",2,zdqsrain)
+             call writediagfi(ngrid,"snow","snowfall","kg m-2 s-1",2,zdqssnow)
+          endif
+
+          if((hydrology).and.(.not.ok_slab_ocean))then
+             call writediagfi(ngrid,"hice","oceanic ice height","m",2,hice)
+          endif
+
+          if(ice_update)then
+             call writediagfi(ngrid,"ice_min","min annual ice","m",2,ice_min)
+             call writediagfi(ngrid,"ice_ini","initial annual ice","m",2,ice_initial)
+          endif
+
+          do ig=1,ngrid
+             if(tau_col(ig).gt.1.e3)then
+!                print*,'WARNING: tau_col=',tau_col(ig)
+!                print*,'at ig=',ig,'in PHYSIQ'
+             endif
+          end do
+
+          call writediagfi(ngrid,"tau_col","Total aerosol optical depth","[]",2,tau_col)
+
+        enddo
+       endif
+
+!      output spectrum 
+      if(specOLR.and.corrk)then      
+         call writediagspecIR(ngrid,"OLR3D","OLR(lon,lat,band)","W/m^2/cm^-1",3,OLR_nu)
+         call writediagspecVI(ngrid,"OSR3D","OSR(lon,lat,band)","W/m^2/cm^-1",3,OSR_nu)
+      endif
+
+      icount=icount+1
+
+      if (lastcall) then
+
+        ! deallocate gas variables
+        IF ( ALLOCATED( gnom ) ) DEALLOCATE( gnom )
+        IF ( ALLOCATED( gfrac ) ) DEALLOCATE( gfrac )  ! both allocated in su_gases.F90
+
+        ! deallocate saved arrays
+        ! this is probably not that necessary
+        ! ... but probably a good idea to clean the place before we leave
+        IF ( ALLOCATED(tsurf)) DEALLOCATE(tsurf)
+        IF ( ALLOCATED(tsoil)) DEALLOCATE(tsoil)
+        IF ( ALLOCATED(albedo)) DEALLOCATE(albedo)
+        IF ( ALLOCATED(albedo0)) DEALLOCATE(albedo0)
+        IF ( ALLOCATED(rnat)) DEALLOCATE(rnat)
+        IF ( ALLOCATED(emis)) DEALLOCATE(emis)
+        IF ( ALLOCATED(dtrad)) DEALLOCATE(dtrad)
+        IF ( ALLOCATED(fluxrad_sky)) DEALLOCATE(fluxrad_sky)
+        IF ( ALLOCATED(fluxrad)) DEALLOCATE(fluxrad)
+        IF ( ALLOCATED(capcal)) DEALLOCATE(capcal)
+        IF ( ALLOCATED(fluxgrd)) DEALLOCATE(fluxgrd)
+        IF ( ALLOCATED(qsurf)) DEALLOCATE(qsurf)
+        IF ( ALLOCATED(q2)) DEALLOCATE(q2)
+        IF ( ALLOCATED(ztprevious)) DEALLOCATE(ztprevious)
+        IF ( ALLOCATED(cloudfrac)) DEALLOCATE(cloudfrac)
+        IF ( ALLOCATED(totcloudfrac)) DEALLOCATE(totcloudfrac)
+        IF ( ALLOCATED(qsurf_hist)) DEALLOCATE(qsurf_hist)
+        IF ( ALLOCATED(reffrad)) DEALLOCATE(reffrad)
+        IF ( ALLOCATED(nueffrad)) DEALLOCATE(nueffrad)
+        IF ( ALLOCATED(ice_initial)) DEALLOCATE(ice_initial)
+        IF ( ALLOCATED(ice_min)) DEALLOCATE(ice_min)
+
+        IF ( ALLOCATED(fluxsurf_lw)) DEALLOCATE(fluxsurf_lw)
+        IF ( ALLOCATED(fluxsurf_sw)) DEALLOCATE(fluxsurf_sw)
+        IF ( ALLOCATED(fluxtop_lw)) DEALLOCATE(fluxtop_lw)
+        IF ( ALLOCATED(fluxabs_sw)) DEALLOCATE(fluxabs_sw)
+        IF ( ALLOCATED(fluxtop_dn)) DEALLOCATE(fluxtop_dn)
+        IF ( ALLOCATED(fluxdyn)) DEALLOCATE(fluxdyn)
+        IF ( ALLOCATED(OLR_nu)) DEALLOCATE(OLR_nu)
+        IF ( ALLOCATED(OSR_nu)) DEALLOCATE(OSR_nu)
+        IF ( ALLOCATED(sensibFlux)) DEALLOCATE(sensibFlux)
+        IF ( ALLOCATED(zdtlw)) DEALLOCATE(zdtlw)
+        IF ( ALLOCATED(zdtsw)) DEALLOCATE(zdtsw)
+        IF ( ALLOCATED(tau_col)) DEALLOCATE(tau_col)
+
+        !! this is defined in comsaison_h
+        IF ( ALLOCATED(mu0)) DEALLOCATE(mu0)
+
+        IF ( ALLOCATED(fract)) DEALLOCATE(fract)
+
+
+        !! this is defined in radcommon_h
+        IF ( ALLOCATED(eclipse)) DEALLOCATE(eclipse)
+
+        !! this is defined in comsoil_h
+        IF ( ALLOCATED(layer)) DEALLOCATE(layer)
+        IF ( ALLOCATED(mlayer)) DEALLOCATE(mlayer)
+        IF ( ALLOCATED(inertiedat)) DEALLOCATE(inertiedat)
+
+        !! this is defined in surfdat_h
+        IF ( ALLOCATED(albedodat)) DEALLOCATE(albedodat)
+        IF ( ALLOCATED(phisfi)) DEALLOCATE(phisfi)
+        IF ( ALLOCATED(zmea)) DEALLOCATE(zmea)
+        IF ( ALLOCATED(zstd)) DEALLOCATE(zstd)
+        IF ( ALLOCATED(zsig)) DEALLOCATE(zsig)
+        IF ( ALLOCATED(zgam)) DEALLOCATE(zgam)
+        IF ( ALLOCATED(zthe)) DEALLOCATE(zthe)
+        IF ( ALLOCATED(dryness)) DEALLOCATE(dryness)
+        IF ( ALLOCATED(watercaptag)) DEALLOCATE(watercaptag)
+ 
+        !! this is defined in tracer_h
+        IF ( ALLOCATED(noms)) DEALLOCATE(noms)
+        IF ( ALLOCATED(mmol)) DEALLOCATE(mmol)
+        IF ( ALLOCATED(radius)) DEALLOCATE(radius)
+        IF ( ALLOCATED(rho_q)) DEALLOCATE(rho_q)
+        IF ( ALLOCATED(qext)) DEALLOCATE(qext)
+        IF ( ALLOCATED(alpha_lift)) DEALLOCATE(alpha_lift)
+        IF ( ALLOCATED(alpha_devil)) DEALLOCATE(alpha_devil)
+        IF ( ALLOCATED(qextrhor)) DEALLOCATE(qextrhor)
+        IF ( ALLOCATED(igcm_dustbin)) DEALLOCATE(igcm_dustbin)
+
+        !! this is defined in comgeomfi_h
+        IF ( ALLOCATED(lati)) DEALLOCATE(lati)
+        IF ( ALLOCATED(long)) DEALLOCATE(long)
+        IF ( ALLOCATED(area)) DEALLOCATE(area)
+        IF ( ALLOCATED(sinlat)) DEALLOCATE(sinlat)
+        IF ( ALLOCATED(coslat)) DEALLOCATE(coslat)
+        IF ( ALLOCATED(sinlon)) DEALLOCATE(sinlon)
+        IF ( ALLOCATED(coslon)) DEALLOCATE(coslon)
+      endif
+
+      return
+    end subroutine physiq
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/planete.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/planete.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/planete.h	(revision 222)
@@ -0,0 +1,15 @@
+!-----------------------------------------------------------------------
+! INCLUDE planet.h
+
+      COMMON/planet/apoastr,periastr,year_day,peri_day,                 &
+     &       obliquit,nres,                                             &
+     &       z0,lmixmin,emin_turb,coefvis,coefir,                       &
+     &       timeperi,e_elips,p_elips
+
+      real apoastr,periastr,year_day,peri_day,                          &
+     &     obliquit,nres,                                               &
+     &     z0,lmixmin,emin_turb,coefvis,coefir,                         &
+     &       timeperi,e_elips,p_elips
+      
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/planetwide_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/planetwide_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/planetwide_mod.F90	(revision 222)
@@ -0,0 +1,298 @@
+!
+! $Id: $
+!
+module planetwide_mod
+! module which contains functions to obtain max/min/... values over the
+! entire globe (trivial in serial mode, but not in parallel)
+
+use mod_phys_lmdz_para, only : is_master, gather, bcast
+                               
+implicit none
+
+interface planetwide_maxval ! maxval() , over the entire planet
+  module procedure planetwide_maxval_i1, planetwide_maxval_i2, &
+                   planetwide_maxval_r1, planetwide_maxval_r2
+end interface
+
+interface planetwide_minval ! minval() , over the entire planet
+  module procedure planetwide_minval_i1, planetwide_minval_i2, &
+                   planetwide_minval_r1, planetwide_minval_r2
+end interface
+
+interface planetwide_sumval ! sum() , over the entire planet
+  module procedure planetwide_sumval_i1, planetwide_sumval_i2, &
+                   planetwide_sumval_r1, planetwide_sumval_r2
+end interface
+
+contains
+
+  subroutine planetwide_maxval_i1(values,values_max)
+  use dimphy, only: klon
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  integer,intent(in) :: values(:) ! local grid (klon)
+  integer,intent(out) :: values_max
+#ifdef CPP_PARA
+  integer :: values_glo(klon_glo) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=maxval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=maxval(values)
+#endif
+  end subroutine planetwide_maxval_i1
+
+  subroutine planetwide_maxval_i2(values,values_max)
+  use dimphy, only: klon, klev
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  integer,intent(in) :: values(:,:) ! local grid (klon,klev)
+  integer,intent(out) :: values_max
+#ifdef CPP_PARA
+  integer :: values_glo(klon_glo,klev) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=maxval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=maxval(values)
+#endif
+  end subroutine planetwide_maxval_i2
+
+  subroutine planetwide_maxval_r1(values,values_max)
+  use dimphy, only: klon
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  real,intent(in) :: values(:) ! local grid (klon)
+  real,intent(out) :: values_max
+#ifdef CPP_PARA
+  real :: values_glo(klon_glo) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=maxval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=maxval(values)
+#endif
+  end subroutine planetwide_maxval_r1
+
+  subroutine planetwide_maxval_r2(values,values_max)
+  use dimphy, only: klon, klev
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  real,intent(in) :: values(:,:) ! local grid (klon,klev)
+  real,intent(out) :: values_max
+#ifdef CPP_PARA
+  real :: values_glo(klon_glo,klev) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=maxval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=maxval(values)
+#endif
+  end subroutine planetwide_maxval_r2
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  subroutine planetwide_minval_i1(values,values_max)
+  use dimphy, only: klon
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  integer,intent(in) :: values(:) ! local grid (klon)
+  integer,intent(out) :: values_max
+#ifdef CPP_PARA
+  integer :: values_glo(klon_glo) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=minval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=minval(values)
+#endif
+  end subroutine planetwide_minval_i1
+
+  subroutine planetwide_minval_i2(values,values_max)
+  use dimphy, only: klon, klev
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  integer,intent(in) :: values(:,:) ! local grid (klon,klev)
+  integer,intent(out) :: values_max
+#ifdef CPP_PARA
+  integer :: values_glo(klon_glo,klev) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=minval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=minval(values)
+#endif
+  end subroutine planetwide_minval_i2
+
+  subroutine planetwide_minval_r1(values,values_max)
+  use dimphy, only: klon
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  real,intent(in) :: values(:) ! local grid (klon)
+  real,intent(out) :: values_max
+#ifdef CPP_PARA
+  real :: values_glo(klon_glo) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=minval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=minval(values)
+#endif
+  end subroutine planetwide_minval_r1
+
+  subroutine planetwide_minval_r2(values,values_max)
+  use dimphy, only: klon, klev
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  real,intent(in) :: values(:,:) ! local grid (klon,klev)
+  real,intent(out) :: values_max
+#ifdef CPP_PARA
+  real :: values_glo(klon_glo,klev) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! extract maximum value
+  if (is_master) then
+    values_max=minval(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_max)
+#else
+  values_max=minval(values)
+#endif
+  end subroutine planetwide_minval_r2
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  subroutine planetwide_sumval_i1(values,values_sum)
+  use dimphy, only: klon
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  integer,intent(in) :: values(:) ! local grid (klon)
+  integer,intent(out) :: values_sum
+#ifdef CPP_PARA
+  integer :: values_glo(klon_glo) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! calculate sum value
+  if (is_master) then
+    values_sum=SUM(values_glo(:))
+  endif
+  ! broadcast information to all cores
+  call bcast(values_sum)
+#else
+  values_sum=SUM(values(:))
+#endif
+  end subroutine planetwide_sumval_i1
+
+  subroutine planetwide_sumval_i2(values,values_sum)
+  use dimphy, only: klon, klev
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  integer,intent(in) :: values(:,:) ! local grid (klon,klev)
+  integer,intent(out) :: values_sum
+#ifdef CPP_PARA
+  integer :: values_glo(klon_glo,klev) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! calculate sum value
+  if (is_master) then
+    values_sum=SUM(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_sum)
+#else
+  values_sum=SUM(values)
+#endif
+  end subroutine planetwide_sumval_i2
+
+  subroutine planetwide_sumval_r1(values,values_sum)
+  use dimphy, only: klon
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  real,intent(in) :: values(:) ! local grid (klon)
+  real,intent(out) :: values_sum
+#ifdef CPP_PARA
+  real :: values_glo(klon_glo) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! calculate sum value
+  if (is_master) then
+    values_sum=SUM(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_sum)
+#else
+  values_sum=SUM(values)
+#endif
+  end subroutine planetwide_sumval_r1
+
+  subroutine planetwide_sumval_r2(values,values_sum)
+  use dimphy, only: klon, klev
+  use mod_grid_phy_lmdz, only : klon_glo
+  implicit none
+  real,intent(in) :: values(:,:) ! local grid (klon,klev)
+  real,intent(out) :: values_sum
+#ifdef CPP_PARA
+  real :: values_glo(klon_glo,klev) ! global grid
+  
+  ! gather field on master:
+  call gather(values,values_glo)
+  ! calculate sum value
+  if (is_master) then
+    values_sum=SUM(values_glo)
+  endif
+  ! broadcast information to all cores
+  call bcast(values_sum)
+#else
+  values_sum=SUM(values)
+#endif
+  end subroutine planetwide_sumval_r2
+  
+  
+end module planetwide_mod
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/profile.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/profile.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/profile.F	(revision 222)
@@ -0,0 +1,226 @@
+      SUBROUTINE profile(nlev,zkm,temp)
+! to use  'getin'
+      USE ioipsl_getincom 
+      IMPLICIT NONE
+c=======================================================================
+c     Subroutine utilisee dans "rcm1d"
+c     pour l'initialisation du profil atmospherique
+c=======================================================================
+c
+c   differents profils d'atmospheres. T=f(z)
+c   entree:
+c     nlev    nombre de niveaux
+c     zkm     alititudes en km
+c     ichoice choix de l'atmosphere:
+c             1 Temperature constante
+c             2 profil Savidjari
+c             3 Lindner (profil polaire)
+c             4 Inversion pour Francois
+c             5 Seiff (moyen)
+c             6 T constante + perturbation gauss (level) (christophe 10/98)
+c             7 T constante + perturbation gauss   (km)  (christophe 10/98)
+c             8 Lecture du profile dans un fichier ASCII (profile)
+c     tref    temperature de reference
+c     isin    ajout d'une perturbation (isin=1)
+c     pic     pic perturbation gauss pour ichoice = 6 ou 7
+c     largeur largeur de la perturbation gauss pour ichoice = 6 ou 7
+c     hauteur hauteur de la perturbation gauss pour ichoice = 6 ou 7
+c
+c   sortie:
+c     temp    temperatures en K
+c     
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+c   arguments:
+c   ----------
+
+       INTEGER nlev, unit
+       REAL zkm(nlev),temp(nlev)
+
+c   local:
+c   ------
+
+      INTEGER il,ichoice,nseiff,iseiff,isin,iter
+      REAL pi
+      PARAMETER(nseiff=37)
+      REAL tref,t1,t2,t3,ww
+      REAL tseiff(nseiff)
+      DATA tseiff/214.,213.8,213.4,212.4,209.3,205.,201.4,197.8,
+     $           194.6,191.4,188.2,185.2,182.5,180.,177.5,175,
+     $           172.5,170.,167.5,164.8,162.4,160.,158.,156.,
+     $           154.1,152.2,150.3,148.7,147.2,145.7,144.2,143.,
+     $           142.,141.,140,139.5,139./
+      REAL pic,largeur
+      REAL hauteur,tmp
+
+c-----------------------------------------------------------------------
+c   read input profile type:
+c--------------------------
+
+      ichoice=1 ! default value for ichoice
+      call getin("ichoice",ichoice)
+      tref=200 ! default value for tref
+      call getin("tref",tref)
+      isin=0 ! default value for isin (=0 means no perturbation)
+      call getin("isin",isin)
+      pic=26.522 ! default value for pic
+      call getin("pic",pic)
+      largeur=10 ! default value for largeur
+      call getin("largeur",largeur)
+      hauteur=30 ! default value for hauteur
+      call getin("hauteur",hauteur)
+
+c-----------------------------------------------------------------------
+c   ichoice=1 temperature constante:
+c   --------------------------------
+
+      IF(ichoice.EQ.1) THEN
+         DO il=1,nlev
+            temp(il)=tref
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=2 savidjari:
+c   --------------------
+
+      ELSE IF(ichoice.EQ.2) THEN
+         DO il=1,nlev
+            temp(il)=AMAX1(219.-2.5*zkm(il),140.)
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=3 Lindner:
+c   ------------------
+
+      ELSE IF(ichoice.EQ.3) THEN
+         DO il=1,nlev
+            IF(zkm(il).LT.2.5) THEN
+               temp(il)=150.+30.*zkm(il)/2.5
+            ELSE IF(zkm(il).LT.5.) THEN
+               temp(il)=180.
+            ELSE
+               temp(il)=AMAX1(180.-2.*(zkm(il)-5.),130.)
+            ENDIF
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=4 Inversion pour Francois:
+c   ------------------
+
+      ELSE IF(ichoice.EQ.4) THEN
+         DO il=1,nlev
+            IF(zkm(il).LT.20.) THEN
+               temp(il)=135.
+            ELSE
+               temp(il)=AMIN1(135.+5.*(zkm(il)-20.),200.)
+            ENDIF
+         ENDDO
+
+
+c-----------------------------------------------------------------------
+c   ichoice=5 Seiff:
+c   ----------------
+
+      ELSE IF(ichoice.EQ.5) THEN
+	 DO il=1,nlev
+	    iseiff=INT(zkm(il)/2.)+1
+	    IF(iseiff.LT.nseiff-1) THEN
+	       temp(il)=tseiff(iseiff)+(zkm(il)-2.*(iseiff-1))*
+     $         (tseiff(iseiff+1)-tseiff(iseiff))/2.
+	    ELSE
+	       temp(il)=tseiff(nseiff)
+	    ENDIF
+	 ENDDO
+c IF(ichoice.EQ.6) THEN
+c	    DO iter=1,6
+c	    t2=temp(1)
+c	    t3=temp(2)
+c	    DO il=2,nlev-1
+c	       t1=t2
+c	       t2=t3
+c	       t3=temp(il+1)
+c	       ww=tanh(zkm(il)/20.)
+c	       ww=ww*ww*ww
+c	       temp(il)=t2+ww*.5*(t1-2.*t2+t3)
+c	    ENDDO
+c	    ENDDO
+c	 ENDIF
+
+c-----------------------------------------------------------------------
+c   ichoice=6 
+c   ---------
+
+      ELSE IF(ichoice.EQ.6) THEN
+      DO il=1,nlev
+        tmp=il-pic
+        temp(il)=tref + hauteur*exp(-tmp*tmp/largeur/largeur)
+      ENDDO
+
+
+c-----------------------------------------------------------------------
+c   ichoice=7
+c   ---------
+
+      ELSE IF(ichoice.EQ.7) THEN
+      DO il=1,nlev
+        tmp=zkm(il)-pic
+        temp(il)=tref + hauteur*exp(-tmp*tmp*4/largeur/largeur)
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=8
+c   ---------
+
+      ! first value is surface temperature
+      ! then profile of atmospheric temperature
+      ELSE IF(ichoice.GE.8) THEN
+      OPEN(11,file='profile',status='old',form='formatted',err=101)
+      DO il=1,nlev
+        READ (11,*) temp(il)
+      ENDDO
+
+      GOTO 201
+101   STOP'fichier profile inexistant'
+201   CONTINUE
+      CLOSE(10)
+
+c-----------------------------------------------------------------------
+
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   rajout eventuel d'une perturbation:
+c   -----------------------------------
+
+      IF(isin.EQ.1) THEN
+	 pi=2.*ASIN(1.)
+	 DO il=1,nlev
+c       if (nlev.EQ.501) then
+c         if (zkm(il).LE.70.5) then
+c       temp(il)=temp(il)+(1.-1000./(1000+zkm(il)*zkm(il)))*(
+c    s      6.*SIN(zkm(il)*pi/6.)+9.*SIN(zkm(il)*pi/10.3) )
+c         endif
+c       else
+        temp(il)=temp(il)+(1.-1000./(1000+zkm(il)*zkm(il)))*(
+     s      6.*SIN(zkm(il)*pi/6.)+9.*SIN(zkm(il)*pi/10.3) )
+c       endif
+	 ENDDO
+      ENDIF
+
+
+c-----------------------------------------------------------------------
+c   Ecriture du profil de temperature dans un fichier profile.out
+c   -------------------------------------------------------------
+
+
+      OPEN(12,file='profile.out',form='formatted')
+	  DO il=1,nlev
+	    write(12,*) temp(il)
+	  ENDDO
+      CLOSE(12)
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radcommon_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radcommon_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radcommon_h.F90	(revision 222)
@@ -0,0 +1,146 @@
+      module radcommon_h
+
+      use radinc_h
+      implicit none
+
+!----------------------------------------------------------------------C
+!
+!                             radcommon.h
+!
+!----------------------------------------------------------------------C
+!
+!  "Include" grid.h and radinc.h before this file in code that uses
+!  some or all of this common data set
+!
+!     WNOI       - Array of wavenumbers at the spectral interval
+!                  centers for the infrared.  Array is NSPECTI
+!                  elements long.
+!     DWNI       - Array of "delta wavenumber", i.e., the width,
+!                  in wavenumbers (cm^-1) of each IR spectral
+!                  interval.  NSPECTI elements long.
+!     WAVEI      - Array (NSPECTI elements long) of the wavelenght
+!                  (in microns) at the center of each IR spectral
+!                  interval.
+!     WNOV       - Array of wavenumbers at the spectral interval
+!                  center for the VISUAL.  Array is NSPECTV
+!                  elements long.
+!     DWNV       - Array of "delta wavenumber", i.e., the width,
+!                  in wavenumbers (cm^-1) of each VISUAL spectral
+!                  interval.  NSPECTV elements long.
+!     WAVEV      - Array (NSPECTV elements long) of the wavelenght
+!                  (in microns) at the center of each VISUAL spectral
+!                  interval.
+!     STELLARF   - Array (NSPECTV elements) of stellar flux (W/M^2) in
+!                  each spectral interval.  Values are for 1 AU,
+!                  scaled to the planetary distance elsewhere.
+!     TAURAY     - Array (NSPECTV elements) of the pressure-independent
+!                  part of Rayleigh scattering optical depth.
+!     TAURAYVAR  - Array (NSPECTV elements) of the pressure-independent
+!                  part of Rayleigh scattering optical depth for the variable gas.
+!     FZEROI     - Fraction of zeros in the IR CO2 k-coefficients, for
+!                  each temperature, pressure, and spectral interval
+!     FZEROV     - Fraction of zeros in the VISUAL CO2 k-coefficients, for
+!                  each temperature, pressure, and spectral interval
+!
+!     AEROSOL RADIATIVE OPTICAL CONSTANTS
+! 
+!   Shortwave
+!   ~~~~~~~~~
+! 
+! For the "naerkind" kind of aerosol radiative properties : 
+! QVISsQREF  :  Qext / Qext("longrefvis")
+! omegavis   :  single scattering albedo
+! gvis       :  assymetry factor
+! 
+!   Longwave
+!   ~~~~~~~~
+! 
+! For the "naerkind" kind of aerosol radiative properties : 
+! QIRsQREF :  Qext / Qext("longrefvis")
+! omegaIR  :  mean single scattering albedo
+! gIR      :  mean assymetry factor
+
+      REAL*8 BWNI(L_NSPECTI+1), WNOI(L_NSPECTI), DWNI(L_NSPECTI), WAVEI(L_NSPECTI)
+      REAL*8 BWNV(L_NSPECTV+1), WNOV(L_NSPECTV), DWNV(L_NSPECTV), WAVEV(L_NSPECTV)
+      REAL*8 STELLARF(L_NSPECTV), TAURAY(L_NSPECTV), TAURAYVAR(L_NSPECTV)
+
+      REAL*8 blami(L_NSPECTI+1)
+      REAL*8 blamv(L_NSPECTV+1) ! these are needed by suaer.F90
+
+      !! AS: introduced to avoid doing same computations again for continuum
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: indi
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: indv
+
+      !!! ALLOCATABLE STUFF SO THAT DIMENSIONS ARE READ in *.dat FILES -- AS 12/2011  
+      REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: gasi, gasv
+      REAL*8, DIMENSION(:), ALLOCATABLE :: PGASREF, TGASREF, WREFVAR, PFGASREF
+      real*8 FZEROI(L_NSPECTI)
+      real*8 FZEROV(L_NSPECTV)
+      real*8 pgasmin, pgasmax
+      real*8 tgasmin, tgasmax
+
+      real QVISsQREF(L_NSPECTV,naerkind,nsizemax)
+      real omegavis(L_NSPECTV,naerkind,nsizemax)
+      real gvis(L_NSPECTV,naerkind,nsizemax)
+      real QIRsQREF(L_NSPECTI,naerkind,nsizemax)
+      real omegair(L_NSPECTI,naerkind,nsizemax)
+      real gir(L_NSPECTI,naerkind,nsizemax)
+
+
+! Reference wavelengths used to compute reference optical depth (m)
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      REAL lamrefir(naerkind),lamrefvis(naerkind)
+
+! Actual number of grain size classes in each domain for a
+!   given aerosol:
+
+      INTEGER          :: nsize(naerkind,2)
+
+! Particle size axis (depend on the kind of aerosol and the
+!   radiation domain)
+
+      DOUBLE PRECISION :: radiustab(naerkind,2,nsizemax)
+
+! Extinction coefficient at reference wavelengths;
+!   These wavelengths are defined in aeroptproperties, and called
+!   longrefvis and longrefir.
+
+      REAL :: QREFvis(naerkind,nsizemax)
+      REAL :: QREFir(naerkind,nsizemax)
+      REAL :: omegaREFvis(naerkind,nsizemax)
+      REAL :: omegaREFir(naerkind,nsizemax)
+
+      REAL tstellar ! Stellar brightness temperature (SW)
+
+      real*8 planckir(L_NSPECTI,NTstop-NTstar+1)
+
+      real*8 PTOP, TAUREF(L_LEVELS+1)
+
+      real*8, parameter :: UBARI = 0.5D0
+
+      real*8 gweight(L_NGAUSS)
+
+!     If the gas optical depth (top to the surface) is less than
+!     this value, we place that Gauss-point into the "zeros"
+!     channel.
+      real*8, parameter :: TLIMIT =  1.0D-30
+
+!     Factor to convert pressures from millibars to Pascals
+      real*8, parameter :: SCALEP = 1.00D+2
+
+      real*8, parameter :: sigma = 5.67032D-8
+      real*8, parameter :: grav = 6.672E-11
+
+      real*8 Cmk
+      save Cmk
+      real*8 glat_ig
+      save glat_ig
+
+      ! extinction of incoming sunlight (Saturn's rings, eclipses, etc...)
+      REAL, DIMENSION(:), ALLOCATABLE :: eclipse
+
+      !Latitude-dependent gravity
+      REAL, DIMENSION(:), ALLOCATABLE :: glat
+
+      end module radcommon_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radii_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radii_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radii_mod.F90	(revision 222)
@@ -0,0 +1,385 @@
+!==================================================================
+module radii_mod
+!==================================================================
+!  module to centralize the radii calculations for aerosols
+! OK for water but should be extended to other aerosols (CO2,...)
+!==================================================================
+      
+!     water cloud optical properties
+      
+      real, save ::  rad_h2o
+      real, save ::  rad_h2o_ice
+      real, save ::  Nmix_h2o
+      real, save ::  Nmix_h2o_ice
+      real, parameter ::  coef_chaud=0.13
+      real, parameter ::  coef_froid=0.09
+
+
+      contains
+
+
+!==================================================================
+   subroutine su_aer_radii(ngrid,reffrad,nueffrad)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of liquid and icy water particles
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+ ! to use  'getin'
+      use ioipsl_getincom 
+      use radinc_h, only: naerkind
+      use aerosol_mod
+!      USE tracer_h
+      Implicit none
+
+      include "callkeys.h"
+      include "dimensions.h"
+      include "dimphys.h"
+
+      integer,intent(in) :: ngrid
+
+      real, intent(out) :: reffrad(ngrid,nlayermx,naerkind)      !aerosols radii (K)
+      real, intent(out) :: nueffrad(ngrid,nlayermx,naerkind)     !variance     
+
+      logical, save :: firstcall=.true.
+      integer :: iaer   
+      
+      print*,'enter su_aer_radii'
+          do iaer=1,naerkind
+!     these values will change once the microphysics gets to work
+!     UNLESS tracer=.false., in which case we should be working with
+!     a fixed aerosol layer, and be able to define reffrad in a 
+!     .def file. To be improved!
+
+            if(iaer.eq.iaero_co2)then ! CO2 ice
+               reffrad(1:ngrid,1:nlayermx,iaer) = 1.e-4
+               nueffrad(1:ngrid,1:nlayermx,iaer) = 0.1 
+            endif
+
+            if(iaer.eq.iaero_h2o)then ! H2O ice
+               reffrad(1:ngrid,1:nlayermx,iaer) = 1.e-5
+               nueffrad(1:ngrid,1:nlayermx,iaer) = 0.1 
+            endif
+
+            if(iaer.eq.iaero_dust)then ! dust
+               reffrad(1:ngrid,1:nlayermx,iaer) = 1.e-5
+               nueffrad(1:ngrid,1:nlayermx,iaer) = 0.1 
+            endif
+ 
+            if(iaer.eq.iaero_h2so4)then ! H2O ice
+               reffrad(1:ngrid,1:nlayermx,iaer) = 1.e-6
+               nueffrad(1:ngrid,1:nlayermx,iaer) = 0.1 
+            endif
+	    
+	    if(iaer.eq.iaero_back2lay)then ! Two-layer aerosols
+               reffrad(1:ngrid,1:nlayermx,iaer) = 2.e-6
+               nueffrad(1:ngrid,1:nlayermx,iaer) = 0.1 
+            endif
+
+
+
+            if(iaer.gt.5)then
+               print*,'Error in callcorrk, naerkind is too high (>5).'
+               print*,'The code still needs generalisation to arbitrary'
+               print*,'aerosol kinds and number.'
+               call abort
+            endif
+
+         enddo
+
+
+         if (radfixed) then
+
+	    write(*,*)"radius of H2O water particles:"
+            rad_h2o=13. ! default value
+            call getin("rad_h2o",rad_h2o)
+            write(*,*)" rad_h2o = ",rad_h2o
+
+	    write(*,*)"radius of H2O ice particles:"
+            rad_h2o_ice=35. ! default value
+            call getin("rad_h2o_ice",rad_h2o_ice)
+            write(*,*)" rad_h2o_ice = ",rad_h2o_ice
+
+	 else
+
+            write(*,*)"Number mixing ratio of H2O water particles:"
+            Nmix_h2o=1.e6 ! default value
+            call getin("Nmix_h2o",Nmix_h2o)
+            write(*,*)" Nmix_h2o = ",Nmix_h2o
+
+            write(*,*)"Number mixing ratio of H2O ice particles:"
+            Nmix_h2o_ice=Nmix_h2o ! default value
+            call getin("Nmix_h2o_ice",Nmix_h2o_ice)
+            write(*,*)" Nmix_h2o_ice = ",Nmix_h2o_ice
+	 endif
+
+      print*,'exit su_aer_radii'
+
+   end subroutine su_aer_radii
+!==================================================================
+
+
+!==================================================================
+   subroutine h2o_reffrad(ngrid,pq,pt,reffrad,nueffrad)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of liquid and icy water particles
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+      use watercommon_h, Only: T_h2O_ice_liq,T_h2O_ice_clouds,rhowater,rhowaterice
+      Implicit none
+
+      include "callkeys.h"
+      include "dimensions.h"
+      include "dimphys.h"
+      include "comcstfi.h"
+
+      integer,intent(in) :: ngrid
+
+      real, intent(in) :: pq(ngrid,nlayermx) !water ice mixing ratios (kg/kg)
+      real, intent(in) :: pt(ngrid,nlayermx) !temperature (K)
+      real, intent(out) :: reffrad(ngrid,nlayermx)      !aerosol radii
+      real, intent(out) :: nueffrad(ngrid,nlayermx) ! dispersion      
+
+      integer :: ig,l
+      real zfice ,zrad,zrad_liq,zrad_ice
+      real,external :: CBRT            
+      
+
+      if (radfixed) then
+         do l=1,nlayermx
+            do ig=1,ngrid
+               zfice = 1.0 - (pt(ig,l)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds)
+               zfice = MIN(MAX(zfice,0.0),1.0)
+               reffrad(ig,l)= rad_h2o * (1.-zfice) + rad_h2o_ice * zfice
+               nueffrad(ig,l) = coef_chaud * (1.-zfice) + coef_froid * zfice
+            enddo
+         enddo
+      else
+         do l=1,nlayermx
+            do ig=1,ngrid
+               zfice = 1.0 - (pt(ig,l)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds)
+               zfice = MIN(MAX(zfice,0.0),1.0)
+	       zrad_liq  = CBRT( 3*pq(ig,l)/(4*Nmix_h2o*pi*rhowater) )
+	       zrad_ice  = CBRT( 3*pq(ig,l)/(4*Nmix_h2o_ice*pi*rhowaterice) )
+               nueffrad(ig,l) = coef_chaud * (1.-zfice) + coef_froid * zfice
+               zrad = zrad_liq * (1.-zfice) + zrad_ice * zfice
+
+	       reffrad(ig,l) = min(max(zrad,1.e-6),1000.e-6)
+               enddo
+            enddo      
+      end if
+
+   end subroutine h2o_reffrad
+!==================================================================
+
+
+!==================================================================
+   subroutine h2o_cloudrad(ngrid,pql,reffliq,reffice)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of liquid and icy water particles
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+      use watercommon_h, Only: rhowater,rhowaterice
+      Implicit none
+
+      include "callkeys.h"
+      include "dimensions.h"
+      include "dimphys.h"
+      include "comcstfi.h"
+
+      integer,intent(in) :: ngrid
+
+      real, intent(in) :: pql(ngrid,nlayermx) !condensed water mixing ratios (kg/kg)
+      real, intent(out) :: reffliq(ngrid,nlayermx),reffice(ngrid,nlayermx)     !liquid and ice water particle radii (m)
+
+      real,external :: CBRT            
+      integer :: i,k
+
+      if (radfixed) then
+	 reffliq(1:ngrid,1:nlayermx)= rad_h2o
+	 reffice(1:ngrid,1:nlayermx)= rad_h2o_ice
+      else
+	 do k=1,nlayermx
+	   do i=1,ngrid
+	     reffliq(i,k) = CBRT(3*pql(i,k)/(4*Nmix_h2o*pi*rhowater))
+	     reffliq(i,k) = min(max(reffliq(i,k),1.e-6),1000.e-6)
+	   
+	     reffice(i,k) = CBRT(3*pql(i,k)/(4*Nmix_h2o_ice*pi*rhowaterice))
+	     reffice(i,k) = min(max(reffice(i,k),1.e-6),1000.e-6)
+	   enddo
+	 enddo
+      endif
+
+   end subroutine h2o_cloudrad
+!==================================================================
+
+
+
+!==================================================================
+   subroutine co2_reffrad(ngrid,nq,pq,reffrad)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of co2 ice particles
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+      USE tracer_h, only:igcm_co2_ice,rho_co2
+      Implicit none
+
+      include "callkeys.h"
+      include "dimensions.h"
+      include "dimphys.h"
+      include "comcstfi.h"
+
+      integer,intent(in) :: ngrid,nq
+
+      real, intent(in) :: pq(ngrid,nlayermx,nq) !tracer mixing ratios (kg/kg)
+      real, intent(out) :: reffrad(ngrid,nlayermx)      !co2 ice particles radii (K)
+
+      integer :: ig,l
+      real :: zrad   
+      real,external :: CBRT            
+            
+      
+
+      if (radfixed) then
+         reffrad(1:ngrid,1:nlayermx) = 5.e-5 ! CO2 ice
+      else
+         do l=1,nlayermx
+            do ig=1,ngrid
+               zrad = CBRT( 3*pq(ig,l,igcm_co2_ice)/(4*Nmix_co2*pi*rho_co2) )
+               reffrad(ig,l) = min(max(zrad,1.e-6),100.e-6)
+            enddo
+         enddo      
+      end if
+
+   end subroutine co2_reffrad
+!==================================================================
+
+
+
+!==================================================================
+   subroutine dust_reffrad(ngrid,reffrad)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of dust particles
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+      Implicit none
+
+      include "callkeys.h"
+      include "dimensions.h"
+      include "dimphys.h"
+
+      integer,intent(in) :: ngrid
+
+      real, intent(out) :: reffrad(ngrid,nlayermx)      !dust particles radii (K)
+            
+      reffrad(1:ngrid,1:nlayermx) = 2.e-6 ! dust
+
+   end subroutine dust_reffrad
+!==================================================================
+
+
+!==================================================================
+   subroutine h2so4_reffrad(ngrid,reffrad)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of h2so4 particles
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+      Implicit none
+
+      include "callkeys.h"
+      include "dimensions.h"
+      include "dimphys.h"
+
+      integer,intent(in) :: ngrid
+
+      real, intent(out) :: reffrad(ngrid,nlayermx)      !h2so4 particle radii (K)
+                
+      reffrad(1:ngrid,1:nlayermx) = 1.e-6 ! h2so4
+
+   end subroutine h2so4_reffrad
+!==================================================================
+
+!==================================================================
+   subroutine back2lay_reffrad(ngrid,reffrad,nlayer,pplev)
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the effective radii of particles in a 2-layer model
+!
+!     Authors
+!     -------
+!     Sandrine Guerlet (2013)
+!
+!==================================================================
+ 
+      use aerosol_mod   !! Particle sizes and boundaries of aerosol layers defined there
+     Implicit none
+
+     include "callkeys.h"
+     include "dimensions.h"
+     include "dimphys.h"
+
+      integer,intent(in) :: ngrid
+
+      real, intent(out) :: reffrad(ngrid,nlayermx)      ! particle radii 
+      REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa)
+      INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers
+      REAL :: expfactor
+      INTEGER l,ig
+            
+      reffrad(:,:)=1e-6  !!initialization, not important
+          DO ig=1,ngrid
+            DO l=1,nlayer-1
+              IF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN
+                reffrad(ig,l) = size_tropo
+              ELSEIF (pplev(ig,l) .lt. pres_top_tropo .and. pplev(ig,l) .gt. pres_bottom_strato) THEN
+                expfactor=log(size_strato/size_tropo) / log(pres_bottom_strato/pres_top_tropo)
+                reffrad(ig,l)= size_tropo*((pplev(ig,l)/pres_top_tropo)**expfactor)
+              ELSEIF (pplev(ig,l) .le. pres_bottom_strato) then
+                reffrad(ig,l) = size_strato
+              ENDIF
+            ENDDO
+          ENDDO
+
+   end subroutine back2lay_reffrad
+!==================================================================
+
+
+
+end module radii_mod
+!==================================================================
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radinc_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radinc_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/radinc_h.F90	(revision 222)
@@ -0,0 +1,98 @@
+      module radinc_h
+
+      implicit none
+
+#include "dimensions.h"
+#include "bands.h"
+#include "scatterers.h"
+
+!======================================================================
+!
+!     RADINC.H 
+!
+!     Includes for the radiation code; RADIATION LAYERS, LEVELS,
+!     number of spectral intervals. . .
+! 
+!======================================================================
+
+!     RADIATION parameters
+
+!     In radiation code, layer 1 corresponds to the stratosphere.  Level
+!     1 is the top of the stratosphere.  The dummy layer is at the same
+!     temperature as the (vertically isothermal) stratosphere, and
+!     any time it is explicitly needed, the appropriate quantities will
+!     be dealt with (aka "top". . .)
+
+!     L_NLEVRAD corresponds to the surface - i.e., the GCM Level that
+!     is at the surface.  PLEV(L_NLEVRAD) = P(J,I)+PTROP, 
+!     PLEV(2) = PTROP, PLEV(1) = ptop
+
+!     L_NLAYRAD is the number of radiation code layers
+!     L_NLEVRAD is the number of radiation code levels.  Level N is the
+!               top of layer N. 
+!
+!     L_NSPECTI is the number of IR spectral intervals
+!     L_NSPECTV is the number of Visual(or Solar) spectral intervals
+!     L_NGAUSS  is the number of Gauss points for K-coefficients
+!               GAUSS POINT 17 (aka the last one) is the special case
+!
+!     L_NPREF   is the number of reference pressures that the 
+!               k-coefficients are calculated on
+!     L_PINT    is the number of Lagrange interpolated reference
+!               pressures for the gas k-coefficients - now for a
+!		smaller p-grid than before
+!     L_NTREF   is the number of reference temperatures for the
+!               k-coefficients
+!     L_TAUMAX  is the largest optical depth - larger ones are set
+!               to this value
+!
+!     L_REFVAR  The number of different mixing ratio values for
+!               the k-coefficients. Variable component of the mixture
+!		can in princple be anything: currently it's H2O.
+!
+!     NAERKIND  The number of radiatively active aerosol types
+!
+!     NSIZEMAX  The maximum number of aerosol particle sizes
+!
+!----------------------------------------------------------------------
+
+      integer, parameter :: L_NLAYRAD  = llm
+      integer, parameter :: L_LEVELS   = 2*(llm-1)+3
+      integer, parameter :: L_NLEVRAD  = llm+1
+
+      ! These are set in sugas_corrk
+      ! [uses allocatable arrays] -- AS 12/2011
+      integer :: L_NPREF, L_NTREF, L_REFVAR, L_PINT
+
+      integer, parameter :: L_NGAUSS  = 17
+
+      integer, parameter :: L_NSPECTI = NBinfrared
+      integer, parameter :: L_NSPECTV = NBvisible
+
+!      integer, parameter :: NAERKIND  = 2 ! set in scatterers.h
+      real,    parameter :: L_TAUMAX  = 35
+
+      ! For Planck function integration: 
+      ! equivalent temperatures are 1/NTfac of these values
+      integer, parameter :: NTstar = 500
+      integer, parameter :: NTstop = 15000 ! new default for all non hot Jupiter runs
+      real*8, parameter :: NTfac = 1.0D+1  
+      !integer, parameter :: NTstar = 1000
+      !integer, parameter :: NTstop = 25000
+      !real*8,parameter :: NTfac = 5.0D+1    
+      !integer, parameter :: NTstar = 2000
+      !integer, parameter :: NTstop = 50000
+      !real*8,parameter :: NTfac = 1.0D+2    
+
+      ! Maximum number of grain size classes for aerosol convolution:
+      ! This must correspond to size of largest dataset used for aerosol 
+      ! optical properties in datagcm folder.
+      integer, parameter :: nsizemax = 60
+
+      character (len=100) :: corrkdir
+      save corrkdir
+
+      character (len=100) :: banddir
+      save banddir
+
+      end module radinc_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rain.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rain.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rain.F90	(revision 222)
@@ -0,0 +1,386 @@
+subroutine rain(ngrid,nq,ptimestep,pplev,pplay,t,pdt,pq,pdq,d_t,dqrain,dqsrain,dqssnow,rneb)
+
+
+  use ioipsl_getincom, only: getin
+  use watercommon_h, only: T_h2O_ice_liq,T_h2O_ice_clouds, RLVTT, RCPD, RCPV, RV, RVTMP2,Psat_water,Tsat_water,rhowater
+  use radii_mod, only: h2o_cloudrad
+  USE tracer_h, only: igcm_h2o_vap, igcm_h2o_ice
+  implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates H2O precipitation using simplified microphysics.
+!     
+!     Authors
+!     -------
+!     Adapted from the LMDTERRE code by R. Wordsworth (2009)
+!     Added rain vaporization in case of T>Tsat
+!     Original author Z. X. Li (1993)
+!     
+!==================================================================
+
+  include "dimensions.h"
+  include "dimphys.h"
+  include "comcstfi.h"
+  include "callkeys.h"
+
+!     Arguments
+      integer,intent(in) :: ngrid ! number of atmospherci columns
+      integer,intent(in) :: nq ! number of tracers
+      real,intent(in) :: ptimestep    ! time interval
+      real,intent(in) :: pplev(ngrid,nlayermx+1) ! inter-layer pressure (Pa)
+      real,intent(in) :: pplay(ngrid,nlayermx)   ! mid-layer pressure (Pa)
+      real,intent(in) :: t(ngrid,nlayermx) ! input temperature (K)
+      real,intent(in) :: pdt(ngrid,nlayermx) ! input tendency on temperature (K/s)      
+      real,intent(in) :: pq(ngrid,nlayermx,nq)  ! tracers (kg/kg)
+      real,intent(in) :: pdq(ngrid,nlayermx,nq) ! input tendency on tracers
+      real,intent(out) :: d_t(ngrid,nlayermx) ! temperature tendency (K/s)
+      real,intent(out) :: dqrain(ngrid,nlayermx,nq) ! tendency of H2O precipitation (kg/kg.s-1)
+      real,intent(out) :: dqsrain(ngrid)  ! rain flux at the surface (kg.m-2.s-1)
+      real,intent(out) :: dqssnow(ngrid)  ! snow flux at the surface (kg.m-2.s-1)
+      real,intent(in) :: rneb(ngrid,nlayermx) ! cloud fraction
+
+      REAL zt(ngrid,nlayermx)         ! working temperature (K)
+      REAL ql(ngrid,nlayermx)         ! liquid water (Kg/Kg)
+      REAL q(ngrid,nlayermx)          ! specific humidity (Kg/Kg)
+      REAL d_q(ngrid,nlayermx)        ! water vapor increment
+      REAL d_ql(ngrid,nlayermx)       ! liquid water / ice increment
+
+!     Subroutine options
+      REAL,PARAMETER :: seuil_neb=0.001  ! Nebulosity threshold
+
+      INTEGER,save :: precip_scheme      ! id number for precipitaion scheme
+!     for simple scheme  (precip_scheme=1)
+      REAL,SAVE :: rainthreshold                ! Precipitation threshold in simple scheme
+!     for sundquist scheme  (precip_scheme=2-3)
+      REAL,SAVE :: cloud_sat                    ! Precipitation threshold in non simple scheme
+      REAL,SAVE :: precip_timescale             ! Precipitation timescale
+!     for Boucher scheme  (precip_scheme=4)
+      REAL,SAVE :: Cboucher ! Precipitation constant in Boucher 95 scheme
+      REAL,PARAMETER :: Kboucher=1.19E8
+      REAL,SAVE :: c1
+
+      INTEGER,PARAMETER :: ninter=5
+
+      logical,save :: evap_prec ! Does the rain evaporate?
+
+!     for simple scheme
+      real,parameter :: t_crit=218.0
+      real lconvert
+
+!     Local variables
+      INTEGER i, k, n
+      REAL zqs(ngrid,nlayermx),Tsat(ngrid,nlayermx), zdelta, zcor
+      REAL zrfl(ngrid), zrfln(ngrid), zqev, zqevt
+
+      REAL zoliq(ngrid)
+      REAL zdz(ngrid),zrho(ngrid),ztot(ngrid), zrhol(ngrid)
+      REAL zchau(ngrid),zfroi(ngrid),zfrac(ngrid),zneb(ngrid)
+
+      real reffh2oliq(ngrid,nlayermx),reffh2oice(ngrid,nlayermx)
+  
+      real ttemp, ptemp, psat_tmp
+      real tnext(ngrid,nlayermx)
+
+      real l2c(ngrid,nlayermx)
+      real dWtot
+
+
+!     Indices of water vapour and water ice tracers
+      INTEGER, SAVE :: i_vap=0  ! water vapour
+      INTEGER, SAVE :: i_ice=0  ! water ice
+
+      LOGICAL,SAVE :: firstcall=.true.
+
+!     Online functions
+      REAL fallv, fall2v, zzz ! falling speed of ice crystals
+      fallv (zzz) = 3.29 * ((zzz)**0.16)
+      fall2v (zzz) =10.6 * ((zzz)**0.31)  !for use with radii
+
+
+      IF (firstcall) THEN
+
+         i_vap=igcm_h2o_vap
+         i_ice=igcm_h2o_ice
+        
+         write(*,*) "rain: i_ice=",i_ice
+         write(*,*) "      i_vap=",i_vap
+
+         PRINT*, 'in rain.F, ninter=', ninter
+         PRINT*, 'in rain.F, evap_prec=', evap_prec
+
+         write(*,*) "Precipitation scheme to use?"
+         precip_scheme=1 ! default value
+         call getin("precip_scheme",precip_scheme)
+         write(*,*) " precip_scheme = ",precip_scheme
+
+         if (precip_scheme.eq.1) then
+	    write(*,*) "rainthreshold in simple scheme?"
+            rainthreshold=0. ! default value
+            call getin("rainthreshold",rainthreshold)
+            write(*,*) " rainthreshold = ",rainthreshold
+
+         else if (precip_scheme.eq.2.or.precip_scheme.eq.3) then
+	    write(*,*) "cloud water saturation level in non simple scheme?"
+            cloud_sat=2.6e-4   ! default value
+            call getin("cloud_sat",cloud_sat)
+            write(*,*) " cloud_sat = ",cloud_sat
+	    write(*,*) "precipitation timescale in non simple scheme?"
+            precip_timescale=3600.  ! default value
+            call getin("precip_timescale",precip_timescale)
+            write(*,*) " precip_timescale = ",precip_timescale
+
+         else if (precip_scheme.eq.4) then
+	    write(*,*) "multiplicative constant in Boucher 95 precip scheme"
+            Cboucher=1.   ! default value
+            call getin("Cboucher",Cboucher)
+            write(*,*) " Cboucher = ",Cboucher	
+	    c1=1.00*1.097/rhowater*Cboucher*Kboucher  
+
+	 endif
+
+         write(*,*) "re-evaporate precipitations?"
+         evap_prec=.true. ! default value
+         call getin("evap_prec",evap_prec)
+         write(*,*) " evap_prec = ",evap_prec
+
+         firstcall = .false.
+      ENDIF ! of IF (firstcall)
+
+!     GCM -----> subroutine variables
+      DO k = 1, nlayermx
+      DO i = 1, ngrid
+
+	 zt(i,k)   = t(i,k)+pdt(i,k)*ptimestep ! a big fat bug was here
+         q(i,k)    = pq(i,k,i_vap)+pdq(i,k,i_vap)*ptimestep
+         ql(i,k)   = pq(i,k,i_ice)+pdq(i,k,i_ice)*ptimestep
+
+         !q(i,k)    = pq(i,k,i_vap)!+pdq(i,k,i_vap)
+         !ql(i,k)   = pq(i,k,i_ice)!+pdq(i,k,i_ice)
+
+         if(q(i,k).lt.0.)then ! if this is not done, we don't conserve water
+            q(i,k)=0.
+         endif
+         if(ql(i,k).lt.0.)then
+            ql(i,k)=0.
+         endif
+
+      ENDDO
+      ENDDO
+
+!     Initialise the outputs
+      d_t(1:ngrid,1:nlayermx) = 0.0
+      d_q(1:ngrid,1:nlayermx) = 0.0
+      d_ql(1:ngrid,1:nlayermx) = 0.0
+      zrfl(1:ngrid) = 0.0
+      zrfln(1:ngrid) = 0.0
+
+      ! calculate saturation mixing ratio
+      DO k = 1, nlayermx
+         DO i = 1, ngrid
+            ttemp = zt(i,k) 
+            ptemp = pplay(i,k)
+!            call watersat(ttemp,ptemp,zqs(i,k))
+	    call Psat_water(ttemp,ptemp,psat_tmp,zqs(i,k))
+	    call Tsat_water(ptemp,Tsat(i,k))
+         ENDDO
+      ENDDO
+
+      ! get column / layer conversion factor
+      DO k = 1, nlayermx
+         DO i = 1, ngrid
+            l2c(i,k)=(pplev(i,k)-pplev(i,k+1))/g
+         ENDDO
+      ENDDO
+
+      ! Vertical loop (from top to bottom)
+      ! We carry the rain with us and calculate that added by warm/cold precipitation
+      ! processes and that subtracted by evaporation at each level.
+      DO k = nlayermx, 1, -1
+
+         IF (evap_prec) THEN ! note no rneb dependence!
+            DO i = 1, ngrid
+               IF (zrfl(i) .GT.0.) THEN
+
+                  if(zt(i,k).gt.Tsat(i,k))then
+!!		     treat the case where all liquid water should boil
+		     zqev=MIN((zt(i,k)-Tsat(i,k))*RCPD*l2c(i,k)/RLVTT/ptimestep,zrfl(i))
+		     zrfl(i)=MAX(zrfl(i)-zqev,0.)
+		     d_q(i,k)=zqev/l2c(i,k)*ptimestep
+		     d_t(i,k) = - d_q(i,k) * RLVTT/RCPD
+		  else
+                     zqev = MAX (0.0, (zqs(i,k)-q(i,k)))*l2c(i,k)/ptimestep !there was a bug here
+                     zqevt= 2.0e-5*(1.0-q(i,k)/zqs(i,k))    & !default was 2.e-5
+                        *sqrt(zrfl(i))*l2c(i,k)/pplay(i,k)*zt(i,k)*R ! BC modif here
+                     zqevt = MAX (zqevt, 0.0)
+                     zqev  = MIN (zqev, zqevt)
+                     zqev  = MAX (zqev, 0.0)
+                     zrfln(i)= zrfl(i) - zqev
+		     zrfln(i)= max(zrfln(i),0.0)
+
+                     d_q(i,k) = - (zrfln(i)-zrfl(i))/l2c(i,k)*ptimestep
+                     !d_t(i,k) = d_q(i,k) * RLVTT/RCPD!/(1.0+RVTMP2*q(i,k)) ! double BC modif here
+                     d_t(i,k) = - d_q(i,k) * RLVTT/RCPD ! was bugged!
+                     zrfl(i)  = zrfln(i)
+		  end if
+		     
+
+               ENDIF ! of IF (zrfl(i) .GT.0.)
+            ENDDO
+         ENDIF ! of IF (evap_prec)
+
+         zoliq(1:ngrid) = 0.0
+
+
+         if(precip_scheme.eq.1)then
+
+            DO i = 1, ngrid
+               ttemp = zt(i,k)
+               IF (ttemp .ge. T_h2O_ice_liq) THEN
+                  lconvert=rainthreshold
+               ELSEIF (ttemp .gt. t_crit) THEN
+                  lconvert=rainthreshold*(1.- t_crit/ttemp)
+                  lconvert=MAX(0.0,lconvert)              
+               ELSE
+                  lconvert=0.
+               ENDIF
+
+
+               IF (ql(i,k).gt.1.e-9) then
+                  zneb(i)  = MAX(rneb(i,k), seuil_neb)
+                  IF ((ql(i,k)/zneb(i)).gt.lconvert)THEN ! precipitate!
+                     d_ql(i,k) = -MAX((ql(i,k)-lconvert*zneb(i)),0.0)
+                     zrfl(i)   = zrfl(i) - d_ql(i,k)*l2c(i,k)/ptimestep
+                  ENDIF
+               ENDIF
+            ENDDO
+
+         elseif (precip_scheme.ge.2) then
+          
+           DO i = 1, ngrid
+               IF (rneb(i,k).GT.0.0) THEN
+                  zoliq(i) = ql(i,k)
+                  zrho(i)  = pplay(i,k) / ( zt(i,k) * R )
+                  zdz(i)   = (pplev(i,k)-pplev(i,k+1)) / (zrho(i)*g)
+                  zfrac(i) = (zt(i,k)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds)
+                  zfrac(i) = MAX(zfrac(i), 0.0)
+                  zfrac(i) = MIN(zfrac(i), 1.0)
+                  zneb(i)  = MAX(rneb(i,k), seuil_neb)
+               ENDIF
+           ENDDO
+
+ !recalculate liquid water particle radii
+	   call h2o_cloudrad(ngrid,ql,reffh2oliq,reffh2oice)
+
+           SELECT CASE(precip_scheme)
+ !precip scheme from Sundquist 78
+ 	   CASE(2)
+
+            DO n = 1, ninter
+               DO i = 1, ngrid
+                  IF (rneb(i,k).GT.0.0) THEN
+                     ! this is the ONLY place where zneb, precip_timescale and cloud_sat are used
+
+                     zchau(i) = (ptimestep/(FLOAT(ninter)*precip_timescale)) * zoliq(i)      &
+                          * (1.0-EXP(-(zoliq(i)/zneb(i)/cloud_sat)**2)) * zfrac(i)
+                     zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+                     zfroi(i) = ptimestep/FLOAT(ninter)/zdz(i)*zoliq(i)    &
+                          *fall2v(reffh2oice(i,k)) * (1.0-zfrac(i)) ! zfroi behaves oddly...
+                     ztot(i)  = zchau(i) + zfroi(i)
+
+                     IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+                     ztot(i)  = MIN(MAX(ztot(i),0.0),zoliq(i))
+                     zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+
+                  ENDIF
+               ENDDO
+            ENDDO            
+
+ !precip scheme modified from Sundquist 78 (in q**3)
+	   CASE(3)	    
+	    
+            DO n = 1, ninter
+               DO i = 1, ngrid
+                  IF (rneb(i,k).GT.0.0) THEN
+                     ! this is the ONLY place where zneb, precip_timescale and cloud_sat are used
+
+                     zchau(i) = (ptimestep/(FLOAT(ninter)*precip_timescale*cloud_sat**2)) * (zoliq(i)/zneb(i))**3  
+                     zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+                     zfroi(i) = ptimestep/FLOAT(ninter)/zdz(i)*zoliq(i)    &
+                          *fall2v(reffh2oice(i,k)) * (1.0-zfrac(i)) ! zfroi behaves oddly...
+                     ztot(i)  = zchau(i) + zfroi(i)
+
+                     IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+                     ztot(i)  = MIN(MAX(ztot(i),0.0),zoliq(i))
+                     zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+
+                  ENDIF
+               ENDDO
+            ENDDO            
+
+ !precip scheme modified from Boucher 95
+	   CASE(4)
+
+            DO n = 1, ninter
+               DO i = 1, ngrid
+                  IF (rneb(i,k).GT.0.0) THEN
+                     ! this is the ONLY place where zneb and c1 are used
+
+                     zchau(i) = ptimestep/FLOAT(ninter) *c1* zrho(i) &
+                                    *(zoliq(i)/zneb(i))**2*reffh2oliq(i,k)*zneb(i)* zfrac(i) 
+                     zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+                     zfroi(i) = ptimestep/FLOAT(ninter)/zdz(i)*zoliq(i)    &
+                          *fall2v(reffh2oice(i,k)) * (1.0-zfrac(i)) ! zfroi behaves oddly...
+                     ztot(i)  = zchau(i) + zfroi(i)
+
+                     IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+                     ztot(i)  = MIN(MAX(ztot(i),0.0),zoliq(i))
+                     zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+
+                  ENDIF
+               ENDDO
+            ENDDO            
+
+           END SELECT ! precip_scheme 
+
+            ! Change in cloud density and surface H2O values
+            DO i = 1, ngrid
+               IF (rneb(i,k).GT.0.0) THEN
+                  d_ql(i,k) = (zoliq(i) - ql(i,k))!/ptimestep
+                  zrfl(i)   = zrfl(i)+ MAX(ql(i,k)-zoliq(i),0.0)*l2c(i,k)/ptimestep
+               ENDIF
+            ENDDO
+
+
+         endif ! if precip_scheme=1
+
+      ENDDO ! of DO k = nlayermx, 1, -1
+
+!     Rain or snow on the ground
+      DO i = 1, ngrid
+         if(zrfl(i).lt.0.0)then
+            print*,'Droplets of negative rain are falling...'
+            call abort
+         endif
+         IF (t(i,1) .LT. T_h2O_ice_liq) THEN
+            dqssnow(i) = zrfl(i)
+            dqsrain(i) = 0.0
+         ELSE
+            dqssnow(i) = 0.0
+            dqsrain(i) = zrfl(i) ! liquid water = ice for now
+         ENDIF
+      ENDDO
+
+!     now subroutine -----> GCM variables
+      if (evap_prec) then
+        dqrain(1:ngrid,1:nlayermx,i_vap)=d_q(1:ngrid,1:nlayermx)/ptimestep
+        d_t(1:ngrid,1:nlayermx)=d_t(1:ngrid,1:nlayermx)/ptimestep
+      else
+        dqrain(1:ngrid,1:nlayermx,i_vap)=0.0
+        d_t(1:ngrid,1:nlayermx)=0.0
+      endif
+      dqrain(1:ngrid,1:nlayermx,i_ice) = d_ql(1:ngrid,1:nlayermx)/ptimestep
+
+    end subroutine rain
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rcm1d.F.delete
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rcm1d.F.delete	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rcm1d.F.delete	(revision 222)
@@ -0,0 +1,925 @@
+      program rcm1d
+
+! to use  'getin'
+      use ioipsl_getincom, only: getin
+      use infotrac, only: nqtot, tname
+      use surfdat_h, only: albedodat, phisfi, dryness, watercaptag,
+     &                     zmea, zstd, zsig, zgam, zthe,
+     &                     emissiv, emisice, albedice, iceradius,
+     &                     dtemisice
+      use comdiurn_h, only: sinlat, coslat, sinlon, coslon
+!      use comsaison_h
+      use comsoil_h, only: nsoilmx, layer, mlayer, inertiedat, volcapa
+      USE comgeomfi_h, only: lati, long, area
+      use control_mod, only: day_step, ecritphy
+      use phyredem, only: physdem0,physdem1
+      use comgeomphy, only: initcomgeomphy
+      use slab_ice_h, only: noceanmx
+
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Run the physics package of the universal model in a 1D column.
+!     
+!     It can be compiled with a command like (e.g. for 25 layers):
+!                                  "makegcm -p std -d 25 rcm1d"
+!     It requires the files "callphys.def", "z2sig.def",
+!     "traceur.def", and "run.def" with a line "INCLUDEDEF=callphys.def"
+!
+!     Authors
+!     -------
+!     Frederic Hourdin
+!     R. Fournier
+!     F. Forget
+!     F. Montmessin (water ice added)
+!     R. Wordsworth
+!     B. Charnay
+!     A. Spiga
+!     J. Leconte (2012)
+!
+!==================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "dimphys.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "planete.h"
+!#include "control.h"
+#include "comvert.h"
+#include "netcdf.inc"
+#include "logic.h"
+#include "comgeom.h"
+
+c --------------------------------------------------------------
+c  Declarations
+c --------------------------------------------------------------
+c
+      INTEGER unitstart      ! unite d'ecriture de "startfi"
+      INTEGER nlayer,nlevel,nsoil,ndt
+      INTEGER ilayer,ilevel,isoil,idt,iq
+      LOGICAl firstcall,lastcall
+c
+      INTEGER day0          ! date initial (sol ; =0 a Ls=0)
+      REAL day           ! date durant le run
+      REAL time             ! time (0<time<1 ; time=0.5 a midi)
+      REAL play(nlayermx)   ! Pressure at the middle of the layers (Pa)
+      REAL plev(nlayermx+1) ! intermediate pressure levels (pa)
+      REAL psurf,tsurf(1)      
+      REAL u(nlayermx),v(nlayermx)  ! zonal, meridional wind
+      REAL gru,grv   ! prescribed "geostrophic" background wind
+      REAL temp(nlayermx)   ! temperature at the middle of the layers
+      REAL,ALLOCATABLE :: q(:,:) ! tracer mixing ratio (e.g. kg/kg)
+      REAL,ALLOCATABLE :: qsurf(:)      ! tracer surface budget (e.g. kg.m-2)
+      REAL tsoil(nsoilmx)   ! subsurface soik temperature (K)
+!      REAL co2ice           ! co2ice layer (kg.m-2) !not used anymore
+      integer :: i_co2_ice=0  ! tracer index of co2 ice
+      integer :: i_h2o_ice=0  ! tracer index of h2o ice
+      integer :: i_h2o_vap=0  ! tracer index of h2o vapor
+      REAL emis(1)             ! surface layer
+      REAL q2(nlayermx+1)   ! Turbulent Kinetic Energy
+      REAL zlay(nlayermx)   ! altitude estimee dans les couches (km)
+
+c    Physical and dynamical tandencies (e.g.  m.s-2, K/s, Pa/s)
+      REAL du(nlayermx),dv(nlayermx),dtemp(nlayermx)
+      REAL dudyn(nlayermx),dvdyn(nlayermx),dtempdyn(nlayermx)
+      REAL dpsurf    
+      REAL,ALLOCATABLE :: dq(:,:)
+      REAL,ALLOCATABLE :: dqdyn(:,:)
+
+c   Various intermediate variables
+!      INTEGER thermo
+      REAL zls
+      REAL phi(nlayermx),h(nlayermx),s(nlayermx)
+      REAL pks, ptif, w(nlayermx)
+      INTEGER ierr, aslun
+      REAL tmp1(0:nlayermx),tmp2(0:nlayermx)
+      Logical  tracerdyn
+      integer :: nq !=1 ! number of tracers
+ 
+      character*2 str2
+      character (len=7) :: str7
+
+      logical oldcompare, earthhack,saveprofile
+
+!     added by RW for zlay computation
+      real Hscale, Hmax, rho, dz
+
+!     added by RW for autozlevs computation
+      real nu, xx, pMIN, zlev, Htop
+      real logplevs(nlayermx)
+
+!     added by BC
+      REAL cloudfrac(1,nlayermx)
+      REAL hice(1),totcloudfrac(1)
+      REAL qzero1D   !initial water amount on the ground
+
+!     added by BC for ocean
+      real rnat(1)
+      REAL tslab(1,noceanmx),tsea_ice(1),sea_ice(1)
+      real pctsrf_sic(1)
+
+
+
+!     added by AS to avoid the use of adv trac common
+      character*20,allocatable :: nametrac(:)   ! name of the tracer (no need for adv trac common)
+
+      real :: latitude, longitude
+
+c=======================================================================
+c INITIALISATION
+c=======================================================================
+! initialize "serial/parallel" related stuff
+      CALL init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/))
+      call initcomgeomphy
+
+      !! those are defined in surfdat_h.F90
+      IF (.not. ALLOCATED(albedodat)) ALLOCATE(albedodat(1))
+      IF (.not. ALLOCATED(phisfi)) ALLOCATE(phisfi(1))
+      IF (.not. ALLOCATED(zmea)) ALLOCATE(zmea(1))
+      IF (.not. ALLOCATED(zstd)) ALLOCATE(zstd(1))
+      IF (.not. ALLOCATED(zsig)) ALLOCATE(zsig(1))
+      IF (.not. ALLOCATED(zgam)) ALLOCATE(zgam(1))
+      IF (.not. ALLOCATED(zthe)) ALLOCATE(zthe(1))
+      IF (.not. ALLOCATED(dryness)) ALLOCATE(dryness(1))
+      IF (.not. ALLOCATED(watercaptag)) ALLOCATE(watercaptag(1))
+      !! those are defined in comdiurn_h.F90
+      IF (.not.ALLOCATED(sinlat)) ALLOCATE(sinlat(1))
+      IF (.not.ALLOCATED(coslat)) ALLOCATE(coslat(1))
+      IF (.not.ALLOCATED(sinlon)) ALLOCATE(sinlon(1))
+      IF (.not.ALLOCATED(coslon)) ALLOCATE(coslon(1))
+      !! those are defined in comsoil_h.F90
+      IF (.not.ALLOCATED(layer)) ALLOCATE(layer(nsoilmx))
+      IF (.not.ALLOCATED(mlayer)) ALLOCATE(mlayer(0:nsoilmx-1))
+      IF (.not.ALLOCATED(inertiedat)) ALLOCATE(inertiedat(1,nsoilmx))
+      !! those are defined in comgeomfi_h
+      IF (.not. ALLOCATED(lati)) ALLOCATE(lati(1))
+      IF (.not. ALLOCATED(long)) ALLOCATE(long(1))
+      IF (.not. ALLOCATED(area)) ALLOCATE(area(1))
+
+
+      saveprofile=.false.
+      saveprofile=.true.
+
+c ----------------------------------------
+c  Default values  (corresponding to Mars)
+c ----------------------------------------
+
+      pi=2.E+0*asin(1.E+0)
+
+c     Parametres Couche limite et Turbulence 
+c     --------------------------------------
+      z0 =  1.e-2                ! surface roughness (m) ~0.01 
+      emin_turb = 1.e-6          ! energie minimale ~1.e-8
+      lmixmin = 30               ! longueur de melange ~100
+ 
+c     propriete optiques des calottes et emissivite du sol
+c     ----------------------------------------------------
+      emissiv= 0.95              ! Emissivite du sol martien ~.95
+      emisice(1)=0.95            ! Emissivite calotte nord
+      emisice(2)=0.95            ! Emissivite calotte sud  
+
+      albedice(1)=0.5            ! Albedo calotte nord
+      albedice(2)=0.5            ! Albedo calotte sud
+      iceradius(1) = 100.e-6     ! mean scat radius of CO2 snow (north)
+      iceradius(2) = 100.e-6     ! mean scat radius of CO2 snow (south)
+      dtemisice(1) = 2.          ! time scale for snow metamorphism (north)
+      dtemisice(2) = 2.          ! time scale for snow metamorphism (south
+      hybrid=.false.
+
+c ------------------------------------------------------
+c  Load parameters from "run.def" and "gases.def" 
+c ------------------------------------------------------
+
+! check if 'rcm1d.def' file is around 
+      open(90,file='rcm1d.def',status='old',form='formatted',
+     &     iostat=ierr)
+      if (ierr.ne.0) then
+        write(*,*) 'Cannot find required file "rcm1d.def"'
+        write(*,*) 'which should contain some input parameters'
+        write(*,*) ' ... might as well stop here ...'
+        stop
+      else
+        close(90)
+      endif
+
+! now, run.def is needed anyway. so we create a dummy temporary one
+! for ioipsl to work. if a run.def is already here, stop the
+! program and ask the user to do a bit of cleaning
+      open(90,file='run.def',status='old',form='formatted',
+     &     iostat=ierr)
+      if (ierr.eq.0) then
+        close(90)
+        write(*,*) 'There is already a run.def file.'
+        write(*,*) 'This is not compatible with 1D runs.'
+        write(*,*) 'Please remove the file and restart the run.'
+        write(*,*) 'Runtime parameters are supposed to be in rcm1d.def'
+        stop
+      else
+        call system('touch run.def')
+        call system("echo 'INCLUDEDEF=callphys.def' >> run.def")
+        call system("echo 'INCLUDEDEF=rcm1d.def' >> run.def")
+      endif
+
+! check if we are going to run with or without tracers
+      write(*,*) "Run with or without tracer transport ?"
+      tracer=.false. ! default value
+      call getin("tracer",tracer)
+      write(*,*) " tracer = ",tracer
+
+! OK. now that run.def has been read once -- any variable is in memory.
+! so we can dump the dummy run.def
+      call system("rm -rf run.def")
+
+! while we're at it, check if there is a 'traceur.def' file
+! and preocess it, if necessary. Otherwise initialize tracer names
+      if (tracer) then
+      ! load tracer names from file 'traceur.def'
+        open(90,file='traceur.def',status='old',form='formatted',
+     &       iostat=ierr)
+        if (ierr.eq.0) then
+          write(*,*) "rcm1d: Reading file traceur.def"
+          ! read number of tracers:
+          read(90,*,iostat=ierr) nq
+          nqtot=nq ! set value of nqtot (in infotrac module) as nq
+          if (ierr.ne.0) then
+            write(*,*) "rcm1d: error reading number of tracers"
+            write(*,*) "   (first line of traceur.def) "
+            stop
+          endif
+          if (nq>0) then
+            allocate(tname(nq))
+            allocate(q(nlayermx,nq))
+            allocate(qsurf(nq))
+            allocate(dq(nlayermx,nq))
+            allocate(dqdyn(nlayermx,nq))
+          else
+            write(*,*) "rcm1d: Error. You set tracer=.true."
+            write(*,*) "       but # of tracers in traceur.def is ",nq
+            stop
+          endif
+        
+          do iq=1,nq
+          ! minimal version, just read in the tracer names, 1 per line
+            read(90,*,iostat=ierr) tname(iq)
+            if (ierr.ne.0) then
+              write(*,*) 'rcm1d: error reading tracer names...'
+              stop
+            endif
+          enddo !of do iq=1,nq
+! check for co2_ice / h2o_ice tracers:
+         i_co2_ice=0
+         i_h2o_ice=0
+         i_h2o_vap=0
+         do iq=1,nq
+           if (tname(iq)=="co2_ice") then
+             i_co2_ice=iq
+           elseif (tname(iq)=="h2o_ice") then
+             i_h2o_ice=iq
+           elseif (tname(iq)=="h2o_vap") then
+             i_h2o_vap=iq
+           endif
+         enddo
+        else
+          write(*,*) 'Cannot find required file "traceur.def"'
+          write(*,*) ' If you want to run with tracers, I need it'
+          write(*,*) ' ... might as well stop here ...'
+          stop
+        endif
+        close(90)
+
+      else ! of if (tracer)
+        nqtot=0
+        nq=0
+        ! still, make allocations for 1 dummy tracer
+        allocate(tname(1)) 
+        allocate(qsurf(1))
+        allocate(q(nlayermx,1))
+        allocate(dq(nlayermx,1))
+      
+       ! Check that tracer boolean is compliant with number of tracers
+       ! -- otherwise there is an error (and more generally we have to be consistent)
+       if (nq .ge. 1) then
+          write(*,*) "------------------------------"
+          write(*,*) "rcm1d: You set tracer=.false."
+          write(*,*) " But set number of tracers to ",nq
+          write(*,*) " > If you want tracers, set tracer=.true."
+          write(*,*) "------------------------------"
+          stop
+       endif
+      endif ! of if (tracer)
+
+!!! We have to check that check_cpp_match is F for 1D computations
+!!! We think this check is better than make a particular case for 1D in inifis or calc_cpp_mugaz
+      check_cpp_match = .false.
+      call getin("check_cpp_match",check_cpp_match)
+      if (check_cpp_match) then
+          print*,"In 1D modeling, check_cpp_match is supposed to be F"
+          print*,"Please correct callphys.def"
+          stop
+      endif
+
+!!! GEOGRAPHICAL INITIALIZATIONS
+     !!! AREA. useless in 1D
+      area(1)=1.E+0
+      aire(1)=area(1) !JL+EM to have access to the area in the diagfi.nc files. area in comgeomfi.h and aire in comgeom.h
+     !!! GEOPOTENTIAL. useless in 1D because control by surface pressure
+      phisfi(1)=0.E+0
+     !!! LATITUDE. can be set. 
+      latitude=0 ! default value for latitude
+      PRINT *,'latitude (in degrees) ?'
+      call getin("latitude",latitude)
+      write(*,*) " latitude = ",latitude
+      latitude=latitude*pi/180.E+0
+     !!! LONGITUDE. useless in 1D.
+      longitude=0.E+0
+      longitude=longitude*pi/180.E+0
+
+!!! CALL INIFIS
+!!! - read callphys.def
+!!! - calculate sine and cosine of longitude and latitude
+!!! - calculate mugaz and cp 
+!!! NB: some operations are being done dummily in inifis in 1D
+!!! - physical constants: nevermind, things are done allright below
+!!! - physical frequency: nevermind, in inifis this is a simple print
+      cpp=1.d-7 !JL because we divide by cpp in inifis, there may be a more elegant solution
+      CALL inifis(1,llm,nq,day0,daysec,dtphys,
+     .            latitude,longitude,area,rad,g,r,cpp)
+!!! We check everything is OK.
+      PRINT *,"CHECK"
+      PRINT *,"--> mugaz = ",mugaz
+      PRINT *,"--> cpp = ",cpp
+      r = 8.314511E+0 * 1000.E+0 / mugaz
+      rcp = r / cpp
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!! PLANETARY CONSTANTS !!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      g = -99999.
+      PRINT *,'GRAVITY in m s-2 ?'
+      call getin("g",g)
+      IF (g.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED g IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> g = ",g
+      ENDIF
+
+      rad = -99999.
+      PRINT *,'PLANETARY RADIUS in m ?'
+      call getin("rad",rad)
+      ! Planetary  radius is needed to compute shadow of the rings
+      IF (rad.eq.-99999. .and. rings_shadow .eq. .true.) THEN
+          PRINT *,"STOP. I NEED rad IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> rad = ",rad
+      ENDIF
+
+      daysec = -99999.
+      PRINT *,'LENGTH OF A DAY in s ?'
+      call getin("daysec",daysec)
+      IF (daysec.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED daysec IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> daysec = ",daysec
+      ENDIF
+      omeg=4.*asin(1.)/(daysec)
+      PRINT *,"OK. FROM THIS I WORKED OUT:"
+      PRINT *,"--> omeg = ",omeg
+
+      year_day = -99999.
+      PRINT *,'LENGTH OF A YEAR in days ?'
+      call getin("year_day",year_day)
+      IF (year_day.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED year_day IN RCM1D.DEF."
+          STOP
+      ELSE 
+          PRINT *,"--> year_day = ",year_day
+      ENDIF
+
+      periastr = -99999.
+      PRINT *,'MIN DIST STAR-PLANET in AU ?'
+      call getin("periastr",periastr)
+      IF (periastr.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED periastr IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> periastr = ",periastr
+      ENDIF
+
+      apoastr = -99999.
+      PRINT *,'MAX DIST STAR-PLANET in AU ?'
+      call getin("apoastr",apoastr)
+      IF (apoastr.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED apoastr IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> apoastr = ",apoastr
+      ENDIF
+
+      peri_day = -99999.
+      PRINT *,'DATE OF PERIASTRON in days ?'
+      call getin("peri_day",peri_day)
+      IF (peri_day.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED peri_day IN RCM1D.DEF."
+          STOP
+      ELSE IF (peri_day.gt.year_day) THEN
+          PRINT *,"STOP. peri_day.gt.year_day"
+          STOP
+      ELSE  
+          PRINT *,"--> peri_day = ", peri_day
+      ENDIF 
+
+      obliquit = -99999. 
+      PRINT *,'OBLIQUITY in deg ?'
+      call getin("obliquit",obliquit)
+      IF (obliquit.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED obliquit IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> obliquit = ",obliquit
+      ENDIF 
+
+      psurf = -99999.
+      PRINT *,'SURFACE PRESSURE in Pa ?'
+      call getin("psurf",psurf)
+      IF (psurf.eq.-99999.) THEN
+          PRINT *,"STOP. I NEED psurf IN RCM1D.DEF."
+          STOP
+      ELSE
+          PRINT *,"--> psurf = ",psurf
+      ENDIF
+      !! we need reference pressures
+      pa=psurf/30.
+      preff=psurf ! these values are not needed in 1D  (are you sure JL12)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!! END PLANETARY CONSTANTS !!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c  Date et heure locale du debut du run
+c  ------------------------------------
+c    Date (en sols depuis le solstice de printemps) du debut du run
+      day0 = 0 ! default value for day0
+      write(*,*) 'Initial date (in martian sols ; =0 at Ls=0)?'
+      call getin("day0",day0)
+      day=float(day0)
+      write(*,*) " day0 = ",day0
+c  Heure de demarrage
+      time=0 ! default value for time
+      write(*,*)'Initial local time (in hours, between 0 and 24)?'
+      call getin("time",time)
+      write(*,*)" time = ",time
+      time=time/24.E+0 ! convert time (hours) to fraction of sol
+
+
+c  Discretisation (Definition de la grille et des pas de temps)
+c  --------------
+c
+      nlayer=nlayermx
+      nlevel=nlayer+1
+      nsoil=nsoilmx
+
+      day_step=48 ! default value for day_step
+      PRINT *,'Number of time steps per sol ?'
+      call getin("day_step",day_step)
+      write(*,*) " day_step = ",day_step
+
+       
+      ecritphy=day_step ! default value for ecritphy
+      PRINT *,'Nunber of steps between writediagfi ?'
+      call getin("ecritphy",ecritphy)
+      write(*,*) " ecritphy = ",ecritphy
+
+      ndt=10 ! default value for ndt
+      PRINT *,'Number of sols to run ?'
+      call getin("ndt",ndt)
+      write(*,*) " ndt = ",ndt
+
+      ndt=ndt*day_step     
+      dtphys=daysec/day_step  
+      write(*,*)"-------------------------------------"
+      write(*,*)"-------------------------------------"
+      write(*,*)"--> Physical timestep is ",dtphys
+      write(*,*)"-------------------------------------"
+      write(*,*)"-------------------------------------"
+
+c output spectrum?
+      write(*,*)"Output spectral OLR?"
+      specOLR=.false.
+      call getin("specOLR",specOLR)
+      write(*,*)" specOLR = ",specOLR
+
+c
+c  pour le schema d'ondes de gravite
+c  ---------------------------------
+      zmea(1)=0.E+0
+      zstd(1)=0.E+0
+      zsig(1)=0.E+0
+      zgam(1)=0.E+0
+      zthe(1)=0.E+0
+
+c    Initialisation des traceurs
+c    ---------------------------
+
+      DO iq=1,nq
+        DO ilayer=1,nlayer
+           q(ilayer,iq) = 0.
+        ENDDO
+      ENDDO
+     
+      DO iq=1,nq
+        qsurf(iq) = 0.
+      ENDDO
+
+      if (water) then
+         qzero1D               = 0.0
+         qsurf(i_h2o_vap) = qzero1D
+      endif
+
+c   Initialisation pour prendre en compte les vents en 1-D
+c   ------------------------------------------------------
+      ptif=2.E+0*omeg*sinlat(1)
+ 
+
+c    vent geostrophique
+      gru=10. ! default value for gru
+      PRINT *,'zonal eastward component of the geostrophic wind (m/s) ?'
+      call getin("u",gru)
+      write(*,*) " u = ",gru
+      grv=0. !default value for grv
+      PRINT *,'meridional northward component of the geostrophic',
+     &' wind (m/s) ?'
+      call getin("v",grv)
+      write(*,*) " v = ",grv
+
+c     Initialisation des vents  au premier pas de temps
+      DO ilayer=1,nlayer
+         u(ilayer)=gru
+         v(ilayer)=grv
+      ENDDO
+
+c     energie cinetique turbulente
+      DO ilevel=1,nlevel
+         q2(ilevel)=0.E+0
+      ENDDO
+
+c  emissivity / surface co2 ice ( + h2o ice??)
+c  -------------------------------------------
+      emis(1)=emissiv ! default value for emissivity
+      PRINT *,'Emissivity of bare ground ?'
+      call getin("emis",emis(1))
+      write(*,*) " emis = ",emis(1)
+      emissiv=emis(1) ! we do this so that condense_co2 sets things to the right
+                   ! value if there is no snow
+
+      if(i_co2_ice.gt.0)then
+         qsurf(i_co2_ice)=0 ! default value for co2ice
+         print*,'Initial CO2 ice on the surface (kg.m-2)'
+         call getin("co2ice",qsurf(i_co2_ice))
+         write(*,*) " co2ice = ",qsurf(i_co2_ice)
+         IF (qsurf(i_co2_ice).ge.1.E+0) THEN
+            ! if we have some CO2 ice on the surface, change emissivity
+            if (lati(1).ge.0) then ! northern hemisphere
+              emis(1)=emisice(1)
+            else ! southern hemisphere
+              emis(1)=emisice(2)
+            endif
+         ENDIF
+      endif
+
+c  calcul des pressions et altitudes en utilisant les niveaux sigma
+c  ----------------------------------------------------------------
+
+c    Vertical Coordinates
+c    """"""""""""""""""""
+      hybrid=.true.
+      PRINT *,'Hybrid coordinates ?'
+      call getin("hybrid",hybrid)
+      write(*,*) " hybrid = ", hybrid
+
+
+      autozlevs=.false.
+      PRINT *,'Auto-discretise vertical levels ?'
+      call getin("autozlevs",autozlevs)
+      write(*,*) " autozlevs = ", autozlevs
+
+      pceil = psurf / 1000.0 ! Pascals
+      PRINT *,'Ceiling pressure (Pa) ?'
+      call getin("pceil",pceil)
+      write(*,*) " pceil = ", pceil
+
+! Test of incompatibility:
+! if autozlevs used, cannot have hybrid too
+
+      if (autozlevs.and.hybrid) then
+         print*,'Cannot use autozlevs and hybrid together!'
+         call abort
+      endif
+
+      if(autozlevs)then
+            
+         open(91,file="z2sig.def",form='formatted')
+         read(91,*) Hscale
+         DO ilayer=1,nlayer-2
+            read(91,*) Hmax
+         enddo
+         close(91)
+ 
+            
+         print*,'Hmax = ',Hmax,' km'
+         print*,'Auto-shifting Hscale to:'
+!     Hscale = Hmax / log(psurf/100.0)
+         Hscale = Hmax / log(psurf/pceil)
+         print*,'Hscale = ',Hscale,' km'
+         
+! none of this matters if we dont care about zlay
+         
+      endif
+
+      call disvert
+
+         if(.not.autozlevs)then
+            ! we want only the scale height from z2sig, in order to compute zlay
+            open(91,file="z2sig.def",form='formatted')
+            read(91,*) Hscale
+            close(91)
+         endif
+
+!         if(autozlevs)then
+!            open(94,file="Hscale.temp",form='formatted')
+!            read(94,*) Hscale
+!            close(94)
+!         endif
+
+         DO ilevel=1,nlevel
+            plev(ilevel)=ap(ilevel)+psurf*bp(ilevel)
+         ENDDO
+         
+         DO ilayer=1,nlayer
+            play(ilayer)=aps(ilayer)+psurf*bps(ilayer)
+         ENDDO
+         
+
+
+         DO ilayer=1,nlayer
+!     zlay(ilayer)=-300.E+0 *r*log(play(ilayer)/plev(1))
+!     &   /g
+            zlay(ilayer)=-1000.0*Hscale*log(play(ilayer)/plev(1))
+         ENDDO
+
+!      endif
+
+c  profil de temperature au premier appel
+c  --------------------------------------
+      pks=psurf**rcp
+
+c altitude en km dans profile: on divise zlay par 1000
+      tmp1(0)=0.E+0
+      DO ilayer=1,nlayer
+        tmp1(ilayer)=zlay(ilayer)/1000.E+0
+      ENDDO
+      call profile(nlayer+1,tmp1,tmp2)
+
+      tsurf(1)=tmp2(0)
+      DO ilayer=1,nlayer
+        temp(ilayer)=tmp2(ilayer)
+      ENDDO
+      print*,"check"
+      PRINT*,"INPUT SURFACE TEMPERATURE",tsurf(1)
+      PRINT*,"INPUT TEMPERATURE PROFILE",temp
+
+c  Initialisation albedo / inertie du sol
+c  --------------------------------------
+      albedodat(1)=0.2 ! default value for albedodat
+      PRINT *,'Albedo of bare ground ?'
+      call getin("albedo",albedodat(1))
+      write(*,*) " albedo = ",albedodat(1)
+
+      inertiedat(1,1)=400 ! default value for inertiedat
+      PRINT *,'Soil thermal inertia (SI) ?'
+      call getin("inertia",inertiedat(1,1))
+      write(*,*) " inertia = ",inertiedat(1,1)
+
+! Initialize soil properties and temperature
+! ------------------------------------------
+      volcapa=1.e6 ! volumetric heat capacity
+      DO isoil=1,nsoil
+         inertiedat(1,isoil)=inertiedat(1,1) ! soil thermal inertia
+         tsoil(isoil)=tsurf(1)  ! soil temperature
+      ENDDO
+
+! Initialize depths
+! -----------------
+      do isoil=0,nsoil-1
+        mlayer(isoil)=2.e-4*(2.**(isoil-0.5)) ! mid-layer depth
+      enddo
+      do isoil=1,nsoil
+        layer(isoil)=2.e-4*(2.**(isoil-1)) ! layer depth
+      enddo
+
+
+! Initialize slab ocean
+! -----------------
+      rnat=1. ! default value for rnat
+      if(inertiedat(1,1).GE.10000.)then
+         rnat=0.
+      endif
+      if(ok_slab_ocean)then
+      rnat=0.
+      tslab(1,1)=tsurf(1)
+      tslab(1,2)=tsurf(1)
+      tsea_ice=tsurf
+      pctsrf_sic=0.
+      sea_ice=0.
+      endif
+
+
+
+c  Write a "startfi" file
+c  --------------------
+c  This file will be read during the first call to "physiq".
+c  It is needed to transfert physics variables to "physiq"...
+
+      call physdem0("startfi.nc",long,lati,nsoilmx,1,llm,nq,
+     &              dtphys,real(day0),time,area,
+     &              albedodat,inertiedat,zmea,zstd,zsig,zgam,zthe)
+      call physdem1("startfi.nc",nsoilmx,1,llm,nq,
+     &                dtphys,time,
+     &                tsurf,tsoil,emis,q2,qsurf,
+     &                cloudfrac,totcloudfrac,hice, 
+     &                rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+
+!      call physdem1(1,"startfi.nc",long,lati,nsoilmx,nq,
+!     &              dtphys,float(day0),
+!     &              time,tsurf,tsoil,emis,q2,qsurf,
+!     &              area,albedodat,inertiedat,zmea,zstd,zsig,zgam,zthe,
+!     &              cloudfrac,totcloudfrac,hice,nametrac)
+
+c=======================================================================
+c  BOUCLE TEMPORELLE DU MODELE 1D 
+c=======================================================================
+
+      firstcall=.true.
+      lastcall=.false.
+
+      DO idt=1,ndt
+        IF (idt.eq.ndt) then       !test
+         lastcall=.true.
+         call stellarlong(day*1.0,zls)
+!         write(103,*) 'Ls=',zls*180./pi
+!         write(103,*) 'Lat=', lati(1)*180./pi
+!         write(103,*) 'RunEnd - Atmos. Temp. File'
+!         write(103,*) 'RunEnd - Atmos. Temp. File'
+!         write(104,*) 'Ls=',zls*180./pi
+!         write(104,*) 'Lat=', lati(1)
+!         write(104,*) 'RunEnd - Atmos. Temp. File'
+        ENDIF
+
+c    calcul du geopotentiel 
+c     ~~~~~~~~~~~~~~~~~~~~~
+
+
+      DO ilayer=1,nlayer
+
+!              if(autozlevs)then
+!                 s(ilayer)=(play(ilayer)/psurf)**rcp
+!              else
+          s(ilayer)=(aps(ilayer)/psurf+bps(ilayer))**rcp
+!              endif
+              !s(ilayer)=(aps(ilayer)/psurf+bps(ilayer))**rcp
+          h(ilayer)=cpp*temp(ilayer)/(pks*s(ilayer))
+       ENDDO
+
+!      DO ilayer=1,nlayer
+!        s(ilayer)=(aps(ilayer)/psurf+bps(ilayer))**rcp
+!        h(ilayer)=cpp*temp(ilayer)/(pks*s(ilayer))
+!      ENDDO
+      phi(1)=pks*h(1)*(1.E+0-s(1))
+      DO ilayer=2,nlayer
+         phi(ilayer)=phi(ilayer-1)+
+     &               pks*(h(ilayer-1)+h(ilayer))*.5E+0
+     &                  *(s(ilayer-1)-s(ilayer))
+
+      ENDDO
+
+c       appel de la physique
+c       --------------------
+
+
+      CALL physiq (1,llm,nq,
+     .     tname,
+     ,     firstcall,lastcall,
+     ,     day,time,dtphys,
+     ,     plev,play,phi,
+     ,     u, v,temp, q,  
+     ,     w,
+C - sorties
+     s     du, dv, dtemp, dq,dpsurf,tracerdyn)
+
+
+c       evolution du vent : modele 1D
+c       -----------------------------
+ 
+c       la physique calcule les derivees temporelles de u et v.
+c       on y rajoute betement un effet Coriolis.
+c
+c       DO ilayer=1,nlayer
+c          du(ilayer)=du(ilayer)+ptif*(v(ilayer)-grv)
+c          dv(ilayer)=dv(ilayer)+ptif*(-u(ilayer)+gru)
+c       ENDDO
+
+c       Pour certain test : pas de coriolis a l'equateur
+c       if(lati(1).eq.0.) then
+          DO ilayer=1,nlayer
+             du(ilayer)=du(ilayer)+ (gru-u(ilayer))/1.e4
+             dv(ilayer)=dv(ilayer)+ (grv-v(ilayer))/1.e4
+          ENDDO
+c       end if
+c      
+c
+c       Calcul du temps au pas de temps suivant
+c       ---------------------------------------
+        firstcall=.false.
+        time=time+dtphys/daysec
+        IF (time.gt.1.E+0) then
+            time=time-1.E+0
+            day=day+1
+        ENDIF
+
+c       calcul des vitesses et temperature au pas de temps suivant
+c       ----------------------------------------------------------
+
+        DO ilayer=1,nlayer
+           u(ilayer)=u(ilayer)+dtphys*du(ilayer)
+           v(ilayer)=v(ilayer)+dtphys*dv(ilayer)
+           temp(ilayer)=temp(ilayer)+dtphys*dtemp(ilayer)
+        ENDDO
+
+c       calcul des pressions au pas de temps suivant
+c       ----------------------------------------------------------
+
+           psurf=psurf+dtphys*dpsurf   ! evolution de la pression de surface
+           DO ilevel=1,nlevel
+              plev(ilevel)=ap(ilevel)+psurf*bp(ilevel)
+           ENDDO
+           DO ilayer=1,nlayer
+                 play(ilayer)=aps(ilayer)+psurf*bps(ilayer)
+           ENDDO
+
+c       calcul traceur au pas de temps suivant
+c       --------------------------------------
+
+        DO iq = 1, nq
+          DO ilayer=1,nlayer
+             q(ilayer,iq)=q(ilayer,iq)+dtphys*dq(ilayer,iq)
+          ENDDO
+        END DO
+
+c    ========================================================
+c    GESTION DES SORTIE
+c    ========================================================
+      if(saveprofile)then
+         OPEN(12,file='profile.out',form='formatted')
+         write(12,*) tsurf
+         DO ilayer=1,nlayermx
+            write(12,*) temp(ilayer) !, play(ilayer) !AS12 only temp so that iprofile=8 can be used
+         ENDDO
+         CLOSE(12)
+      endif
+
+
+      ENDDO   ! fin de la boucle temporelle
+
+      write(*,*) "rcm1d: Everything is cool."
+
+c    ========================================================
+      end                       !rcm1d
+ 
+c***********************************************************************
+c***********************************************************************
+c     Subroutines Bidons utilise seulement en 3D, mais
+c     necessaire a la compilation de rcm1d en 1D
+
+      subroutine gr_fi_dyn
+      RETURN
+      END
+ 
+c***********************************************************************
+c***********************************************************************
+
+#include "../dyn3d_common/disvert.F"
+#include "../dyn3d_common/abort_gcm.F"
+#include "../dyn3d_common/diverg.F"
+#include "../dyn3d_common/grad.F"
+#include "../dyn3d_common/gr_u_scal.F"
+#include "../dyn3d_common/gr_v_scal.F"
+#include "../dyn3d_common/gr_dyn_fi.F"
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rings.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rings.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/rings.F90	(revision 222)
@@ -0,0 +1,197 @@
+SUBROUTINE rings(ngrid, declin, ptime, rad, flat, eclipse)
+! Calculates Saturn's rings shadowing
+! Includes rings opacities measured by Cassini/UVIS
+! Authors: M. Sylvestre, M. Capderou, S. Guerlet, A. Spiga
+
+    use comdiurn_h
+    use comgeomfi_h
+ 
+    implicit none   
+
+    INTEGER, INTENT(IN) :: ngrid  ! horizontal grid dimension
+    REAL, INTENT(IN) :: declin    ! latitude of the subsolar point
+    REAL, INTENT(IN) :: ptime     ! UTC time in sol fraction : ptime=0.5 at noon
+    REAL, INTENT(IN) :: rad       ! equatorial radius of the planet
+    REAL, INTENT(IN) :: flat      ! flattening of the planet 
+    REAL, DIMENSION(ngrid), INTENT(OUT) :: eclipse ! absorption of the light by the rings    
+    
+    REAL :: rpol   ! polar radius of the planet
+    REAL :: e      ! shape excentricity of the planet : (1-e*e) = (1-f)*(1-f)    
+    INTEGER, PARAMETER :: nb_a = 4 ! number of subdivisions of the A ring
+    INTEGER, PARAMETER :: nb_b = 3 ! number of subdivisions of the B ring
+    INTEGER, PARAMETER :: nb_c = 3 ! number of subdivisions of the C ring
+    INTEGER, PARAMETER :: nb_ca = 2 ! number of subdivisions in the Cassini division
+    INTEGER :: i
+
+    ! arrays for the rings. TBD: dynamical?
+    REAL, DIMENSION(nb_a) :: A_Rint ! internal radii of the subdivisions of the A ring 
+    REAL, DIMENSION(nb_a) :: A_Rext ! external radii of the subdivisions of the A ring
+    REAL, DIMENSION(nb_b) :: B_Rint ! internal radii of the subdivisions of the B ring
+    REAL, DIMENSION(nb_b) :: B_Rext ! external radii of the subdivisions of the B ring 
+    REAL, DIMENSION(nb_c) :: C_Rint ! internal radii of the subdivisions of the C ring
+    REAL, DIMENSION(nb_c) :: C_Rext ! external radii of the subdivisions of the C ring 
+    REAL, DIMENSION(nb_ca) :: Ca_Rint ! internal radii of the subdivisions of the Cassini Division
+    REAL, DIMENSION(nb_ca) :: Ca_Rext ! external radii of the subdivisions of the Cassini Division
+
+    ! Opacities of the rings : for each one we can give different opacities for each part
+    REAL, DIMENSION(nb_a) :: tau_A ! opacity of the A ring
+    REAL, DIMENSION(nb_b) :: tau_B ! opacity of the B ring
+    REAL, DIMENSION(nb_c) :: tau_C ! opacity of the C ring
+    REAL, DIMENSION(nb_ca) :: tau_Ca ! opacity of the Cassini Division 
+
+    ! Parameters used to calculate if a point is under a ring subdivision's shadow
+    REAL :: phi_S                             ! subsolar point longitude
+    REAL, PARAMETER :: pi=acos(-1.0)    
+    REAL, DIMENSION(:), ALLOCATABLE:: x, y, z ! cartesian coordinates of the points on the planet
+    REAL :: xs, ys, zs                        ! cartesian coordinates of the points of the subsolar point
+    REAL, DIMENSION(:), ALLOCATABLE :: k
+    REAL, DIMENSION(:), ALLOCATABLE :: N      ! parameter to compute cartesian coordinates on a ellipsoidal planet
+    REAL, DIMENSION(:), ALLOCATABLE :: r      ! distance at which the incident ray of sun crosses the equatorial plane
+                                              ! measured from the center of the planet   
+    REAL :: Ns                                ! (same for the subsolar point)
+   
+    ! equinox --> no shadow (AS: why is this needed?)
+    if(declin .eq. 0.) then
+        eclipse(:) = 0.
+        return 
+    endif 
+
+! 1) INITIALIZATION
+
+    ! Generic
+    rpol = (1.- flat)*rad
+    e = sqrt(2*flat - flat**2)
+    ALLOCATE(x(ngrid))
+    ALLOCATE(y(ngrid))
+    ALLOCATE(z(ngrid))
+    ALLOCATE(k(ngrid))
+    ALLOCATE(N(ngrid))
+    ALLOCATE(r(ngrid))
+    eclipse(:) = 2000.
+
+! Model of the rings with Cassini/UVIS opacities
+
+    ! Size of the rings
+    A_Rint(1) = 2.03*rad
+    A_Rext(1) = 2.06*rad
+    A_Rint(2) = 2.06*rad
+    A_Rext(2) = 2.09*rad
+    A_Rint(3) = 2.09*rad
+    A_Rext(3) = 2.12*rad
+    A_Rint(4) = 2.12*rad
+    A_Rext(4) = 2.27*rad
+
+    B_Rint(1) = 1.53*rad
+    B_Rext(1) = 1.64*rad
+    B_Rint(2) = 1.64*rad
+    B_Rext(2) = 1.83*rad
+    B_Rint(3) = 1.83*rad
+    B_Rext(3) = 1.95*rad
+    
+    C_Rint(1) = 1.24*rad
+    C_Rext(1) = 1.29*rad
+    C_Rint(2) = 1.29*rad
+    C_Rext(2) = 1.43*rad
+    C_Rint(3) = 1.43*rad
+    C_Rext(3) = 1.53*rad
+
+    Ca_Rint(1) = 1.95*rad
+    Ca_Rext(1) = 1.99*rad
+    Ca_Rint(2) = 1.99*rad
+    Ca_Rext(2) = 2.03*rad
+
+
+    ! Opacities of the rings
+    tau_A(1) = 1.24
+    tau_A(2) = 0.81
+    tau_A(3) = 0.67
+    tau_A(4) = 0.58
+                
+    tau_B(1) = 1.29
+    tau_B(2) = 5.13 
+    tau_B(3) = 2.84 
+    
+    tau_C(1) = 0.06
+    tau_C(2) = 0.10
+    tau_C(3) = 0.14
+
+    tau_Ca(1) = 0.06
+    tau_Ca(2) = 0.24
+
+    ! Convert to cartesian coordinates
+    N(:) = rad / sqrt(1-(e**2)*sinlat(:)**2)
+    x(:) = N(:)*coslat(:)*coslon(:)
+    y(:) = N(:)*coslat(:)*sinlon(:)
+    z(:) = N(:)*(1-e**2)*sinlat(:)
+
+! 2) LOCATION OF THE SUBSOLAR POINT 
+ 
+    ! subsolar longitude is deduced from time fraction ptime
+    ! SG: the minus sign is important! ... otherwise subsolar point adopts a reverse rotation
+    phi_S = -(ptime - 0.5)*2.*pi 
+!    write(*,*) 'subsol point coords : ', declin*180./pi, phi_S*180./pi
+
+    ! subsolar latitude is declin (declination of the sun)
+    ! now convert in cartesian coordinates : 
+    Ns = rad/sqrt(1-(e**2)*sin(declin)**2)
+    xs = Ns*cos(declin)*cos(phi_S)
+    ys = Ns*cos(declin)*sin(phi_S)
+    zs = Ns*(1-e**2)*sin(declin)
+
+! 3) WHERE DOES THE INCIDENT RAY OF SUN CROSS THE EQUATORIAL PLAN ?
+
+    k(:) = -z(:)/zs
+    r(:) = (k(:)*xs + x(:))**2 + (k(:)*ys + y(:))**2 
+    r(:) = sqrt(r(:))
+
+! 4) SO WHERE ARE THE SHADOW OF THESE RINGS ?
+
+    ! Summer hemisphere is not under the shadow of the rings
+    where(lati(:)*declin .gt. 0.)
+       eclipse(:) = 1000.
+    end where
+
+    ! No shadow of the rings by night
+    where(x(:)*xs + y(:)*ys + z(:)*zs .lt. 0.)
+       eclipse(:) = 1000.
+    end where
+
+    ! if the incident rays of sun cross a ring, there is a shadow
+    do i=1, nb_A 
+        where(r(:) .ge. A_Rint(i) .and. r(:) .le. A_Rext(i) .and. eclipse(:) .ne. 1000.)
+            eclipse(:) = 1. - exp(-tau_A(i)/abs(sin(declin)))
+        end where
+    end do 
+
+    do i=1, nb_B 
+        where(r(:) .ge. B_Rint(i) .and. r(:) .le. B_Rext(i) .and. eclipse(:) .ne. 1000.)
+            eclipse(:) = 1. - exp(-tau_B(i)/abs(sin(declin)))
+        end where
+    enddo
+    
+    do i=1, nb_C 
+        where(r(:) .ge. C_Rint(i) .and. r(:) .le. C_Rext(i) .and. eclipse(:) .ne. 1000.)
+            eclipse(:) = 1. - exp(-tau_C(i)/abs(sin(declin)))
+        end where
+    enddo
+
+    do i=1, nb_ca
+        where(r(:) .ge. Ca_Rint(i) .and. r(:) .le. Ca_Rext(i) .and. eclipse(:) .ne. 1000.)
+            eclipse(:) = 1. - exp(-tau_Ca(i)/abs(sin(declin)))
+        end where
+    enddo
+
+    ! At the other places and the excluded ones, eclipse is 0. 
+    where(eclipse(:) .eq. 2000. .or. eclipse(:) .eq. 1000.)
+        eclipse(:) = 0. 
+    end where 
+
+! 5) CLEAN THE PLACE
+    DEALLOCATE(x)
+    DEALLOCATE(y)
+    DEALLOCATE(z)
+    DEALLOCATE(k)
+    DEALLOCATE(N)
+    DEALLOCATE(r)
+
+END SUBROUTINE rings
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/scatterers.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/scatterers.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/scatterers.h	(revision 222)
@@ -0,0 +1,11 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'scatterers.h'
+!
+! Number of radiatively active species 
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!-----------------------------------------------------------------------
+
+      integer, parameter :: naerkind=1
+
+!-----------------------------------------------------------------------
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/scopyi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/scopyi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/scopyi.F	(revision 222)
@@ -0,0 +1,17 @@
+      subroutine scopyi(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      integer sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+      sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/setspi.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/setspi.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/setspi.F90	(revision 222)
@@ -0,0 +1,214 @@
+      subroutine setspi
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Set up spectral intervals and Planck function in the longwave.
+!     
+!     Authors
+!     ------- 
+!     Adapted from setspi in the NASA Ames radiative code by
+!     Robin Wordsworth (2009).
+!     
+!     Called by
+!     ---------
+!     callcorrk.F
+!     
+!     Calls
+!     -----
+!     none
+!     
+!==================================================================
+
+      use radinc_h,    only: L_NSPECTI,corrkdir,banddir,NTstar,NTstop,NTfac
+      use radcommon_h, only: BWNI,BLAMI,WNOI,DWNI,WAVEI,planckir,sigma
+      use datafile_mod, only: datadir
+
+      implicit none
+
+#include "callkeys.h"
+#include "comcstfi.h"
+
+      logical file_ok
+      integer nw, nt, m, mm, file_entries
+      real*8 a, b, ans, y, bpa, bma, T, dummy
+
+      character(len=30)  :: temp1
+      character(len=200) :: file_id
+      character(len=200) :: file_path
+
+!     C1 and C2 values from Goody and Yung (2nd edition)  MKS units
+!     These values lead to a "sigma" (sigma*T^4) of 5.67032E-8 W m^-2 K^-4
+
+      real*8 :: c1 = 3.741832D-16 ! W m^-2
+      real*8 :: c2 = 1.438786D-2  ! m K
+      
+      real*8 :: lastband(2), plancksum
+
+      !! used to count lines
+      integer :: nb
+      integer :: ierr
+
+      logical forceEC, planckcheck
+
+      real*8 :: x(12) = [ -0.981560634246719D0,  -0.904117256370475D0, &
+      -0.769902674194305D0,  -0.587317954286617D0,                     &
+      -0.367831498998180D0,  -0.125233408511469D0,                     &
+       0.125233408511469D0,   0.367831498998180D0,                     &
+       0.587317954286617D0,   0.769902674194305D0,                     &
+       0.904117256370475D0,   0.981560634246719D0  ]
+
+      real*8 :: w(12) = [  0.047175336386512D0,   0.106939325995318D0, &
+           0.160078328543346D0,   0.203167426723066D0,                 &
+           0.233492536538355D0,   0.249147045813403D0,                 &
+           0.249147045813403D0,   0.233492536538355D0,                 &
+           0.203167426723066D0,   0.160078328543346D0,                 &
+           0.106939325995318D0,   0.047175336386512D0  ]
+      mm=0
+
+      forceEC=.true.
+      planckcheck=.true.
+
+!=======================================================================
+!     Set up spectral bands - wavenumber [cm^(-1)]. Go from smaller to
+!     larger wavenumbers.
+
+      write(temp1,'(i2.2)') L_NSPECTI
+      !file_id='/corrk_data/' // corrkdir(1:LEN_TRIM(corrkdir)) // '/narrowbands_IR.in'
+      file_id='/corrk_data/'//trim(adjustl(banddir))//'/narrowbands_IR.in' 
+      file_path=TRIM(datadir)//TRIM(file_id)
+
+      ! check that the file exists
+      inquire(FILE=file_path,EXIST=file_ok)
+      if(.not.file_ok) then
+         write(*,*)'The file ',TRIM(file_path)
+         write(*,*)'was not found by setspi.F90, exiting.'
+         write(*,*)'Check that your path to datagcm:',trim(datadir)
+         write(*,*)' is correct. You can change it in callphys.def with:'
+         write(*,*)' datadir = /absolute/path/to/datagcm'
+         write(*,*)'Also check that the corrkdir you chose in callphys.def exists.'
+         call abort
+      endif
+    
+      nb=0
+      ierr=0
+      ! check that the file contains the right number of bands 
+      open(131,file=file_path,form='formatted')
+      read(131,*,iostat=ierr) file_entries
+      do while (ierr==0)
+        read(131,*,iostat=ierr) dummy
+!        write(*,*) 'setspi: file_entries:',dummy,'ierr=',ierr
+        if (ierr==0) nb=nb+1
+      enddo
+      close(131)
+
+      write(*,*) 'setspi: L_NSPECTI = ',L_NSPECTI, 'in the model '
+      write(*,*) '        there are   ',nb, 'entries in ',TRIM(file_path)
+      if(nb.ne.L_NSPECTI) then
+         write(*,*) 'MISMATCH !! I stop here'
+         call abort
+      endif
+
+      ! load and display the data
+      open(111,file=file_path,form='formatted')
+      read(111,*) 
+      do M=1,L_NSPECTI-1
+         read(111,*) BWNI(M)
+      end do
+      read(111,*) lastband
+      close(111)
+      BWNI(L_NSPECTI)  =lastband(1)
+      BWNI(L_NSPECTI+1)=lastband(2)
+
+      print*,''
+      print*,'setspi: IR band limits:'
+      do M=1,L_NSPECTI+1
+         print*,m,'-->',BWNI(M),' cm^-1'
+      end do
+
+!     Set up mean wavenumbers and wavenumber deltas.  Units of 
+!     wavenumbers is cm^(-1); units of wavelengths is microns.
+
+      do M=1,L_NSPECTI
+         WNOI(M)  = 0.5D0*(BWNI(M+1)+BWNI(M))
+         DWNI(M)  = BWNI(M+1)-BWNI(M)
+         WAVEI(M) = 1.0D+4/WNOI(M)
+         BLAMI(M) = 0.01D0/BWNI(M)         
+      end do
+      BLAMI(M) = 0.01D0/BWNI(M)
+!     note M=L_NSPECTI+1 after loop due to Fortran bizarreness
+
+!=======================================================================
+!     For each IR wavelength interval, compute the integral of B(T), the
+!     Planck function, divided by the wavelength interval, in cm-1.  The
+!     integration is in MKS units, the final answer is the same as the
+!     original planck.f; W m^-2 wavenumber^-1, where wavenumber is in CM^-1.
+
+      print*,''
+      print*,'setspi: Current Planck integration range:'
+      print*,'T = ',dble(NTstar)/NTfac, ' to ',dble(NTstop)/NTfac,' K.'
+
+      do NW=1,L_NSPECTI
+         a = 1.0D-2/BWNI(NW+1)
+         b = 1.0D-2/BWNI(NW)
+         bpa = (b+a)/2.0D0
+         bma = (b-a)/2.0D0
+         do nt=NTstar,NTstop
+            T   = dble(NT)/NTfac
+            ans = 0.0D0
+
+            do mm=1,12
+               y    = bma*x(mm)+bpa
+               ans  = ans + w(mm)*c1/(y**5*(exp(c2/(y*T))-1.0D0))
+            end do
+
+            planckir(NW,nt-NTstar+1) = ans*bma/(PI*DWNI(NW))
+         end do
+      end do
+         
+      ! force planck=sigma*eps*T^4 for each temperature in array
+      if(forceEC)then
+         print*,'setspi: Force F=sigma*eps*T^4 for all values of T!'
+         do nt=NTstar,NTstop
+            plancksum=0.0D0
+            T=dble(NT)/NTfac
+       
+            do NW=1,L_NSPECTI
+               plancksum=plancksum+  &
+                  planckir(NW,nt-NTstar+1)*DWNI(NW)*pi
+            end do
+
+            do NW=1,L_NSPECTI
+               planckir(NW,nt-NTstar+1)=     &
+                  planckir(NW,nt-NTstar+1)*  &
+                          sigma*(dble(nt)/NTfac)**4/plancksum
+            end do
+         end do
+      endif
+
+      if(planckcheck)then
+         ! check energy conservation at lower temperature boundary
+         plancksum=0.0D0
+         nt=NTstar
+         do NW=1,L_NSPECTI
+            plancksum=plancksum+planckir(NW,nt-NTstar+1)*DWNI(NW)*pi
+         end do
+         print*,'setspi: At lower limit:'
+         print*,'in model sig*T^4 = ',plancksum,' W m^-2'
+         print*,'actual sig*T^4   = ',sigma*(dble(nt)/NTfac)**4,' W m^-2'
+         
+         ! check energy conservation at upper temperature boundary
+         plancksum=0.0D0
+         nt=NTstop
+         do NW=1,L_NSPECTI
+            plancksum=plancksum+planckir(NW,nt-NTstar+1)*DWNI(NW)*pi
+         end do
+         print*,'setspi: At upper limit:'
+         print*,'in model sig*T^4 = ',plancksum,' W m^-2'
+         print*,'actual sig*T^4   = ',sigma*(dble(nt)/NTfac)**4,' W m^-2'
+         print*,''
+      endif
+
+      return
+    end subroutine setspi
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/setspv.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/setspv.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/setspv.F90	(revision 222)
@@ -0,0 +1,151 @@
+      subroutine setspv
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Set up spectral intervals, stellar spectrum and Rayleigh 
+!     opacity in the shortwave. 
+!     
+!     Authors
+!     ------- 
+!     Adapted from setspv in the NASA Ames radiative code by
+!     Robin Wordsworth (2009).
+!
+!     Called by
+!     ---------
+!     callcorrk.F
+!     
+!     Calls
+!     -----
+!     ave_stelspec.F
+!     
+!==================================================================
+
+      use radinc_h,    only: L_NSPECTV, corrkdir, banddir
+      use radcommon_h, only: BWNV,BLAMV,WNOV,DWNV,WAVEV, &
+                             STELLARF,TAURAY
+      use datafile_mod, only: datadir
+
+      implicit none
+
+#include "comcstfi.h"
+#include "callkeys.h"
+
+      logical file_ok
+
+      integer N, M, file_entries
+
+      character(len=30)  :: temp1
+      character(len=200) :: file_id
+      character(len=200) :: file_path
+
+      real*8 :: lastband(2)
+
+      real*8 STELLAR(L_NSPECTV)
+      real*8 sum, dummy
+
+      !! used to count lines
+      integer :: nb
+      integer :: ierr
+
+!=======================================================================
+!     Set up spectral bands - wavenumber [cm^(-1)]. Go from smaller to
+!     larger wavenumbers, the same as in the IR.
+
+      write(temp1,'(i2.2)') L_NSPECTV
+      file_id='/corrk_data/'//trim(adjustl(banddir))//'/narrowbands_VI.in' 
+      file_path=TRIM(datadir)//TRIM(file_id)
+
+      ! check that the file exists
+      inquire(FILE=file_path,EXIST=file_ok)
+      if(.not.file_ok) then
+         write(*,*)'The file ',TRIM(file_path)
+         write(*,*)'was not found by setspv.F90, exiting.'
+         write(*,*)'Check that your path to datagcm:',trim(datadir)
+         write(*,*)' is correct. You can change it in callphys.def with:'
+         write(*,*)' datadir = /absolute/path/to/datagcm'
+         write(*,*)'Also check that the corrkdir you chose in callphys.def exists.'
+         call abort
+      endif
+    
+      nb=0
+      ierr=0
+      ! check that the file contains the right number of bands 
+      open(131,file=file_path,form='formatted')
+      read(131,*,iostat=ierr) file_entries
+      do while (ierr==0)
+        read(131,*,iostat=ierr) dummy
+        if (ierr==0) nb=nb+1
+      enddo
+      close(131)
+
+      write(*,*) 'setspv: L_NSPECTV = ',L_NSPECTV, 'in the model '
+      write(*,*) '        there are   ',nb, 'entries in ',TRIM(file_path)
+      if(nb.ne.L_NSPECTV) then
+         write(*,*) 'MISMATCH !! I stop here'
+         call abort
+      endif
+
+      ! load and display the data
+      open(111,file=file_path,form='formatted')
+      read(111,*) 
+       do M=1,L_NSPECTV-1
+         read(111,*) BWNV(M)
+      end do
+      read(111,*) lastband
+      close(111)
+      BWNV(L_NSPECTV)  =lastband(1)
+      BWNV(L_NSPECTV+1)=lastband(2)
+
+
+      print*,'setspv: VI band limits:'
+      do M=1,L_NSPECTV+1
+         print*,m,'-->',BWNV(M),' cm^-1'
+      end do
+      print*,' '
+
+!     Set up mean wavenumbers and wavenumber deltas.  Units of 
+!     wavenumbers is cm^(-1); units of wavelengths is microns.
+
+      do M=1,L_NSPECTV
+         WNOV(M)  = 0.5*(BWNV(M+1)+BWNV(M))
+         DWNV(M)  = BWNV(M+1)-BWNV(M)
+         WAVEV(M) = 1.0E+4/WNOV(M)
+         BLAMV(M) = 0.01/BWNV(M)
+      end do
+      BLAMV(M) = 0.01/BWNV(M) ! wavelength in METERS for aerosol stuff
+!     note M=L_NSPECTV+1 after loop due to Fortran bizarreness
+
+!=======================================================================
+!     Set up stellar spectrum
+
+      write(*,*)'setspv: Interpolating stellar spectrum from the hires data...'
+      call ave_stelspec(STELLAR)
+
+!     Sum the stellar flux, and write out the result.  
+      sum = 0.0  
+      do N=1,L_NSPECTV
+         STELLARF(N) = STELLAR(N) * Fat1AU
+         sum         = sum+STELLARF(N)
+      end do
+      write(6,'("setspv: Stellar flux at 1 AU = ",f7.2," W m-2")') sum
+      print*,' '
+
+
+!=======================================================================
+!     Set up the wavelength independent part of the Rayleigh scattering.
+!     The pressure dependent part will be computed elsewhere (OPTCV).
+!     WAVEV is in microns.  There is no Rayleigh scattering in the IR.
+
+      if(rayleigh) then
+         call calc_rayleigh
+      else
+         print*,'setspv: No Rayleigh scattering, check for NaN in output!'
+         do N=1,L_NSPECTV
+            TAURAY(N) = 1E-16
+         end do
+      endif
+
+      RETURN
+    END subroutine setspv
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sfluxi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sfluxi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sfluxi.F	(revision 222)
@@ -0,0 +1,202 @@
+      SUBROUTINE SFLUXI(PLEV,TLEV,DTAUI,TAUCUMI,UBARI,RSFI,WNOI,DWNI,
+     *                  COSBI,WBARI,GWEIGHT,NFLUXTOPI,NFLUXTOPI_nu,
+     *                  FMNETI,fluxupi,fluxdni,fluxupi_nu,
+     *                  FZEROI,TAUGSURF)
+
+      use radinc_h
+      use radcommon_h, only: planckir, tlimit,sigma
+
+      implicit none
+
+#include "comcstfi.h"
+
+      integer NLEVRAD, L, NW, NG, NTS, NTT
+
+      real*8 TLEV(L_LEVELS), PLEV(L_LEVELS)
+      real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS)
+      real*8 FMNETI(L_NLAYRAD)
+      real*8 WNOI(L_NSPECTI), DWNI(L_NSPECTI)
+      real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+      real*8 FMUPI(L_NLEVRAD), FMDI(L_NLEVRAD)
+      real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+      real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
+      real*8 GWEIGHT(L_NGAUSS), NFLUXTOPI
+      real*8 NFLUXTOPI_nu(L_NSPECTI)
+      real*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI)
+      real*8 FTOPUP
+
+      real*8 UBARI, RSFI, TSURF, BSURF, TTOP, BTOP, TAUTOP
+      real*8 PLANCK, PLTOP
+      real*8 fluxupi(L_NLAYRAD), fluxdni(L_NLAYRAD)
+      real*8 FZEROI(L_NSPECTI)
+      real*8 taugsurf(L_NSPECTI,L_NGAUSS-1), fzero
+
+      real*8 fup_tmp(L_NSPECTI),fdn_tmp(L_NSPECTI)
+      real*8 PLANCKSUM,PLANCKREF
+
+
+C======================================================================C
+ 
+      NLEVRAD = L_NLEVRAD
+ 
+
+C     ZERO THE NET FLUXES
+    
+      NFLUXTOPI = 0.0D0
+
+      DO NW=1,L_NSPECTI
+        NFLUXTOPI_nu(NW) = 0.0D0
+        DO L=1,L_NLAYRAD
+           FLUXUPI_nu(L,NW) = 0.0D0
+
+              fup_tmp(nw)=0.0D0
+              fdn_tmp(nw)=0.0D0
+
+        END DO
+      END DO
+
+      DO L=1,L_NLAYRAD
+        FMNETI(L)  = 0.0D0
+        FLUXUPI(L) = 0.0D0
+        FLUXDNI(L) = 0.0D0
+      END DO
+ 
+C     WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE INFRARED
+C     TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL
+
+      TTOP  = TLEV(2)  ! JL12 why not (1) ???
+      TSURF = TLEV(L_LEVELS)
+
+      NTS   = int(TSURF*NTfac)-NTstar+1
+      NTT   = int(TTOP *NTfac)-NTstar+1
+
+!JL12 corrects the surface planck function so that its integral is equal to sigma Tsurf^4
+!JL12   this ensure that no flux is lost due to:
+!JL12          -truncation of the planck function at high/low wavenumber
+!JL12          -numerical error during first spectral integration
+!JL12          -discrepancy between Tsurf and NTS/NTfac
+      PLANCKSUM=0.d0
+      PLANCKREF=TSURF*TSURF
+      PLANCKREF=sigma*PLANCKREF*PLANCKREF
+      DO NW=1,L_NSPECTI
+         PLANCKSUM=PLANCKSUM+PLANCKIR(NW,NTS)*DWNI(NW)
+      ENDDO
+      PLANCKSUM=PLANCKREF/(PLANCKSUM*Pi)
+!JL12
+
+      DO 501 NW=1,L_NSPECTI
+
+C       SURFACE EMISSIONS - INDEPENDENT OF GAUSS POINTS
+        BSURF = (1.-RSFI)*PLANCKIR(NW,NTS)*PLANCKSUM !JL12 plancksum see above
+        PLTOP = PLANCKIR(NW,NTT)
+
+C  If FZEROI(NW) = 1, then the k-coefficients are zero - skip to the
+C  special Gauss point at the end.
+ 
+        FZERO = FZEROI(NW)
+        IF(FZERO.ge.0.99) goto 40
+ 
+        DO NG=1,L_NGAUSS-1
+         
+          if(TAUGSURF(NW,NG).lt. TLIMIT) then
+            fzero = fzero + (1.0D0-FZEROI(NW))*GWEIGHT(NG)
+            goto 30
+          end if
+
+C         SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE IR
+C         CALCULATE THE DOWNWELLING RADIATION AT THE TOP OF THE MODEL
+C         OR THE TOP LAYER WILL COOL TO SPACE UNPHYSICALLY
+ 
+!          TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2))
+          TAUTOP = TAUCUMI(2,NW,NG)
+          BTOP   = (1.0D0-EXP(-TAUTOP/UBARI))*PLTOP
+ 
+C         WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
+C         CALL A SUBROUTINE THAT SOLVES  FOR THE FLUX TERMS
+C         WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER 
+          
+          CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG),
+     *                TAUCUMI(1,NW,NG),
+     *                WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP,
+     *                BSURF,FTOPUP,FMUPI,FMDI)
+
+
+
+C         NOW CALCULATE THE CUMULATIVE IR NET FLUX
+
+          NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*GWEIGHT(NG)*
+     *                           (1.0D0-FZEROI(NW))
+
+c         and same thing by spectral band... (RDW)
+          NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW)
+     *      +FTOPUP*DWNI(NW)*GWEIGHT(NG)*(1.0D0-FZEROI(NW))
+
+
+          DO L=1,L_NLEVRAD-1
+
+C           CORRECT FOR THE WAVENUMBER INTERVALS
+
+            FMNETI(L)  = FMNETI(L)+(FMUPI(L)-FMDI(L))*DWNI(NW)*
+     *                              GWEIGHT(NG)*(1.0D0-FZEROI(NW))
+            FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*GWEIGHT(NG)*
+     *                                (1.0D0-FZEROI(NW))
+            FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*GWEIGHT(NG)*
+     *                                (1.0D0-FZEROI(NW))
+
+c         and same thing by spectral band... (RW)
+            FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + 
+     *                FMUPI(L)*DWNI(NW)*GWEIGHT(NG)*(1.0D0-FZEROI(NW))
+
+          END DO
+
+   30     CONTINUE
+
+       END DO       !End NGAUSS LOOP
+
+   40  CONTINUE
+
+C      SPECIAL 17th Gauss point
+
+       NG     = L_NGAUSS
+
+!       TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2))
+       TAUTOP = TAUCUMI(2,NW,NG)
+       BTOP   = (1.0D0-EXP(-TAUTOP/UBARI))*PLTOP
+
+C      WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
+C      CALL A SUBROUTINE THAT SOLVES  FOR THE FLUX TERMS
+C      WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER 
+
+
+       CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG),
+     *                TAUCUMI(1,NW,NG),
+     *                WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP,
+     *                BSURF,FTOPUP,FMUPI,FMDI)
+ 
+C      NOW CALCULATE THE CUMULATIVE IR NET FLUX
+
+       NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*FZERO
+
+c         and same thing by spectral band... (RW)
+          NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW)
+     *      +FTOPUP*DWNI(NW)*FZERO
+
+       DO L=1,L_NLEVRAD-1
+
+C        CORRECT FOR THE WAVENUMBER INTERVALS
+
+         FMNETI(L)  = FMNETI(L)+(FMUPI(L)-FMDI(L))*DWNI(NW)*FZERO
+         FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*FZERO
+         FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*FZERO
+
+c         and same thing by spectral band... (RW)
+         FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + FMUPI(L)*DWNI(NW)*FZERO
+
+       END DO
+
+  501 CONTINUE      !End Spectral Interval LOOP
+
+C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE INFRARED****
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sfluxv.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sfluxv.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sfluxv.F	(revision 222)
@@ -0,0 +1,188 @@
+      SUBROUTINE SFLUXV(DTAUV,TAUV,TAUCUMV,RSFV,DWNV,WBARV,COSBV,
+     *                  UBAR0,STEL,GWEIGHT,NFLUXTOPV,FLUXTOPVDN,
+     *                  NFLUXOUTV_nu,NFLUXGNDV_nu,
+     *                  FMNETV,FLUXUPV,FLUXDNV,FZEROV,taugsurf)
+
+      use radinc_h
+      use radcommon_h, only: tlimit
+
+      implicit none
+
+      real*8 FMNETV(L_NLAYRAD)
+      real*8 TAUCUMV(L_LEVELS,L_NSPECTV,L_NGAUSS)
+      real*8 TAUV(L_NLEVRAD,L_NSPECTV,L_NGAUSS)
+      real*8 DTAUV(L_NLAYRAD,L_NSPECTV,L_NGAUSS), DWNV(L_NSPECTV)
+      real*8 FMUPV(L_NLAYRAD), FMDV(L_NLAYRAD)
+      real*8 COSBV(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+      real*8 WBARV(L_NLAYRAD,L_NSPECTV,L_NGAUSS)
+      real*8 STEL(L_NSPECTV)
+      real*8 FLUXUPV(L_NLAYRAD), FLUXDNV(L_NLAYRAD)
+      real*8 NFLUXTOPV, FLUXUP, FLUXDN,FLUXTOPVDN
+      real*8 NFLUXOUTV_nu(L_NSPECTV)
+      real*8 NFLUXGNDV_nu(L_NSPECTV)
+      real*8 GWEIGHT(L_NGAUSS)
+
+      integer L, NG, NW, NG1,k
+      real*8  rsfv, ubar0, f0pi, btop, bsurf, taumax, eterm
+      real*8 FZEROV(L_NSPECTV)
+
+      real*8 DIFFV, DIFFVT
+      real*8 taugsurf(L_NSPECTV,L_NGAUSS-1), fzero
+
+C======================================================================C
+
+      TAUMAX = L_TAUMAX
+
+C     ZERO THE NET FLUXES
+
+      NFLUXTOPV = 0.0
+      FLUXTOPVDN = 0.0
+
+      DO NW=1,L_NSPECTV
+         NFLUXOUTV_nu(NW)=0.0
+         NFLUXGNDV_nu(NW)=0.0
+      END DO
+
+      DO L=1,L_NLAYRAD
+        FMNETV(L)  = 0.0
+        FLUXUPV(L) = 0.0
+        FLUXDNV(L) = 0.0
+      END DO
+
+      DIFFVT = 0.0
+
+C     WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE VISIBLE
+C     TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL
+
+      DO 500 NW=1,L_NSPECTV
+      
+        F0PI = STEL(NW)
+
+        FZERO = FZEROV(NW)
+        IF(FZERO.ge.0.99) goto 40
+        DO NG=1,L_NGAUSS-1
+
+          if(TAUGSURF(NW,NG) .lt. TLIMIT) then
+
+            fzero = fzero + (1.0-FZEROV(NW))*GWEIGHT(NG)
+
+            goto 30
+          end if
+
+C         SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE
+
+          BTOP  = 0.0
+          !BSURF = 0./0. ! why was this here?
+          BSURF = 0.
+C         LOOP OVER THE NTERMS BEGINNING HERE
+ 
+
+!      FACTOR    = 1.0D0 - WDEL(1)*CDEL(1)**2
+!      TAU(1)    = TDEL(1)*FACTOR
+
+
+          ETERM = MIN(TAUV(L_NLEVRAD,NW,NG),TAUMAX)
+          BSURF = RSFV*UBAR0*STEL(NW)*EXP(-ETERM/UBAR0)
+
+C         WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
+C         CALL A SUBROUTINE THAT SOLVES  FOR THE FLUX TERMS
+C         WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER
+C 
+C         FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO 
+C         RETURN FLUXES FOR A GIVEN NT
+
+
+          CALL GFLUXV(DTAUV(1,NW,NG),TAUV(1,NW,NG),TAUCUMV(1,NW,NG),
+     *                WBARV(1,NW,NG),COSBV(1,NW,NG),UBAR0,F0PI,RSFV,
+     *                BTOP,BSURF,FMUPV,FMDV,DIFFV,FLUXUP,FLUXDN)
+
+C         NOW CALCULATE THE CUMULATIVE VISIBLE NET FLUX 
+
+          NFLUXTOPV = NFLUXTOPV+(FLUXUP-FLUXDN)*GWEIGHT(NG)*
+     *                          (1.0-FZEROV(NW))
+          FLUXTOPVDN = FLUXTOPVDN+FLUXDN*GWEIGHT(NG)*
+     *                          (1.0-FZEROV(NW))
+          DO L=1,L_NLAYRAD
+            FMNETV(L)=FMNETV(L)+( FMUPV(L)-FMDV(L) )*
+     *                           GWEIGHT(NG)*(1.0-FZEROV(NW))
+            FLUXUPV(L) = FLUXUPV(L) + FMUPV(L)*GWEIGHT(NG)*
+     *                   (1.0-FZEROV(NW))
+            FLUXDNV(L) = FLUXDNV(L) + FMDV(L)*GWEIGHT(NG)*
+     *                   (1.0-FZEROV(NW))
+          END DO
+
+c     band-resolved flux leaving TOA (RDW)
+          NFLUXOUTV_nu(NW) = NFLUXOUTV_nu(NW)
+     *      +FLUXUP*GWEIGHT(NG)*(1.0-FZEROV(NW))
+
+c     band-resolved flux at ground (RDW)
+          NFLUXGNDV_nu(NW) = NFLUXGNDV_nu(NW)
+     *      +FMDV(L_NLAYRAD)*GWEIGHT(NG)*(1.0-FZEROV(NW))
+
+
+C         THE DIFFUSE COMPONENT OF THE DOWNWARD STELLAR FLUX
+
+          DIFFVT = DIFFVT + DIFFV*GWEIGHT(NG)*(1.0-FZEROV(NW))
+
+   30     CONTINUE 
+
+        END DO   ! the Gauss loop 
+
+   40   continue 
+C       Special 17th Gauss point
+
+        NG = L_NGAUSS
+
+C       SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE
+ 
+        BTOP = 0.0
+
+C       LOOP OVER THE NTERMS BEGINNING HERE
+ 
+        ETERM = MIN(TAUV(L_NLEVRAD,NW,NG),TAUMAX)
+        BSURF = RSFV*UBAR0*STEL(NW)*EXP(-ETERM/UBAR0)
+
+
+C       WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
+C       CALL A SUBROUTINE THAT SOLVES  FOR THE FLUX TERMS
+C       WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER
+C 
+C       FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO 
+C       RETURN FLUXES FOR A GIVEN NT
+
+        CALL GFLUXV(DTAUV(1,NW,NG),TAUV(1,NW,NG),TAUCUMV(1,NW,NG),
+     *              WBARV(1,NW,NG),COSBV(1,NW,NG),UBAR0,F0PI,RSFV,
+     *              BTOP,BSURF,FMUPV,FMDV,DIFFV,FLUXUP,FLUXDN)
+
+
+C       NOW CALCULATE THE CUMULATIVE VISIBLE NET FLUX 
+
+        NFLUXTOPV = NFLUXTOPV+(FLUXUP-FLUXDN)*FZERO
+        FLUXTOPVDN = FLUXTOPVDN+FLUXDN*FZERO
+        DO L=1,L_NLAYRAD
+          FMNETV(L)=FMNETV(L)+( FMUPV(L)-FMDV(L) )*FZERO
+          FLUXUPV(L) = FLUXUPV(L) + FMUPV(L)*FZERO
+          FLUXDNV(L) = FLUXDNV(L) + FMDV(L)*FZERO
+        END DO
+
+c     band-resolved flux leaving TOA (RDW)
+          NFLUXOUTV_nu(NW) = NFLUXOUTV_nu(NW)
+     *      +FLUXUP*FZERO
+
+c     band-resolved flux at ground (RDW)
+          NFLUXGNDV_nu(NW) = NFLUXGNDV_nu(NW)+FMDV(L_NLAYRAD)*FZERO
+
+
+C       THE DIFFUSE COMPONENT OF THE DOWNWARD STELLAR FLUX
+
+        DIFFVT = DIFFVT + DIFFV*FZERO
+
+
+  500 CONTINUE
+
+
+C     *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE VISIBLE*****
+
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/slab_ice_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/slab_ice_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/slab_ice_h.F90	(revision 222)
@@ -0,0 +1,39 @@
+      module slab_ice_h
+
+      implicit none
+
+! noceanmx : number of oceanic layers
+      integer, parameter :: noceanmx = 2 ! number of oceanic layers
+
+      real, parameter :: ice_cap=2.05e+03       ! J/kg/K
+      real, parameter :: ice_den=945.0          ! kg/m3
+      real, parameter :: ice_lat=0.334e+05      ! J/kg
+      real, parameter :: ice_cond=2.1           ! W/m/K
+      real, parameter :: alb_ice_min=0.2       
+      real, parameter :: alb_ice_max=0.65 
+      real, parameter :: alb_ocean=0.07
+      real, parameter :: ice_frac_min=0.0001
+      real, parameter :: ice_frac_max=1.!0.9999
+      real, parameter :: h_alb_ice=0.5*ice_den   !m->kg/m2
+      real, parameter :: h_ice_thin=0.2*ice_den
+      real, parameter :: h_ice_thick=2.5*ice_den
+      real, parameter :: h_ice_min=0.000001*ice_den
+      real, parameter :: h_ice_max=10000.0
+
+      real, parameter :: capcalocean=50.*4.228e+06!121635.0
+      real, parameter :: capcalseaice=5.1444e+06*0.15
+      real, parameter :: capcalsno=2.3867e+06*0.15
+
+      real, parameter :: epsfra=1.0E-05
+      real, parameter :: soil_hdiff=25000.0
+
+!      real, parameter :: calice=1.0/(5.1444e+06*0.15)
+!      real, parameter :: tau_gl=86400.*5.
+!      real, parameter :: calsno=1./(2.3867e+06*0.15)
+
+
+
+
+
+
+      end module slab_ice_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/soil.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/soil.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/soil.F	(revision 222)
@@ -0,0 +1,187 @@
+      subroutine soil(ngrid,nsoil,firstcall,lastcall,
+     &          therm_i,
+     &          timestep,tsurf,tsoil,
+     &          capcal,fluxgrd)
+
+      use comsoil_h, only: layer, mlayer, volcapa
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!  Author: Ehouarn Millour
+!
+!  Purpose: Compute soil temperature using an implict 1st order scheme
+!  
+!  Note: depths of layers and mid-layers, soil thermal inertia and 
+!        heat capacity are commons in comsoil.h
+!-----------------------------------------------------------------------
+
+      include "dimensions.h"
+      include "dimphys.h"
+
+
+c-----------------------------------------------------------------------
+!  arguments
+!  ---------
+!  inputs:
+      integer,intent(in) :: ngrid	! number of (horizontal) grid-points 
+      integer,intent(in) :: nsoil	! number of soil layers 
+      logical,intent(in) :: firstcall ! identifier for initialization call 
+      logical,intent(in) :: lastcall
+      real,intent(in) :: therm_i(ngrid,nsoil) ! thermal inertia
+      real,intent(in) :: timestep	    ! time step
+      real,intent(in) :: tsurf(ngrid)   ! surface temperature
+! outputs:
+      real,intent(out) :: tsoil(ngrid,nsoil) ! soil (mid-layer) temperature
+      real,intent(out) :: capcal(ngrid) ! surface specific heat
+      real,intent(out) :: fluxgrd(ngrid) ! surface diffusive heat flux
+
+! local saved variables:
+      real,dimension(:,:),save,allocatable :: mthermdiff ! mid-layer thermal diffusivity
+      real,dimension(:,:),save,allocatable :: thermdiff ! inter-layer thermal diffusivity
+      real,dimension(:),save,allocatable :: coefq ! q_{k+1/2} coefficients
+      real,dimension(:,:),save,allocatable :: coefd ! d_k coefficients
+      real,dimension(:,:),save,allocatable :: alph ! alpha_k coefficients
+      real,dimension(:,:),save,allocatable :: beta ! beta_k coefficients
+      real,save :: mu
+            
+! local variables:
+      integer ig,ik
+
+
+! 0. Initialisations and preprocessing step
+      if (firstcall) then
+      ! note: firstcall is set to .true. or .false. by the caller
+      !       and not changed by soil.F 
+
+      ALLOCATE(mthermdiff(ngrid,0:nsoil-1)) ! mid-layer thermal diffusivity
+      ALLOCATE(thermdiff(ngrid,nsoil-1))    ! inter-layer thermal diffusivity
+      ALLOCATE(coefq(0:nsoil-1))              ! q_{k+1/2} coefficients
+      ALLOCATE(coefd(ngrid,nsoil-1))        ! d_k coefficients
+      ALLOCATE(alph(ngrid,nsoil-1))         ! alpha_k coefficients
+      ALLOCATE(beta(ngrid,nsoil-1))         ! beta_k coefficients
+
+! 0.1 Build mthermdiff(:), the mid-layer thermal diffusivities
+      do ig=1,ngrid
+        do ik=0,nsoil-1
+	  mthermdiff(ig,ik)=therm_i(ig,ik+1)*therm_i(ig,ik+1)/volcapa
+!	  write(*,*),'soil: ik: ',ik,' mthermdiff:',mthermdiff(ig,ik)
+	enddo
+      enddo
+
+! 0.2 Build thermdiff(:), the "interlayer" thermal diffusivities
+      do ig=1,ngrid
+        do ik=1,nsoil-1
+      thermdiff(ig,ik)=((layer(ik)-mlayer(ik-1))*mthermdiff(ig,ik)
+     &                +(mlayer(ik)-layer(ik))*mthermdiff(ig,ik-1))
+     &                    /(mlayer(ik)-mlayer(ik-1))
+!	write(*,*),'soil: ik: ',ik,' thermdiff:',thermdiff(ig,ik)
+	enddo
+      enddo
+
+! 0.3 Build coefficients mu, q_{k+1/2}, d_k, alpha_k and capcal
+      ! mu
+      mu=mlayer(0)/(mlayer(1)-mlayer(0))
+
+      ! q_{1/2}
+      coefq(0)=volcapa*layer(1)/timestep
+	! q_{k+1/2}
+        do ik=1,nsoil-1
+          coefq(ik)=volcapa*(layer(ik+1)-layer(ik))
+     &                 /timestep
+	enddo
+
+      do ig=1,ngrid
+	! d_k
+	do ik=1,nsoil-1
+	  coefd(ig,ik)=thermdiff(ig,ik)/(mlayer(ik)-mlayer(ik-1))
+	enddo
+	
+	! alph_{N-1}
+	alph(ig,nsoil-1)=coefd(ig,nsoil-1)/
+     &                  (coefq(nsoil-1)+coefd(ig,nsoil-1))
+        ! alph_k
+        do ik=nsoil-2,1,-1
+	  alph(ig,ik)=coefd(ig,ik)/(coefq(ik)+coefd(ig,ik+1)*
+     &                              (1.-alph(ig,ik+1))+coefd(ig,ik))
+	enddo
+
+        ! capcal
+! Cstar
+        capcal(ig)=volcapa*layer(1)+
+     &              (thermdiff(ig,1)/(mlayer(1)-mlayer(0)))*
+     &              (timestep*(1.-alph(ig,1)))
+! Cs
+        capcal(ig)=capcal(ig)/(1.+mu*(1.0-alph(ig,1))*
+     &                         thermdiff(ig,1)/mthermdiff(ig,0))
+      !write(*,*)'soil: ig=',ig,' capcal(ig)=',capcal(ig)
+      enddo ! of do ig=1,ngrid
+            
+      else ! of if (firstcall)
+
+
+!  1. Compute soil temperatures
+! First layer:
+      do ig=1,ngrid
+        tsoil(ig,1)=(tsurf(ig)+mu*beta(ig,1)*
+     &                         thermdiff(ig,1)/mthermdiff(ig,0))/
+     &              (1.+mu*(1.0-alph(ig,1))*
+     &               thermdiff(ig,1)/mthermdiff(ig,0))
+      enddo
+! Other layers:
+      do ik=1,nsoil-1
+        do ig=1,ngrid
+	  tsoil(ig,ik+1)=alph(ig,ik)*tsoil(ig,ik)+beta(ig,ik)
+	enddo
+      enddo
+      
+      endif! of if (firstcall)
+
+!  2. Compute beta coefficients (preprocessing for next time step)
+! Bottom layer, beta_{N-1}
+      do ig=1,ngrid
+        beta(ig,nsoil-1)=coefq(nsoil-1)*tsoil(ig,nsoil)
+     &                   /(coefq(nsoil-1)+coefd(ig,nsoil-1))
+      enddo
+! Other layers
+      do ik=nsoil-2,1,-1
+        do ig=1,ngrid
+	  beta(ig,ik)=(coefq(ik)*tsoil(ig,ik+1)+
+     &                 coefd(ig,ik+1)*beta(ig,ik+1))/
+     &                 (coefq(ik)+coefd(ig,ik+1)*(1.0-alph(ig,ik+1))
+     &                  +coefd(ig,ik))
+	enddo
+      enddo
+
+
+!  3. Compute surface diffusive flux & calorific capacity
+      do ig=1,ngrid
+! Cstar
+!        capcal(ig)=volcapa(ig,1)*layer(ig,1)+
+!     &              (thermdiff(ig,1)/(mlayer(ig,1)-mlayer(ig,0)))*
+!     &              (timestep*(1.-alph(ig,1)))
+! Fstar
+
+!         print*,'this far in soil 1'
+!         print*,'thermdiff=',thermdiff(ig,1)
+!         print*,'mlayer=',mlayer
+!         print*,'beta=',beta(ig,1)
+!         print*,'alph=',alph(ig,1)
+!         print*,'tsoil=',tsoil(ig,1)
+
+        fluxgrd(ig)=(thermdiff(ig,1)/(mlayer(1)-mlayer(0)))*
+     &              (beta(ig,1)+(alph(ig,1)-1.0)*tsoil(ig,1))
+
+!        mu=mlayer(ig,0)/(mlayer(ig,1)-mlayer(ig,0))
+!        capcal(ig)=capcal(ig)/(1.+mu*(1.0-alph(ig,1))*
+!     &                         thermdiff(ig,1)/mthermdiff(ig,0))
+! Fs
+        fluxgrd(ig)=fluxgrd(ig)+(capcal(ig)/timestep)*
+     &              (tsoil(ig,1)*(1.+mu*(1.0-alph(ig,1))*
+     &                         thermdiff(ig,1)/mthermdiff(ig,0))
+     &               -tsurf(ig)-mu*beta(ig,1)*
+     &                          thermdiff(ig,1)/mthermdiff(ig,0))
+      enddo
+
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/soil_settings.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/soil_settings.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/soil_settings.F	(revision 222)
@@ -0,0 +1,328 @@
+      subroutine soil_settings(nid,ngrid,nsoil,tsurf,tsoil,indextime)
+
+!      use netcdf
+      use comsoil_h, only: layer, mlayer, inertiedat, volcapa
+      use iostart, only: inquire_field_ndims, get_var, get_field,
+     &                   inquire_field, inquire_dimension_length
+      implicit none
+
+!======================================================================
+!  Author: Ehouarn Millour (07/2006)
+!
+!  Purpose: Read and/or initialise soil depths and properties
+!
+! Modifications: Aug.2010 EM : use NetCDF90 to load variables (enables using
+!                      r4 or r8 restarts independently of having compiled
+!                      the GCM in r4 or r8)
+!                June 2013 TN : Possibility to read files with a time axis
+!
+!
+!  This subroutine reads from a NetCDF file (opened by the caller)
+!  of "startfi.nc" format.
+!  The various actions and variable read/initialized are:
+!  1. Check out the number of soil layers (in datafile); if it isn't equal
+!     to nsoil, then some interpolation will be required
+!     Also check if data in file "startfi.nc" is in older format (ie:
+!     thermal inertia was depth-independent; and there was no "depth"
+!     coordinate.
+!     Read/build layer (and midlayer) depths
+!  2. Read volumetric specific heat (or initialise it to default value)
+!  3. Read Thermal inertia
+!  4. Read soil temperatures
+!  5. Interpolate thermal inertia and temperature on the new grid, if
+!     necessary
+!======================================================================
+
+!======================================================================
+!  arguments
+!  ---------
+!  inputs:
+      integer,intent(in) :: nid	! Input Netcdf file ID 
+      integer,intent(in) :: ngrid	! # of horizontal grid points
+      integer,intent(in) :: nsoil	! # of soil layers
+      real,intent(in) :: tsurf(ngrid)   ! surface temperature
+      integer,intent(in) :: indextime	! position on time axis
+!  output:
+      real,intent(out) :: tsoil(ngrid,nsoil)	! soil temperature
+
+!======================================================================
+! local variables:
+      integer ierr	! status (returned by NetCDF functions)
+      integer nvarid	! ID of NetCDF variable
+      integer dimid	! ID of NetCDF dimension
+      integer dimlen	! length along the "depth" dimension
+      integer ndims	! # of dimensions of read <inertiedat> data
+      integer ig,iloop	! loop counters
+      
+      integer edges(3),corner(3) ! to read a specific time
+
+      logical :: olddepthdef=.false. ! flag
+      logical :: interpol=.false. ! flag: true if interpolation will be requiered
+
+      ! to store "old" values
+      real,dimension(:),allocatable :: surfinertia !surface thermal inertia
+      real,dimension(:),allocatable :: oldmlayer
+      real,dimension(:,:),allocatable :: oldinertiedat
+      real,dimension(:,:),allocatable :: oldtsoil
+      ! for interpolation
+      real,dimension(:),allocatable :: oldgrid
+      real,dimension(:),allocatable :: oldval
+      real,dimension(:),allocatable :: newval
+
+      real alpha,lay1 ! coefficients for building layers
+      real xmin,xmax ! to display min and max of a field
+
+      real,parameter :: default_volcapa=1.e6
+
+      logical :: found,ok
+!======================================================================
+! 1. Depth coordinate
+! -------------------
+! 1.1 Start by reading how many layers of soil there are
+        dimlen=inquire_dimension_length("subsurface_layers")
+
+        if (dimlen.ne.nsoil) then
+          write(*,*)'soil_settings: Interpolation of soil temperature ',
+     &              'and thermal inertia will be required!'
+	! if dimlen doesn't match nsoil, then interpolation of
+	! soil temperatures and thermal inertia will be requiered
+	  interpol=.true.
+	endif
+! 1.2 Find out the # of dimensions <inertiedat> was defined as using
+      ndims=inquire_field_ndims("inertiedat")
+! 1.3 Read depths values or set olddepthdef flag and values
+      if (ndims.eq.1) then ! we know that there is none
+        write(*,*)'soil_settings: no <soildepth> field expected'
+	write(*,*)'building one mimicking old definitions'
+        olddepthdef=.true.
+	interpol=.true.
+        ! allocate oldmlayer
+        if (.not.allocated(oldmlayer)) then
+          allocate(oldmlayer(dimlen),stat=ierr)
+          if (ierr.ne.0) then
+            write(*,*) 'soil_settings: failed allocation of oldmlayer!'
+            stop
+          endif
+        endif
+	do iloop=1,dimlen
+	  oldmlayer(iloop)=sqrt(887.75/3.14)*((2.**(iloop-0.5))-1.)
+	enddo
+      else ! Look for depth 
+        ! read <depth> coordinate
+        if (interpol) then !put values in oldmlayer
+          call get_var("soildepth",oldmlayer,found)
+          if (.not.found) then
+            write(*,*)'soil_settings: Problem while reading <soildepth>'
+          endif
+        else ! put values in mlayer
+          call get_var("soildepth",mlayer,found)
+          print*,"mlayer",mlayer
+	  if (.not.found) then
+            write(*,*)'soil_settings: Problem while reading <soildepth>'
+          endif
+        endif !of if (interpol)
+      endif !of if (ndims.eq.1)
+! 1.4 Build mlayer(), if necessary
+      if (interpol) then
+      ! default mlayer distribution, following a power law:
+      !  mlayer(k)=lay1*alpha**(k-1/2)
+        lay1=2.e-4
+	alpha=2
+        do iloop=0,nsoil-1
+	  mlayer(iloop)=lay1*(alpha**(iloop-0.5))
+        enddo
+      endif
+! 1.5 Build layer(); following the same law as mlayer()
+      ! Assuming layer distribution follows mid-layer law:
+      ! layer(k)=lay1*alpha**(k-1)
+      lay1=sqrt(mlayer(0)*mlayer(1))
+      alpha=mlayer(1)/mlayer(0)
+      do iloop=1,nsoil
+        layer(iloop)=lay1*(alpha**(iloop-1))
+      enddo
+! 2. Volumetric heat capacity (note: it is declared in comsoil_h)
+! ---------------------------
+! "volcapa" is (so far) 0D and written in "controle" table of startfi file 
+! volcapa is read or set when "controle" is read (see tabfi.F)
+! Just in case, we check here that it is not zero. If it is, we
+! set it to "default_volcapa"
+
+      if (volcapa.le.0.0) then
+        write(*,*)'soil_settings: Warning, volcapa = ',volcapa
+	write(*,*)'               That doesn t seem right'
+        write(*,*)'        Initializing Volumetric heat capacity to ',
+     &             default_volcapa
+	volcapa=default_volcapa
+      endif
+
+! 3. Thermal inertia (note: it is declared in comsoil_h)
+! ------------------
+! 3.1 Look (again) for thermal inertia data (to reset nvarid)
+
+! 3.2 Knowing the # of dimensions <inertidat> was defined as using,
+!     read/build thermal inertia
+
+      if (ndims.eq.1) then ! "old 2D-surface" format
+       write(*,*)'soil_settings: Thermal inertia is only given as surfac
+     &e data!'
+       ! Read Surface thermal inertia
+       allocate(surfinertia(ngrid))
+       call get_field("inertiedat",surfinertia,found)
+       if (.not.found) then
+         write(*,*) "soil_settings: Failed loading <inertiedat>"
+         call abort
+       endif
+       
+       write(*,*)' => Building soil thermal inertia (using reference sur
+     &face thermal inertia)'
+       do iloop=1,nsoil
+         inertiedat(:,iloop)=surfinertia(:)
+       enddo
+       deallocate(surfinertia)
+
+      else ! "3D surface+depth" format
+       if (interpol) then ! put values in oldinertiedat
+         if (.not.allocated(oldinertiedat)) then
+           allocate(oldinertiedat(ngrid,dimlen),stat=ierr)
+           if (ierr.ne.0) then
+            write(*,*) 'soil_settings: failed allocation of ',
+     &                 'oldinertiedat!'
+            stop
+           endif
+         endif ! of if (.not.allocated(oldinertiedat))
+        call get_field("inertiedat",oldinertiedat,found)
+        if (.not.found) then
+          write(*,*) "soil_settings: Failed loading <inertiedat>"
+          call abort
+        endif
+       else ! put values in therm_i
+         call get_field("inertiedat",inertiedat,found)
+         if (.not.found) then
+           write(*,*) "soil_settings: Failed loading <inertiedat>"
+           call abort
+         endif
+!        endif
+       endif ! of if (interpol)
+      endif ! of if (ndims.eq.1)
+      
+! 4. Read soil temperatures
+! -------------------------
+!      ierr=nf90_inq_varid(nid,"tsoil",nvarid)
+      ok=inquire_field("tsoil")
+!      if (ierr.ne.nf90_noerr) then
+      if (.not.ok) then
+        write(*,*)'soil_settings: Field <tsoil> not found!'
+	write(*,*)' => Building <tsoil> from surface values <tsurf>'
+	do iloop=1,nsoil
+	  tsoil(:,iloop)=tsurf(:)
+	enddo
+      else ! <tsoil> found
+       if (interpol) then ! put values in oldtsoil
+         if (.not.allocated(oldtsoil)) then
+           allocate(oldtsoil(ngrid,dimlen),stat=ierr)
+           if (ierr.ne.0) then
+             write(*,*) 'soil_settings: failed allocation of ',
+     &                  'oldtsoil!'
+             stop
+           endif
+         endif
+         call get_field("tsoil",oldtsoil,found)
+         if (.not.found) then
+           write(*,*) "soil_settings: Failed loading <tsoil>"
+           call abort
+         endif
+       else ! put values in tsoil
+         call get_field("tsoil",tsoil,found,timeindex=indextime)
+         if (.not.found) then
+           write(*,*) "soil_settings: Failed loading <tsoil>"
+           call abort
+         endif
+       endif ! of if (interpol) 
+      endif! of if (.not.ok)
+
+! 5. If necessary, interpolate soil temperatures and thermal inertias
+! -------------------------------------------------------------------
+      if (olddepthdef) then
+      ! tsoil needs to be interpolated, but not therm_i
+        allocate(oldgrid(dimlen+1))
+        allocate(oldval(dimlen+1))
+	allocate(newval(nsoil))
+
+        do ig=1,ngrid
+	  ! copy values
+	  oldval(1)=tsurf(ig)
+	  oldval(2:dimlen+1)=oldtsoil(ig,1:dimlen)
+	  ! build vertical coordinate
+	  oldgrid(1)=0. ! ground
+	  oldgrid(2:dimlen+1)=oldmlayer(1:dimlen)*
+     &                (inertiedat(ig,1)/volcapa)
+	  ! interpolate
+	  call interp_line(oldgrid,oldval,dimlen+1,mlayer,newval,nsoil)
+	  ! copy result in tsoil
+	  tsoil(ig,:)=newval(:)
+	enddo
+
+        ! cleanup
+	deallocate(oldgrid)
+	deallocate(oldval)
+	deallocate(newval)
+	interpol=.false. ! no need for interpolation any more      
+      endif !of if (olddepthdef)
+
+      if (interpol) then
+      write(*,*)'soil_settings: Vertical interpolation along new grid'
+      ! interpolate soil temperatures and thermal inertias
+        if (.not.allocated(oldgrid)) then
+          allocate(oldgrid(dimlen+1))
+          allocate(oldval(dimlen+1))
+	  allocate(newval(nsoil))
+        endif
+
+      ! thermal inertia
+        do ig=1,ngrid
+	  ! copy data
+	  oldval(1:dimlen)=oldinertiedat(ig,dimlen)
+	  ! interpolate
+	  call interp_line(oldmlayer,oldval,dimlen,mlayer,newval,nsoil)
+	  !copy result in inertiedat
+	  inertiedat(ig,:)=newval(:)
+	enddo
+        
+      ! soil temperature
+        ! vertical coordinate
+	oldgrid(1)=0.0
+	oldgrid(2:dimlen+1)=oldmlayer(1:dimlen)
+        do ig=1,ngrid
+	  ! data
+	  oldval(1)=tsurf(ig)
+	  oldval(2:dimlen+1)=oldtsoil(ig,1:dimlen)
+	  ! interpolate
+	  call interp_line(oldgrid,oldval,dimlen+1,mlayer,newval,nsoil)
+	  ! copy result in inertiedat
+	  tsoil(ig,:)=newval(:)
+	enddo
+	
+	!cleanup
+        deallocate(oldgrid)
+	deallocate(oldval)
+	deallocate(newval)
+	deallocate(oldinertiedat)
+	deallocate(oldtsoil)
+      endif ! of if (interpol)
+      
+! 6. Report min and max values of soil temperatures and thermal inertias
+! ----------------------------------------------------------------------
+
+      write(*,*)
+      write(*,*)'Soil volumetric heat capacity:',volcapa
+
+      xmin = MINVAL(inertiedat)
+      xmax = MAXVAL(inertiedat)
+      write(*,*)'Soil thermal inertia <inertiedat>:',xmin,xmax
+
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(tsoil)
+      xmax = MAXVAL(tsoil)
+      write(*,*)'Soil temperature <tsoil>:',xmin,xmax
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/start2archive.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/start2archive.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/start2archive.F	(revision 222)
@@ -0,0 +1,517 @@
+c=======================================================================
+      PROGRAM start2archive
+c=======================================================================
+c
+c
+c   Date:    01/1997
+c   ----
+c
+c
+c   Objet:   Passage des  fichiers netcdf d'etat initial "start" et
+c   -----    "startfi" a un fichier netcdf unique "start_archive" 
+c
+c  "start_archive" est une banque d'etats initiaux:
+c  On peut stocker plusieurs etats initiaux dans un meme fichier "start_archive"
+c    (Veiller dans ce cas avoir un day_ini different pour chacun des start)
+c 
+c
+c
+c=======================================================================
+
+      use infotrac, only: iniadvtrac, nqtot, tname
+      USE comsoil_h
+      USE comgeomfi_h, ONLY: lati, long, area
+!      use control_mod
+      use comgeomphy, only: initcomgeomphy
+      use slab_ice_h, only: noceanmx
+! to use  'getin'
+      USE ioipsl_getincom
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+!#include "control.h"
+#include "ener.h"
+
+#include "dimphys.h"
+#include "planete.h"
+!#include"advtrac.h"
+#include "netcdf.inc"
+#include "callkeys.h"
+c-----------------------------------------------------------------------
+c   Declarations
+c-----------------------------------------------------------------------
+
+c variables dynamiques du GCM
+c -----------------------------
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                    ! temperature potentielle 
+      REAL,ALLOCATABLE :: q(:,:,:)   ! champs advectes
+      REAL pks(ip1jmp1)                      ! exner (f pour filtre)
+      REAL pk(ip1jmp1,llm)
+      REAL pkf(ip1jmp1,llm)
+      REAL beta(iip1,jjp1,llm)
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL masse(ip1jmp1,llm)                ! masse de l'atmosphere
+      REAL ps(ip1jmp1)                       ! pression au sol
+      REAL p3d(iip1, jjp1, llm+1)            ! pression aux interfaces
+      
+c Variable Physiques (grille physique)
+c ------------------------------------
+      REAL tsurf(ngridmx)	! Surface temperature
+      REAL tsoil(ngridmx,nsoilmx) ! Soil temperature
+      REAL co2ice(ngridmx)	! CO2 ice layer
+      REAL q2(ngridmx,nlayermx+1)
+      REAL,ALLOCATABLE :: qsurf(:,:)
+      REAL emis(ngridmx)
+      INTEGER start,length
+      PARAMETER (length = 100)
+      REAL tab_cntrl_fi(length) ! tableau des parametres de startfi
+      REAL tab_cntrl_dyn(length) ! tableau des parametres de start
+      INTEGER*4 day_ini_fi
+
+!     added by FF for cloud fraction setup
+      REAL hice(ngridmx)
+      REAL cloudfrac(ngridmx,nlayermx),totalcloudfrac(ngridmx)
+
+!     added by BC for slab ocean
+      REAL rnat(ngridmx),pctsrf_sic(ngridmx),sea_ice(ngridmx)
+      REAL tslab(ngridmx,noceanmx),tsea_ice(ngridmx)
+
+
+c Variable naturelle / grille scalaire
+c ------------------------------------
+      REAL T(ip1jmp1,llm),us(ip1jmp1,llm),vs(ip1jmp1,llm)
+      REAL tsurfS(ip1jmp1)
+      REAL tsoilS(ip1jmp1,nsoilmx)
+      REAL ithS(ip1jmp1,nsoilmx) ! Soil Thermal Inertia
+      REAL co2iceS(ip1jmp1)
+      REAL q2S(ip1jmp1,llm+1)
+      REAL,ALLOCATABLE :: qsurfS(:,:)
+      REAL emisS(ip1jmp1)
+
+!     added by FF for cloud fraction setup
+      REAL hiceS(ip1jmp1)
+      REAL cloudfracS(ip1jmp1,llm),totalcloudfracS(ip1jmp1)
+
+!     added by BC for slab ocean
+      REAL rnatS(ip1jmp1),pctsrf_sicS(ip1jmp1),sea_iceS(ip1jmp1)
+      REAL tslabS(ip1jmp1,noceanmx),tsea_iceS(ip1jmp1)
+
+
+c Variables intermediaires : vent naturel, mais pas coord scalaire
+c----------------------------------------------------------------
+      REAL vn(ip1jm,llm),un(ip1jmp1,llm)
+
+c Autres  variables
+c -----------------
+      LOGICAL startdrs
+      INTEGER Lmodif
+
+      REAL ptotal, co2icetotal
+      REAL timedyn,timefi !fraction du jour dans start, startfi
+      REAL date
+
+      CHARACTER*2 str2
+      CHARACTER*80 fichier 
+      data  fichier /'startfi'/
+
+      INTEGER ij, l,i,j,isoil,iq
+      character*80      fichnom
+      integer :: ierr,ntime
+      integer :: nq,numvanle
+      character(len=30) :: txt ! to store some text
+
+c Netcdf
+c-------
+      integer varid,dimid,timelen 
+      INTEGER nid,nid1
+
+c-----------------------------------------------------------------------
+c   Initialisations 
+c-----------------------------------------------------------------------
+
+      CALL defrun_new(99, .TRUE. )
+      grireg   = .TRUE.
+
+! initialize "serial/parallel" related stuff
+      CALL init_phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+      call initcomgeomphy
+
+      ! ALLOCATE ARRAYS IN comgeomfi_h (usually done in inifis)
+      ! this must be here for start2archive to work
+      IF (.not. ALLOCATED(lati)) ALLOCATE(lati(ngridmx))
+      IF (.not. ALLOCATED(long)) ALLOCATE(long(ngridmx))
+      IF (.not. ALLOCATED(area)) ALLOCATE(area(ngridmx))
+
+c=======================================================================
+c Lecture des donnees
+c=======================================================================
+! Load tracer number and names:
+      call iniadvtrac(nqtot,numvanle)
+
+! allocate arrays:
+      allocate(q(ip1jmp1,llm,nqtot))
+      allocate(qsurf(ngridmx,nqtot))
+      allocate(qsurfS(ip1jmp1,nqtot))
+! other array allocations:
+      call ini_comsoil_h(ngridmx)
+
+      fichnom = 'start.nc'
+      CALL dynetat0(fichnom,nqtot,vcov,ucov,teta,q,masse,
+     .       ps,phis,timedyn)
+
+! load 'controle' array from dynamics start file
+
+       ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1)
+       IF (ierr.NE.NF_NOERR) THEN
+         write(6,*)' Pb d''ouverture du fichier'//trim(fichnom)
+        CALL ABORT
+       ENDIF
+                                                
+      ierr = NF_INQ_VARID (nid1, "controle", varid)
+      IF (ierr .NE. NF_NOERR) THEN
+       PRINT*, "start2archive: Le champ <controle> est absent"
+       CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+       ierr = NF_GET_VAR_DOUBLE(nid1, varid, tab_cntrl_dyn)
+#else
+      ierr = NF_GET_VAR_REAL(nid1, varid, tab_cntrl_dyn)
+#endif
+       IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "start2archive: Lecture echoue pour <controle>"
+          CALL abort
+       ENDIF
+
+      ierr = NF_CLOSE(nid1)
+      
+
+      fichnom = 'startfi.nc'
+      Lmodif=0
+
+
+      CALL phyetat0 (ngridmx,fichnom,0,Lmodif,nsoilmx,nqtot,day_ini_fi,
+     .      timefi,
+     .      tsurf,tsoil,emis,q2,qsurf,
+!       change FF 05/2011
+     .       cloudfrac,totalcloudfrac,hice,
+!       change BC 05/2014
+     .       rnat,pctsrf_sic,tslab,tsea_ice,sea_ice)
+
+
+
+
+! load 'controle' array from physics start file
+
+       ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1)
+       IF (ierr.NE.NF_NOERR) THEN
+         write(6,*)' Pb d''ouverture du fichier'//trim(fichnom)
+        CALL ABORT
+       ENDIF
+                                                
+      ierr = NF_INQ_VARID (nid1, "controle", varid)
+      IF (ierr .NE. NF_NOERR) THEN
+       PRINT*, "start2archive: Le champ <controle> est absent"
+       CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+       ierr = NF_GET_VAR_DOUBLE(nid1, varid, tab_cntrl_fi)
+#else
+      ierr = NF_GET_VAR_REAL(nid1, varid, tab_cntrl_fi)
+#endif
+       IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "start2archive: Lecture echoue pour <controle>"
+          CALL abort
+       ENDIF
+
+      ierr = NF_CLOSE(nid1)
+
+
+c-----------------------------------------------------------------------
+c Controle de la synchro
+c-----------------------------------------------------------------------
+!mars a voir      if ((day_ini_fi.ne.day_ini).or.(abs(timefi-timedyn).gt.1.e-10)) 
+      if ((day_ini_fi.ne.day_ini)) 
+     &  stop ' Probleme de Synchro entre start et startfi !!!'
+
+
+c *****************************************************************
+c    Option : Reinitialisation des dates dans la premieres annees :
+       do while (day_ini.ge.year_day)
+          day_ini=day_ini-year_day
+       enddo
+c *****************************************************************
+
+c-----------------------------------------------------------------------
+c   Initialisations 
+c-----------------------------------------------------------------------
+
+      CALL defrun_new(99, .FALSE. )
+      call iniconst
+      call inigeom
+      call inifilr
+      CALL pression(ip1jmp1, ap, bp, ps, p3d)
+      call exner_hyb(ip1jmp1, ps, p3d, beta, pks, pk, pkf)
+
+c=======================================================================
+c Transformation EN VARIABLE NATURELLE / GRILLE SCALAIRE si necessaire
+c=======================================================================
+c  Les variables modeles dependent de la resolution. Il faut donc
+c  eliminer les facteurs responsables de cette dependance
+c  (pour utiliser newstart)
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c Vent   (depend de la resolution horizontale) 
+c-----------------------------------------------------------------------
+c
+c ucov --> un  et  vcov --> vn
+c un --> us  et   vn --> vs
+c
+c-----------------------------------------------------------------------
+
+      call covnat(llm,ucov, vcov, un, vn) 
+      call wind_scal(un,vn,us,vs) 
+
+c-----------------------------------------------------------------------
+c Temperature  (depend de la resolution verticale => de "sigma.def")
+c-----------------------------------------------------------------------
+c
+c h --> T
+c
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            T(ij,l)=teta(ij,l)*pk(ij,l)/cpp !mars deduit de l'equation dans newstart
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c Variable physique 
+c-----------------------------------------------------------------------
+c
+c tsurf --> tsurfS
+c co2ice --> co2iceS
+c tsoil --> tsoilS
+c emis --> emisS
+c q2 --> q2S
+c qsurf --> qsurfS
+c
+c-----------------------------------------------------------------------
+
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsurf,tsurfS)
+!      call gr_fi_dyn(1,ngridmx,iip1,jjp1,co2ice,co2iceS)
+      call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,tsoil,tsoilS)
+      ! Note: thermal inertia "inertiedat" is in comsoil.h
+      call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,inertiedat,ithS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,emis,emisS)
+      call gr_fi_dyn(llm+1,ngridmx,iip1,jjp1,q2,q2S)
+      call gr_fi_dyn(nqtot,ngridmx,iip1,jjp1,qsurf,qsurfS)
+      call gr_fi_dyn(llm,ngridmx,iip1,jjp1,cloudfrac,cloudfracS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,hice,hiceS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,totalcloudfrac,totalcloudfracS)
+
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,rnat,rnatS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,pctsrf_sic,pctsrf_sicS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsea_ice,tsea_iceS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,sea_ice,sea_iceS)
+      call gr_fi_dyn(noceanmx,ngridmx,iip1,jjp1,tslab,tslabS)
+
+c=======================================================================
+c Info pour controler
+c=======================================================================
+
+      ptotal =  0.
+      co2icetotal = 0.
+      DO j=1,jjp1
+         DO i=1,iim
+           ptotal=ptotal+aire(i+(iim+1)*(j-1))*ps(i+(iim+1)*(j-1))/g
+!           co2icetotal = co2icetotal + 
+!     &            co2iceS(i+(iim+1)*(j-1))*aire(i+(iim+1)*(j-1))
+         ENDDO
+      ENDDO
+      write(*,*)'Ancienne grille : masse de l''atm :',ptotal
+!      write(*,*)'Ancienne grille : masse de la glace CO2 :',co2icetotal
+
+c-----------------------------------------------------------------------
+c Passage de "ptotal" et "co2icetotal" par tab_cntrl_fi
+c-----------------------------------------------------------------------
+
+      tab_cntrl_fi(49) = ptotal
+      tab_cntrl_fi(50) = co2icetotal
+
+c=======================================================================
+c Ecriture dans le fichier  "start_archive"
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c Ouverture de "start_archive" 
+c-----------------------------------------------------------------------
+
+      ierr = NF_OPEN ('start_archive.nc', NF_WRITE,nid)
+ 
+c-----------------------------------------------------------------------
+c  si "start_archive" n'existe pas:
+c    1_ ouverture
+c    2_ creation de l'entete dynamique ("ini_archive")
+c-----------------------------------------------------------------------
+c ini_archive:
+c On met dans l'entete le tab_cntrl dynamique (1 a 16) 
+c  On y ajoute les valeurs du tab_cntrl_fi (a partir de 51)
+c  En plus les deux valeurs ptotal et co2icetotal (99 et 100)
+c-----------------------------------------------------------------------
+
+      if (ierr.ne.NF_NOERR) then
+         write(*,*)'OK, Could not open file "start_archive.nc"'
+         write(*,*)'So let s create a new "start_archive"'
+         ierr = NF_CREATE('start_archive.nc', NF_CLOBBER, nid)
+         call ini_archive(nid,day_ini,phis,ithS,tab_cntrl_fi,
+     &                                          tab_cntrl_dyn)
+      endif
+
+c-----------------------------------------------------------------------
+c Ecriture de la coordonnee temps (date en jours)
+c-----------------------------------------------------------------------
+
+      date = day_ini
+      ierr= NF_INQ_VARID(nid,"Time",varid)
+      ierr= NF_INQ_DIMID(nid,"Time",dimid)
+      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
+      ntime=timelen+1
+
+      write(*,*) "******************"
+      write(*,*) "ntime",ntime
+      write(*,*) "******************"
+#ifdef NC_DOUBLE
+      ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+#else
+      ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write(*,*) "time matter ",NF_STRERROR(ierr)
+         stop
+      endif
+
+c-----------------------------------------------------------------------
+c Ecriture des champs  (co2ice,emis,ps,Tsurf,T,u,v,q2,q,qsurf)
+c-----------------------------------------------------------------------
+c ATTENTION: q2 a une couche de plus!!!!
+c    Pour creer un fichier netcdf lisible par grads,
+c    On passe donc une des couches de q2 a part
+c    comme une variable 2D (la couche au sol: "q2surf")
+c    Les lmm autres couches sont nommees "q2atm" (3D) 
+c-----------------------------------------------------------------------
+
+!      call write_archive(nid,ntime,'co2ice','couche de glace co2',
+!     &  'kg/m2',2,co2iceS)
+      call write_archive(nid,ntime,'emis','grd emis',' ',2,emisS)
+      call write_archive(nid,ntime,'ps','Psurf','Pa',2,ps)
+      call write_archive(nid,ntime,'tsurf','surf T','K',2,tsurfS)
+      call write_archive(nid,ntime,'temp','temperature','K',3,t)
+      call write_archive(nid,ntime,'u','Vent zonal','m.s-1',3,us)
+      call write_archive(nid,ntime,'v','Vent merid','m.s-1',3,vs)
+      call write_archive(nid,ntime,'q2surf','wind variance','m2.s-2',2,
+     .              q2S)
+      call write_archive(nid,ntime,'q2atm','wind variance','m2.s-2',3,
+     .              q2S(1,2))
+
+c-----------------------------------------------------------------------
+c Ecriture du champs  q  ( q[1,nqtot] )
+c-----------------------------------------------------------------------
+      do iq=1,nqtot
+        call write_archive(nid,ntime,tname(iq),'tracer','kg/kg',
+     &         3,q(1,1,iq))
+      end do
+c-----------------------------------------------------------------------
+c Ecriture du champs  qsurf  ( qsurf[1,nqtot] )
+c-----------------------------------------------------------------------
+      do iq=1,nqtot
+        txt=trim(tname(iq))//"_surf"
+        call write_archive(nid,ntime,txt,'Tracer on surface',
+     &  'kg.m-2',2,qsurfS(1,iq))
+      enddo
+
+
+c-----------------------------------------------------------------------
+c Ecriture du champs  tsoil  ( Tg[1,10] )
+c-----------------------------------------------------------------------
+c "tsoil" Temperature au sol definie dans 10 couches dans le sol
+c   Les 10 couches sont lues comme 10 champs 
+c  nommees Tg[1,10]
+
+c      do isoil=1,nsoilmx
+c       write(str2,'(i2.2)') isoil
+c       call write_archive(nid,ntime,'Tg'//str2,'Ground Temperature ',
+c     .   'K',2,tsoilS(1,isoil))
+c      enddo
+
+! Write soil temperatures tsoil
+      call write_archive(nid,ntime,'tsoil','Soil temperature',
+     &     'K',-3,tsoilS)
+
+! Write soil thermal inertia
+      call write_archive(nid,ntime,'inertiedat',
+     &     'Soil thermal inertia',
+     &     'J.s-1/2.m-2.K-1',-3,ithS)
+
+! Write (0D) volumetric heat capacity (stored in comsoil.h)
+!      call write_archive(nid,ntime,'volcapa',
+!     &     'Soil volumetric heat capacity',
+!     &     'J.m-3.K-1',0,volcapa)
+! Note: no need to write volcapa, it is stored in "controle" table
+
+c-----------------------------------------------------------------------
+c Ecriture du champs  cloudfrac,hice,totalcloudfrac
+c-----------------------------------------------------------------------
+      call write_archive(nid,ntime,'hice',
+     &         'Height of oceanic ice','m',2,hiceS)
+      call write_archive(nid,ntime,'totalcloudfrac',
+     &        'Total cloud Fraction','',2,totalcloudfracS)
+      call write_archive(nid,ntime,'cloudfrac'
+     &        ,'Cloud fraction','',3,cloudfracS)
+
+c-----------------------------------------------------------------------
+c Slab ocean
+c-----------------------------------------------------------------------
+      OPEN(99,file='callphys.def',status='old',form='formatted'
+     &     ,iostat=ierr)
+      CLOSE(99)
+
+      IF(ierr.EQ.0) THEN
+
+
+         write(*,*) "Use slab-ocean ?"
+         ok_slab_ocean=.false.         ! default value
+         call getin("ok_slab_ocean",ok_slab_ocean)
+         write(*,*) "ok_slab_ocean = ",ok_slab_ocean
+
+      if(ok_slab_ocean) then
+      call write_archive(nid,ntime,'rnat'
+     &        ,'rnat','',2,rnatS)
+      call write_archive(nid,ntime,'pctsrf_sic'
+     &        ,'pctsrf_sic','',2,pctsrf_sicS)
+      call write_archive(nid,ntime,'sea_ice'
+     &        ,'sea_ice','',2,sea_iceS)
+      call write_archive(nid,ntime,'tslab'
+     &        ,'tslab','',3,tslabS)
+      call write_archive(nid,ntime,'tsea_ice'
+     &        ,'tsea_ice','',2,tsea_iceS)
+      endif !ok_slab_ocean
+      ENDIF
+c-----------------------------------------------------------------------
+c Fin 
+c-----------------------------------------------------------------------
+      ierr=NF_CLOSE(nid)
+
+      write(*,*) "start2archive: All is well that ends well."
+
+      end 
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/statto.h
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/statto.h	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/statto.h	(revision 222)
@@ -0,0 +1,34 @@
+
+!  statto:
+!     This include file controls the production of statistics.
+!     Some variables could be set in a namelist, but it is easier to
+!     do it here since arrays can then be dimensioned using parameters
+!     and values shouldn't have to change too often.   SRL
+
+!     Calculate stats every istats physics timesteps, starting at first
+!     call.  If istats=0 then don't do statistics at all.  Check value
+!     if number of physics timesteps changes.
+	integer istats
+
+!     Calculate itime independent sums and sums of squares,
+!     example, istat=1,istime=1 gives a single time mean
+	integer, parameter :: istime=12
+
+!     Number of 2D and 3D variables on which to do statistics.
+	integer n2dvar, n3dvar
+	parameter (n2dvar = 8, n3dvar = 5)
+
+!     Units for writing stats header and data
+	integer usdata
+
+!     count tab to know the variable record
+        integer count(istime)
+
+!     Record of the number of stores made for each time.
+	integer nstore(istime)
+
+! Size of the "controle" array
+        integer, parameter :: cntrlsize=15
+
+!       common /sttcom/ dummy,nstore,istats,usdata
+        common /sttcom/ nstore,istats,usdata,count
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stelang.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stelang.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stelang.F	(revision 222)
@@ -0,0 +1,121 @@
+      subroutine stelang(kgrid,psilon,pcolon,psilat,pcolat,
+     &                ptim1,ptim2,ptim3,pmu0,pfract, pflat)
+      IMPLICIT NONE
+
+C
+C**** *LW*   - ORGANIZES THE LONGWAVE CALCULATIONS
+C
+C     PURPOSE.
+C     --------
+C          CALCULATES THE STELLAR ANGLE FOR ALL THE POINTS OF THE GRID
+C
+C**   INTERFACE.
+C     ----------
+C      SUBROUTINE STELANG ( KGRID )
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS  ===
+C
+C PSILON(KGRID)   : SINUS OF THE LONGITUDE
+C PCOLON(KGRID)   : COSINUS OF THE LONGITUDE
+C PSILAT(KGRID)   : SINUS OF THE LATITUDE
+C PCOLAT(KGRID)   : COSINUS OF THE LATITUDE
+C PTIM1           : SIN(DECLI)
+C PTIM2           : COS(DECLI)*COS(TIME)
+C PTIM3           : SIN(DECLI)*SIN(TIME)
+C
+C     ==== OUTPUTS ===
+C
+C PMU0 (KGRID)    : SOLAR ANGLE
+C PFRACT(KGRID)   : DAY FRACTION OF THE TIME INTERVAL
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C     EXTERNALS.
+C     ----------
+C
+C         NONE
+C
+C     REFERENCE.
+C     ----------
+C
+C         RADIATIVE PROCESSES IN METEOROLOGIE AND CLIMATOLOGIE
+C         PALTRIDGE AND PLATT
+C
+C     AUTHOR.
+C     -------
+C        FREDERIC HOURDIN
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL :90-01-14
+C                  92-02-14 CALCULATIONS DONE THE ENTIER GRID (J.Polcher)
+C-----------------------------------------------------------------------
+C
+C     ------------------------------------------------------------------
+
+C-----------------------------------------------------------------------
+C
+C*      0.1   ARGUMENTS
+C             ---------
+C
+      INTEGER,INTENT(IN) :: kgrid
+      REAL,INTENT(IN) :: ptim1,ptim2,ptim3, pflat
+      REAL,INTENT(IN) :: psilon(kgrid),pcolon(kgrid)
+      REAL,INTENT(IN) :: psilat(kgrid), pcolat(kgrid)
+      REAL,INTENT(OUT) :: pmu0(kgrid),pfract(kgrid)
+C
+      INTEGER jl
+      REAL ztim1,ztim2,ztim3, rap
+C------------------------------------------------------------------------
+C------------------------------------------------------------------------
+C------------------------------------------------------------------------
+C
+C------------------------------------------------------------------------
+C
+C*     1.     INITIALISATION
+C             --------------
+C
+c----- SG: geometry adapted to a flattened planet (Feb2014)
+
+      rap = 1./((1.-pflat)**2)
+
+ 100  CONTINUE
+C
+      DO jl=1,kgrid
+        pmu0(jl)=0.
+        pfract(jl)=0.
+      ENDDO
+C
+C*     1.1     COMPUTATION OF THE SOLAR ANGLE
+C              ------------------------------
+C
+      DO jl=1,kgrid
+        ztim1=psilat(jl)*ptim1*rap
+        ztim2=pcolat(jl)*ptim2
+        ztim3=pcolat(jl)*ptim3
+        pmu0(jl)=ztim1+ztim2*pcolon(jl)+ztim3*psilon(jl)
+	pmu0(jl)=pmu0(jl)/SQRT(pcolat(jl)**2+(rap**2)*(psilat(jl)**2))
+
+      ENDDO
+C
+C*     1.2      DISTINCTION BETWEEN DAY AND NIGHT
+C               ---------------------------------
+C
+      DO jl=1,kgrid
+        IF (pmu0(jl).gt.0.) THEN
+          pfract(jl)=1.
+c       pmu0(jl)=sqrt(1224.*pmu0(jl)*pmu0(jl)+1.)/35.
+      ELSE
+c       pmu0(jl)=0.
+        pfract(jl)=0.
+        ENDIF
+      ENDDO
+C
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stellarlong.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stellarlong.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stellarlong.F	(revision 222)
@@ -0,0 +1,101 @@
+      SUBROUTINE stellarlong(pday,pstellong)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Objet:
+c   ------
+c
+c      Calcul de la distance soleil-planete et de la declinaison
+c   en fonction du jour de l'annee.
+c
+c
+c   Methode:
+c   --------
+c
+c      Calcul complet de l'elipse
+c
+c   Interface:
+c   ----------
+c
+c      Uncommon comprenant les parametres orbitaux.
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   pday          jour de l'annee (le jour 0 correspondant a l'equinoxe)
+c
+c   Output:
+c   -------
+c   pdist_star     distance entre le soleil et la planete
+c                 ( en unite astronomique pour utiliser la constante 
+c                  solaire terrestre 1370 Wm-2 )
+c   pdecli        declinaison ( en radians )
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "comcstfi.h"
+
+c arguments:
+c ----------
+
+      REAL pday,pdist_star,pdecli,pstellong
+      LOGICAL lwrite
+
+c Local:
+c ------
+
+      REAL zanom,xref,zx0,zdx,zteta,zz
+      INTEGER iter
+
+
+c-----------------------------------------------------------------------
+c calcul de l'angle polaire et de la distance au soleil :
+c -------------------------------------------------------
+
+c  calcul de l'zanomalie moyenne
+
+      zz=(pday-peri_day)/year_day
+      pi=2.*asin(1.)
+      zanom=2.*pi*(zz-nint(zz))
+      xref=abs(zanom)
+
+c  resolution de l'equation horaire  zx0 - e * sin (zx0) = xref
+c  methode de Newton
+
+      zx0=xref+e_elips*sin(xref)
+      DO 110 iter=1,10
+         zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
+         if(abs(zdx).le.(1.e-7)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+
+c zteta est la longitude solaire
+
+      zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+
+      pstellong=zteta-timeperi
+
+      IF(pstellong.LT.0.) pstellong=pstellong+2.*pi
+      IF(pstellong.GT.2.*pi) pstellong=pstellong-2.*pi
+c-----------------------------------------------------------------------
+c   sorties eventuelles:
+c   ---------------------
+
+c     IF (lwrite) THEN
+c        PRINT*,'jour de l"annee   :',pday
+c        PRINT*,'distance au soleil (en unite astronomique) :',pdist_star
+c        PRINT*,'declinaison (en degres) :',pdecli*180./pi
+c     ENDIF
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stokes.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stokes.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/stokes.F90	(revision 222)
@@ -0,0 +1,67 @@
+      subroutine stokes(p,t,rd,w,rho_aer)
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the sedimentation velocity in a low pressure 
+!     atmosphere.
+!
+!     Authors
+!     ------- 
+!     Francois Forget (1997)
+!
+!==================================================================
+
+!      use radcommon_h, only : Rgas
+
+      implicit none
+
+#include "comcstfi.h"
+
+!     input
+!     -----
+!     pressure (Pa), Temperature (K), particle radius (m), density
+      real p, t, rd, rho_aer 
+
+!     output
+!     ------
+!     sedimentation velocity (m/s, >0)
+      real w
+
+!     locally saved variables
+!     ---------------------
+      real a,b,molrad,visc
+      save a,b
+  
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall/.true./
+
+      if (firstcall) then
+
+         !print*,'Routine not working: replace Rgas with r'
+	 !stop
+         !a = 0.707*Rgas/(4*pi*molrad**2 * avocado)
+
+         molrad=2.2e-10   ! CO2 (only used in condense_co2cloud at the moment)
+         visc=1.e-5       ! CO2
+
+
+         a = 0.707*R/(4*pi*molrad**2 * avocado)
+         b = (2./9.) * rho_aer * g / visc 
+	!print*,'molrad=',molrad
+	!print*,'visc=',visc
+	!print*,'a=',a
+	!print*,'b=',b
+	!print*,'rho_aer=',rho_aer
+	!stop
+ 
+         firstcall=.false.
+      end if
+
+!     Sedimentation velocity =
+!     Stokes' Law corrected for low pressures by the Cunningham
+!     slip-flow correction according to Rossow (Icarus 36, 1-50, 1978)
+      w = b * rd*rd * (1 + 1.333* (a*T/P)/rd )  
+      return
+    end subroutine stokes
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/su_gases.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/su_gases.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/su_gases.F90	(revision 222)
@@ -0,0 +1,125 @@
+subroutine su_gases
+
+  use gases_h
+
+  implicit none
+
+  integer igas, ierr, count
+
+  !==================================================================
+  !     
+  !     Purpose
+  !     -------
+  !     Load atmospheric composition info
+  !     
+  !     Authors
+  !     -------
+  !     R. Wordsworth (2011)
+  !     Allocatable arrays by A. Spiga (2011)
+  !     
+  !==================================================================
+
+  ! load gas names from file 'gases.def'
+  open(90,file='gases.def',status='old',form='formatted',iostat=ierr)
+  if (ierr.eq.0) then
+     write(*,*) "sugases.F90: reading file gases.def"
+     read(90,*)
+     read(90,*,iostat=ierr) ngasmx
+     if (ierr.ne.0) then
+        write(*,*) "sugases.F90: error reading number of gases"
+        write(*,*) "   (first line of gases.def) "
+        call abort
+     endif
+
+     print*,ngasmx, " gases found in gases.def. Allocating names and molar fractions..."
+
+     if (.not.allocated(gnom)) allocate(gnom(ngasmx))
+     do igas=1,ngasmx
+        read(90,*,iostat=ierr) gnom(igas)
+        if (ierr.ne.0) then
+           write(*,*) 'sugases.F90: error reading gas names in gases.def...'
+           call abort
+        endif
+     enddo                  !of do igas=1,ngasmx
+
+     vgas=0
+     if(.not.allocated(gfrac)) allocate(gfrac(ngasmx))
+     do igas=1,ngasmx
+        read(90,*,iostat=ierr) gfrac(igas)
+        if (ierr.ne.0) then
+           write(*,*) 'sugases.F90: error reading gas molar fractions in gases.def...'
+           call abort
+        endif
+
+        ! find variable gas (if any)
+        if(gfrac(igas).eq.-1.0)then 
+           if(vgas.eq.0)then
+              vgas=igas
+           else
+              print*,'You seem to be choosing two variable gases'
+              print*,'Check that gases.def is correct'
+              call abort
+           endif
+        endif
+
+     enddo                  !of do igas=1,ngasmx
+
+
+     ! assign the 'igas_X' labels
+     count=0
+     do igas=1,ngasmx
+        if (trim(gnom(igas)).eq."H2_" .or. trim(gnom(igas)).eq."H2") then
+           igas_H2=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."He_" .or. trim(gnom(igas)).eq."He") then
+           igas_He=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."H2O") then
+           igas_H2O=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."CO2") then
+           igas_CO2=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."CO_" .or. trim(gnom(igas)).eq."CO") then
+           igas_CO=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."N2_" .or. trim(gnom(igas)).eq."N2") then
+           igas_N2=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."O2_" .or. trim(gnom(igas)).eq."O2") then
+           igas_O2=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."SO2") then
+           igas_SO2=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."H2S") then
+           igas_H2S=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."CH4") then
+           igas_CH4=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."NH3") then
+           igas_NH3=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."C2H6") then
+           igas_C2H6=igas
+           count=count+1
+        elseif (trim(gnom(igas)).eq."C2H2") then
+           igas_C2H2=igas
+           count=count+1
+        endif
+     enddo
+
+     if(count.ne.ngasmx)then
+        print*,'Mismatch between ngas and number of recognised gases in sugas_corrk.F90.'
+        print*,'Either we haven`t managed to assign all the gases, or there are duplicates.'
+        print*,'Please try again.'
+     endif
+
+  else
+     write(*,*) 'Cannot find required file "gases.def"'
+     call abort
+  endif
+  close(90)
+
+end subroutine su_gases
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/su_watercycle.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/su_watercycle.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/su_watercycle.F90	(revision 222)
@@ -0,0 +1,32 @@
+      subroutine su_watercycle
+
+      use watercommon_h
+      implicit none
+#include "comcstfi.h"
+#include "callkeys.h"
+
+
+!==================================================================
+!
+!     Purpose
+!     -------
+!     Set up relevant constants and parameters for the water cycle, and water cloud properties
+!
+!     Authors
+!     -------
+!     Robin Wordsworth (2010)
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+
+      epsi   = mH2O / mugaz
+      RCPD   = cpp 
+
+      !RV = 1000.*R/mH2O
+      RV = 1000.*8.314/mH2O ! caution! R is R/mugaz already!
+
+      RCPV   = 1.88e3 ! specific heat capacity of water vapor at 350K
+
+      RVTMP2 = RCPV/RCPD-1. ! not currently used...
+
+      end subroutine su_watercycle
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/suaer_corrk.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/suaer_corrk.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/suaer_corrk.F90	(revision 222)
@@ -0,0 +1,449 @@
+      subroutine suaer_corrk
+
+      ! inputs
+      use radinc_h,    only: L_NSPECTI,L_NSPECTV,nsizemax,iim,jjm,naerkind
+      use radcommon_h, only: blamv,blami,lamrefir,lamrefvis
+      use datafile_mod, only: datadir
+
+      ! outputs
+      use radcommon_h, only: QVISsQREF,omegavis,gvis,QIRsQREF,omegair,gir
+      use radcommon_h, only: radiustab,nsize,tstellar
+      use radcommon_h, only: qrefvis,qrefir,omegarefvis,omegarefir
+      use aerosol_mod
+
+      implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Initialize all radiative aerosol properties
+!
+!     Notes
+!     -----
+!     Reads the optical properties -> Mean  -> Variable assignment
+!     (ASCII files)                  (see radcommon_h.F90)
+!     wvl(nwvl)                      longsun
+!     ep(nwvl)                       epav     QVISsQREF(L_NSPECTV)
+!     omeg(nwvl)                     omegav   omegavis(L_NSPECTV)
+!     gfactor(nwvl)                  gav      gvis(L_NSPECTV)
+!     
+!     Authors
+!     ------- 
+!     Richard Fournier (1996) Francois Forget (1996)
+!     Frederic Hourdin
+!     Jean-jacques morcrette *ECMWF*
+!     MODIF Francois Forget (2000)
+!     MODIF Franck Montmessin (add water ice)
+!     MODIF J.-B. Madeleine 2008W27
+!     - Optical properties read in ASCII files
+!     - Add varying radius of the particules
+!     - Add water ice clouds
+!     MODIF R. Wordsworth (2009)
+!     - generalisation to arbitrary spectral bands 
+!
+!==================================================================
+
+#include "callkeys.h"
+!     Optical properties (read in external ASCII files)
+      INTEGER          :: nwvl  ! Number of wavelengths in
+                                ! the domain (VIS or IR)
+
+!      REAL             :: solsir ! visible to infrared ratio
+!                                ! (tau_0.67um/tau_9um)
+
+      REAL, DIMENSION(:),&
+      ALLOCATABLE, SAVE :: wvl  ! Wavelength axis
+      REAL, DIMENSION(:),&
+      ALLOCATABLE, SAVE :: radiusdyn ! Particle size axis
+
+      REAL, DIMENSION(:,:),&
+      ALLOCATABLE, SAVE :: ep,& ! Extinction coefficient Qext
+      omeg,&                    ! Single Scattering Albedo
+      gfactor                   ! Assymetry Factor
+
+!     Local variables:
+
+      INTEGER :: iaer           ! Aerosol index
+      INTEGER :: idomain        ! Domain index (1=VIS,2=IR)
+      INTEGER :: ilw            ! longwave index
+      INTEGER :: isw           ! shortwave index
+      INTEGER :: isize          ! Particle size index
+      INTEGER :: jfile          ! ASCII file scan index
+      INTEGER :: file_unit = 60
+      LOGICAL :: file_ok, endwhile
+      CHARACTER(LEN=132) :: scanline ! ASCII file scanning line
+
+!     I/O  of "aerave" (subroutine that spectrally averages
+!     the single scattering parameters)
+
+      REAL lamref                      ! reference wavelengths
+      REAL epref                       ! reference extinction ep
+
+!      REAL epav(L_NSPECTI)            ! Average ep (= <Qext>/Qext(lamref) if epref=1)
+!      REAL omegav(L_NSPECTI)          ! Average single scattering albedo
+!      REAL gav(L_NSPECTI)             ! Average assymetry parameter
+
+      REAL epavVI(L_NSPECTV)            ! Average ep (= <Qext>/Qext(lamref) if epref=1)
+      REAL omegavVI(L_NSPECTV)          ! Average single scattering albedo
+      REAL gavVI(L_NSPECTV)             ! Average assymetry parameter
+
+      REAL epavIR(L_NSPECTI)            ! Average ep (= <Qext>/Qext(lamref) if epref=1)
+      REAL omegavIR(L_NSPECTI)          ! Average single scattering albedo
+      REAL gavIR(L_NSPECTI)             ! Average assymetry parameter
+      
+      logical forgetit                  ! use francois' data?
+      integer iwvl
+
+!     Local saved variables:
+
+      CHARACTER(LEN=30), DIMENSION(naerkind,2), SAVE :: file_id
+!---- Please indicate the names of the optical property files below
+!     Please also choose the reference wavelengths of each aerosol
+
+      if (noaero) then
+        print*, 'naerkind= 0'
+      endif
+      do iaer=1,naerkind
+       if (iaer.eq.iaero_co2) then
+        forgetit=.true.
+          if (.not.noaero) then
+              print*, 'naerkind= co2', iaer
+          end if
+!     visible
+        if(forgetit)then
+           file_id(iaer,1) = 'optprop_co2_vis_ff.dat' ! Francois' values
+        else
+           file_id(iaer,1) = 'optprop_co2ice_vis_n50.dat'
+        endif
+        lamrefvis(iaer)=1.5E-6   ! 1.5um OMEGA/MEx ???
+
+!     infrared
+        if(forgetit)then
+           file_id(iaer,2) = 'optprop_co2_ir_ff.dat' ! Francois' values
+        else
+           file_id(iaer,2) = 'optprop_co2ice_ir_n50.dat'
+        endif
+        lamrefir(iaer)=12.1E-6   ! 825cm-1 TES/MGS ???
+       endif ! CO2 aerosols  
+! NOTE: these lamref's are currently for dust, not CO2 ice.
+! JB thinks this shouldn't matter too much, but it needs to be 
+! fixed / decided for the final version.
+
+       if (iaer.eq.iaero_h2o) then
+        print*, 'naerkind= h2o', iaer
+
+!     visible
+         file_id(iaer,1) = 'optprop_icevis_n50.dat'
+         lamrefvis(iaer)=1.5E-6   ! 1.5um OMEGA/MEx
+!     infrared
+         file_id(iaer,2) = 'optprop_iceir_n50.dat'
+         lamrefir(iaer)=12.1E-6   ! 825cm-1 TES/MGS
+       endif
+
+       if (iaer.eq.iaero_dust) then
+        print*, 'naerkind= dust', iaer
+
+!     visible
+         file_id(iaer,1) = 'optprop_dustvis_n50.dat'
+         !lamrefvis(iaer)=1.5E-6   ! 1.5um OMEGA/MEx
+         lamrefvis(iaer)=0.67e-6
+!     infrared
+         file_id(iaer,2) = 'optprop_dustir_n50.dat'
+         !lamrefir(iaer)=12.1E-6   ! 825cm-1 TES/MGS
+         lamrefir(iaer)=9.3E-6
+       endif 
+
+       if (iaer.eq.iaero_h2so4) then
+         print*, 'naerkind= h2so4', iaer
+
+!     visible
+         file_id(iaer,1) = 'optprop_h2so4vis_n20.dat'
+         !lamrefir(iaer)=  doesn't exist?
+         lamrefvis(iaer)=1.5E-6   ! no idea, must find
+!     infrared
+         file_id(iaer,2) = 'optprop_h2so4ir_n20.dat'
+         !lamrefir(iaer)=12.1E-6   ! 825cm-1 TES/MGS
+         lamrefir(iaer)=9.3E-6 ! no idea, must find
+! added by LK
+       endif
+
+       if (iaer.eq.iaero_back2lay) then
+         print*, 'naerkind= back2lay', iaer
+
+!     visible
+         file_id(iaer,1) = 'optprop_saturn_vis_n20.dat'
+         lamrefvis(iaer)=0.8E-6  ! 
+!     infrared
+         file_id(iaer,2) = 'optprop_saturn_ir_n20.dat'
+         lamrefir(iaer)=6.E-6  ! 
+! added by SG
+       endif
+       
+       
+      enddo
+
+!------------------------------------------------------------------
+
+!     Initializations:
+
+      radiustab(:,:,:) = 0.0
+      gvis(:,:,:)      = 0.0
+      omegavis(:,:,:)  = 0.0
+      QVISsQREF(:,:,:) = 0.0
+      gir(:,:,:)       = 0.0
+      omegair(:,:,:)   = 0.0
+      QIRsQREF(:,:,:)  = 0.0
+
+      DO iaer = 1, naerkind     ! Loop on aerosol kind
+         DO idomain = 1, 2      ! Loop on radiation domain (VIS or IR)
+!==================================================================
+!     1. READ OPTICAL PROPERTIES
+!==================================================================
+
+!     1.1 Open the ASCII file
+
+            INQUIRE(FILE=TRIM(datadir)//&
+         '/'//TRIM(file_id(iaer,idomain)),&
+            EXIST=file_ok)
+            IF(.NOT.file_ok) THEN
+               write(*,*)'suaer_corrk: Problem opening ',&
+               TRIM(file_id(iaer,idomain))
+               write(*,*)'It should be in: ',TRIM(datadir)
+               write(*,*)'1) You can set this directory address ',&
+               'in callphys.def with:'
+               write(*,*)' datadir = /absolute/path/to/datagcm'
+               write(*,*)'2) If ',&
+              TRIM(file_id(iaer,idomain)),&
+               ' is a LMD reference datafile, it'
+               write(*,*)' can be obtained online at:'
+               write(*,*)' http://www.lmd.jussieu.fr/',&
+               '~forget/datagcm/datafile'
+               CALL ABORT 
+            ENDIF
+            OPEN(UNIT=file_unit,&
+            FILE=TRIM(datadir)//&
+         '/'//TRIM(file_id(iaer,idomain)),&
+            FORM='formatted')
+
+!     1.2 Allocate the optical property table
+
+            jfile = 1
+            endwhile = .false.
+            DO WHILE (.NOT.endwhile)
+               READ(file_unit,*) scanline
+               IF ((scanline(1:1) .ne. '#').and.&
+               (scanline(1:1) .ne. ' ')) THEN
+               BACKSPACE(file_unit)
+               reading1_seq: SELECT CASE (jfile) ! ====================
+            CASE(1) reading1_seq ! nwvl ----------------------------
+               read(file_unit,*) nwvl
+               jfile = jfile+1
+            CASE(2) reading1_seq ! nsize ---------------------------
+               read(file_unit,*) nsize(iaer,idomain)
+               endwhile = .true.
+            CASE DEFAULT reading1_seq ! ---------------------------- 
+               WRITE(*,*) 'readoptprop: ',& 
+               'Error while loading optical properties.' 
+               CALL ABORT 
+            END SELECT reading1_seq ! ==============================
+         ENDIF
+      ENDDO
+
+      ALLOCATE(wvl(nwvl))       ! wvl
+      ALLOCATE(radiusdyn(nsize(iaer,idomain))) ! radiusdyn
+      ALLOCATE(ep(nwvl,nsize(iaer,idomain))) ! ep
+      ALLOCATE(omeg(nwvl,nsize(iaer,idomain))) ! omeg 
+      ALLOCATE(gfactor(nwvl,nsize(iaer,idomain))) ! g
+
+
+!     1.3 Read the data
+
+      jfile = 1
+      endwhile = .false.
+      DO WHILE (.NOT.endwhile)
+         READ(file_unit,*) scanline
+         IF ((scanline(1:1) .ne. '#').and.&
+         (scanline(1:1) .ne. ' ')) THEN
+         BACKSPACE(file_unit)
+         reading2_seq: SELECT CASE (jfile) ! ====================
+      CASE(1) reading2_seq      ! wvl -----------------------------
+         read(file_unit,*) wvl
+         jfile = jfile+1
+      CASE(2) reading2_seq      ! radiusdyn -----------------------
+         read(file_unit,*) radiusdyn
+         jfile = jfile+1
+      CASE(3) reading2_seq      ! ep ------------------------------
+         isize = 1
+         DO WHILE (isize .le. nsize(iaer,idomain))
+            READ(file_unit,*) scanline
+            IF ((scanline(1:1) .ne. '#').and.&
+            (scanline(1:1) .ne. ' ')) THEN
+            BACKSPACE(file_unit)
+            read(file_unit,*) ep(:,isize)
+            isize = isize + 1
+         ENDIF
+      ENDDO
+
+      jfile = jfile+1
+      CASE(4) reading2_seq      ! omeg ----------------------------
+         isize = 1
+         DO WHILE (isize .le. nsize(iaer,idomain))
+            READ(file_unit,*) scanline
+            IF ((scanline(1:1) .ne. '#').and.&
+            (scanline(1:1) .ne. ' ')) THEN
+            BACKSPACE(file_unit)
+            read(file_unit,*) omeg(:,isize)
+            isize = isize + 1
+         ENDIF
+      ENDDO
+
+      jfile = jfile+1
+      CASE(5) reading2_seq      ! gfactor -------------------------
+         isize = 1
+         DO WHILE (isize .le. nsize(iaer,idomain))
+            READ(file_unit,*) scanline
+            IF ((scanline(1:1) .ne. '#').and.&
+            (scanline(1:1) .ne. ' ')) THEN
+            BACKSPACE(file_unit)
+            read(file_unit,*) gfactor(:,isize)
+            isize = isize + 1
+         ENDIF
+      ENDDO
+
+      jfile = jfile+1
+      IF ((idomain.NE.iaero_co2).OR.(iaer.NE.iaero_co2)) THEN
+         endwhile = .true.
+      ENDIF
+      CASE(6) reading2_seq
+         endwhile = .true.
+      CASE DEFAULT reading2_seq ! ----------------------------
+         WRITE(*,*) 'readoptprop: ',&
+         'Error while loading optical properties.'
+         CALL ABORT
+      END SELECT reading2_seq   ! ==============================
+      ENDIF
+      ENDDO
+
+!     1.4 Close the file
+
+      CLOSE(file_unit)
+
+!     1.5 If Francois' data, convert wvl to metres
+       if(iaer.eq.iaero_co2)then
+         if(forgetit)then
+         !   print*,'please sort out forgetit for naerkind>1'
+            do iwvl=1,nwvl
+               wvl(iwvl)=wvl(iwvl)*1.e-6
+            enddo
+         endif
+      endif
+
+
+
+
+
+
+!==================================================================
+!     2. AVERAGED PROPERTIES AND VARIABLE ASSIGNMENTS
+!==================================================================
+      domain: SELECT CASE (idomain)
+!==================================================================
+      CASE(1) domain            !       VISIBLE DOMAIN (idomain=1)
+!==================================================================
+
+         lamref=lamrefvis(iaer)
+         epref=1.E+0
+
+         DO isize=1,nsize(iaer,idomain)
+
+!     Save the particle sizes
+            radiustab(iaer,idomain,isize)=radiusdyn(isize)
+
+!     Averaged optical properties (GCM channels)
+
+!            CALL aerave ( nwvl,&
+!            wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),&
+!            lamref,epref,tstellar,&
+!            L_NSPECTV,blamv,epavVI,&
+!            omegavVI,gavVI,QREFvis(iaer,isize))!,omegaREFir(iaer,isize))
+            CALL aerave_new ( nwvl,&
+            wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),&
+            lamref,epref,tstellar,&
+            L_NSPECTV,blamv,epavVI,&
+            omegavVI,gavVI,QREFvis(iaer,isize),omegaREFir(iaer,isize))
+
+!     Variable assignments (declared in radcommon)
+            DO isw=1,L_NSPECTV
+               QVISsQREF(isw,iaer,isize)=epavVI(isw)
+               gvis(isw,iaer,isize)=gavVI(isw)
+               omegavis(isw,iaer,isize)=omegavVI(isw)
+            END DO
+
+         ENDDO
+
+!==================================================================
+      CASE(2) domain            !      INFRARED DOMAIN (idomain=2)
+!==================================================================
+
+
+         DO isize=1,nsize(iaer,idomain) ! ----------------------------------
+
+            lamref=lamrefir(iaer)
+            epref=1.E+0
+
+!     Save the particle sizes
+            radiustab(iaer,idomain,isize)=radiusdyn(isize)
+
+!     Averaged optical properties (GCM channels)
+
+!     epav is <QIR>/Qext(lamrefir) since epref=1
+!     Note: aerave also computes the extinction coefficient at
+!     the reference wavelength. This is called QREFvis or QREFir
+!     (not epref, which is a different parameter).
+!     Reference wavelengths SHOULD BE defined for each aerosol in
+!     radcommon_h.F90
+
+!            CALL aerave ( nwvl,&
+!            wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),&
+!            lamref,epref,tplanet,&
+!            L_NSPECTI,blami,epavIR,&
+!            omegavIR,gavIR,QREFir(iaer,isize))!,omegaREFir(iaer,isize))
+            CALL aerave_new ( nwvl,&
+            wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),&
+            lamref,epref,tplanet,&
+            L_NSPECTI,blami,epavIR,&
+            omegavIR,gavIR,QREFir(iaer,isize),omegaREFir(iaer,isize))
+
+
+!     Variable assignments (declared in radcommon)
+            DO ilw=1,L_NSPECTI
+               QIRsQREF(ilw,iaer,isize)=epavIR(ilw)
+               gir(ilw,iaer,isize)=gavIR(ilw)
+               omegair(ilw,iaer,isize)=omegavIR(ilw)
+            END DO
+
+
+      ENDDO                     ! isize (particle size) -------------------------------------
+
+      END SELECT domain
+
+!========================================================================
+!     3. Deallocate temporary variables that were read in the ASCII files
+!========================================================================
+
+      DEALLOCATE(wvl)           ! wvl
+      DEALLOCATE(radiusdyn)     ! radiusdyn
+      DEALLOCATE(ep)            ! ep 
+      DEALLOCATE(omeg)          ! omeg 
+      DEALLOCATE(gfactor)       ! g
+
+      END DO                    ! Loop on iaer
+      END DO                    ! Loop on idomain
+!========================================================================
+
+      RETURN
+
+
+
+    END subroutine suaer_corrk
+      
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sugas_corrk.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sugas_corrk.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/sugas_corrk.F90	(revision 222)
@@ -0,0 +1,661 @@
+      subroutine sugas_corrk
+
+!==================================================================
+!
+!     Purpose
+!     -------
+!     Set up gaseous absorption parameters used by the radiation code.
+!     This subroutine is a replacement for the old 'setrad', which contained
+!     both absorption and scattering data.
+!
+!     Authors
+!     -------
+!     Adapted and generalised from the NASA Ames code by Robin Wordsworth (2009)
+!     Added double gray case by Jeremy Leconte (2012)
+!     New HITRAN continuum data section by RW (2012)
+!
+!     Summary
+!     -------
+!
+!==================================================================
+
+      use radinc_h
+      use radcommon_h, only : pgasref,pfgasref,pgasmin,pgasmax
+      use radcommon_h, only : tgasref,tgasmin,tgasmax
+      use radcommon_h, only : gasv,gasi,FZEROI,FZEROV,gweight
+      use radcommon_h, only : wrefvar,WNOI,WNOV
+      use datafile_mod, only: datadir
+
+      use gases_h
+      use ioipsl_getincom 
+      implicit none
+
+#include "callkeys.h"
+#include "comcstfi.h"
+
+!==================================================================
+
+      logical file_ok
+
+      integer n, nt, np, nh, ng, nw, m, i
+      integer L_NGAUSScheck
+
+      character(len=200) :: file_id
+      character(len=500) :: file_path
+
+      ! ALLOCATABLE ARRAYS -- AS 12/2011
+      REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: gasi8, gasv8
+      character*20,allocatable,DIMENSION(:) :: gastype ! for check with gnom
+
+      real*8 x, xi(4), yi(4), ans, p
+!     For gray case (JL12)
+      real kappa_IR, kappa_VI, IR_VI_wnlimit
+      integer nVI_limit,nIR_limit
+
+      integer ngas, igas, jgas
+
+      double precision testcont ! for continuum absorption initialisation
+
+      integer :: dummy
+
+!=======================================================================
+!     Load variable species data, exit if we have wrong database
+      file_id='/corrk_data/' // TRIM(corrkdir) // '/Q.dat'
+      file_path=TRIM(datadir)//TRIM(file_id)
+
+      ! check that the file exists
+      inquire(FILE=file_path,EXIST=file_ok)
+      if(.not.file_ok) then
+         write(*,*)'The file ',TRIM(file_path)
+         write(*,*)'was not found by sugas_corrk.F90, exiting.'
+         write(*,*)'Check that your path to datagcm:',trim(datadir)
+         write(*,*)' is correct. You can change it in callphys.def with:'
+         write(*,*)' datadir = /absolute/path/to/datagcm'
+         write(*,*)'Also check that the corrkdir you chose in callphys.def exists.'
+         call abort
+      endif
+
+      ! check that database matches varactive toggle
+      open(111,file=TRIM(file_path),form='formatted')
+      read(111,*) ngas
+
+      if(ngas.ne.ngasmx)then
+         print*,'Number of gases in radiative transfer data (',ngas,') does not', &
+                'match that in gases.def (',ngasmx,'), exiting.'
+         call abort
+      endif 
+
+      if(ngas.eq.1 .and. (varactive.or.varfixed))then
+         print*,'You have varactive/fixed=.true. but the database [',  &
+                     corrkdir(1:LEN_TRIM(corrkdir)),           &
+                '] has no variable species, exiting.'
+         call abort
+      elseif(ngas.gt.5 .or. ngas.lt.1)then
+         print*,ngas,' species in database [',               &
+                     corrkdir(1:LEN_TRIM(corrkdir)),           &
+                '], radiative code cannot handle this.'
+         call abort
+      endif 
+
+      ! dynamically allocate gastype and read from Q.dat
+      IF ( .NOT. ALLOCATED( gastype ) ) ALLOCATE( gastype( ngas ) )
+
+      do igas=1,ngas
+         read(111,*) gastype(igas)
+         print*,'Gas ',igas,' is ',gastype(igas)
+      enddo
+
+      ! get array size, load the coefficients
+      open(111,file=TRIM(file_path),form='formatted')
+      read(111,*) L_REFVAR
+      IF( .NOT. ALLOCATED( wrefvar ) ) ALLOCATE( WREFVAR(L_REFVAR) )
+      read(111,*) wrefvar
+      close(111)
+
+      if(L_REFVAR.gt.1 .and. (.not.varactive) .and. (.not.varfixed))then
+         print*,'You have varactive and varfixed=.false. and the database [', &
+                     corrkdir(1:LEN_TRIM(corrkdir)),           &
+                '] has a variable species.'
+         call abort
+      endif
+
+      ! Check that gastype and gnom match
+      do igas=1,ngas
+         print*,'Gas ',igas,' is ',trim(gnom(igas))
+         if (trim(gnom(igas)).ne.trim(gastype(igas))) then
+            print*,'Name of a gas in radiative transfer data (',trim(gastype(igas)),') does not ', &
+                 'match that in gases.def (',trim(gnom(igas)),'), exiting. You should compare ', &
+                 'gases.def with Q.dat in your radiative transfer directory.' 
+            call abort
+         endif
+      enddo
+      print*,'Confirmed gas match in radiative transfer and gases.def!'
+
+      ! display the values
+      print*,'Variable gas volume mixing ratios:'
+      do n=1,L_REFVAR
+         !print*,n,'.',wrefvar(n),' kg/kg' ! pay attention!
+         print*,n,'.',wrefvar(n),' mol/mol'
+      end do
+      print*,''
+
+!=======================================================================
+!     Set the weighting in g-space
+
+      file_id='/corrk_data/' // TRIM(corrkdir) // '/g.dat'
+      file_path=TRIM(datadir)//TRIM(file_id)
+
+      ! check that the file exists
+      inquire(FILE=file_path,EXIST=file_ok)
+      if(.not.file_ok) then
+         write(*,*)'The file ',TRIM(file_path)
+         write(*,*)'was not found by sugas_corrk.F90, exiting.'
+         write(*,*)'Check that your path to datagcm:',trim(datadir)
+         write(*,*)' is correct. You can change it in callphys.def with:'
+         write(*,*)' datadir = /absolute/path/to/datagcm'
+         write(*,*)'Also check that the corrkdir you chose in callphys.def exists.'
+         call abort
+      endif
+      
+      ! check the array size is correct, load the coefficients
+      open(111,file=TRIM(file_path),form='formatted')
+      read(111,*) L_NGAUSScheck
+      if(.not.(L_NGAUSScheck.eq.L_NGAUSS)) then
+         print*,'The size of your radiative transfer g-space array does '
+         print*,'not match the value given in g.dat, exiting.'
+         call abort
+      endif
+      read(111,*) gweight
+      close(111)
+ 
+      ! display the values
+      print*,'Correlated-k g-space grid:'
+      do n=1,L_NGAUSS
+         print*,n,'.',gweight(n)
+      end do
+      print*,''
+
+!=======================================================================
+!     Set the reference pressure and temperature arrays.  These are
+!     the pressures and temperatures at which we have k-coefficients.
+
+!-----------------------------------------------------------------------
+! pressure
+
+      file_id='/corrk_data/' // TRIM(corrkdir) // '/p.dat'
+      file_path=TRIM(datadir)//TRIM(file_id)
+
+      ! check that the file exists
+      inquire(FILE=file_path,EXIST=file_ok)
+      if(.not.file_ok) then
+         write(*,*)'The file ',TRIM(file_path)
+         write(*,*)'was not found by sugas_corrk.F90, exiting.'
+         write(*,*)'Check that your path to datagcm:',trim(datadir)
+         write(*,*)' is correct. You can change it in callphys.def with:'
+         write(*,*)' datadir = /absolute/path/to/datagcm'
+         write(*,*)'Also check that the corrkdir you chose in callphys.def exists.'
+         call abort
+      endif
+     
+      ! get array size, load the coefficients
+      open(111,file=TRIM(file_path),form='formatted')
+      read(111,*) L_NPREF
+      IF( .NOT. ALLOCATED( pgasref ) ) ALLOCATE( PGASREF(L_NPREF) )
+      read(111,*) pgasref
+      close(111)
+      L_PINT = (L_NPREF-1)*5+1
+      IF( .NOT. ALLOCATED( pfgasref ) ) ALLOCATE( PFGASREF(L_PINT) )
+
+      ! display the values
+      print*,'Correlated-k pressure grid (mBar):'
+      do n=1,L_NPREF
+         print*,n,'. 1 x 10^',pgasref(n),' mBar'
+      end do
+      print*,''
+
+      ! save the min / max matrix values
+      pgasmin = 10.0**pgasref(1)
+      pgasmax = 10.0**pgasref(L_NPREF)
+
+      ! interpolate to finer grid
+      do n=1,L_NPREF-1
+         do m=1,5
+            pfgasref((n-1)*5+m) = pgasref(n)+(m-1)*0.2
+         end do
+      end do
+      pfgasref(L_PINT) = pgasref(L_NPREF)
+      ! Warning, pfgasref needs generalisation to uneven grids!
+
+!-----------------------------------------------------------------------
+! temperature
+
+      file_id='/corrk_data/' // TRIM(corrkdir) // '/T.dat'
+      file_path=TRIM(datadir)//TRIM(file_id)
+
+      ! check that the file exists
+      inquire(FILE=file_path,EXIST=file_ok)
+      if(.not.file_ok) then
+         write(*,*)'The file ',TRIM(file_path)
+         write(*,*)'was not found by sugas_corrk.F90, exiting.'
+         write(*,*)'Check that your path to datagcm:',trim(datadir)
+         write(*,*)' is correct. You can change it in callphys.def with:'
+         write(*,*)' datadir = /absolute/path/to/datagcm'
+         write(*,*)'Also check that the corrkdir you chose in callphys.def exists.'
+         call abort
+      endif
+
+      ! get array size, load the coefficients
+      open(111,file=TRIM(file_path),form='formatted')
+      read(111,*) L_NTREF
+      IF( .NOT. ALLOCATED( tgasref ) ) ALLOCATE( TGASREF(L_NTREF) )
+      read(111,*) tgasref
+      close(111)
+
+      ! display the values
+      print*,'Correlated-k temperature grid:'
+      do n=1,L_NTREF
+         print*,n,'.',tgasref(n),' K'
+      end do
+
+      ! save the min / max matrix values
+      tgasmin = tgasref(1)
+      tgasmax = tgasref(L_NTREF)
+
+!-----------------------------------------------------------------------
+! allocate the multidimensional arrays in radcommon_h
+
+      IF( .NOT. ALLOCATED( gasi8 ) ) ALLOCATE( gasi8(L_NTREF,L_NPREF,L_REFVAR,L_NSPECTI,L_NGAUSS) )
+      IF( .NOT. ALLOCATED( gasv8 ) ) ALLOCATE( gasv8(L_NTREF,L_NPREF,L_REFVAR,L_NSPECTV,L_NGAUSS) )
+      IF( .NOT. ALLOCATED( gasi ) ) ALLOCATE( gasi(L_NTREF,L_PINT,L_REFVAR,L_NSPECTI,L_NGAUSS) )
+      IF( .NOT. ALLOCATED( gasv ) ) ALLOCATE( gasv(L_NTREF,L_PINT,L_REFVAR,L_NSPECTV,L_NGAUSS) )
+
+      ! display the values
+      print*,''
+      print*,'Correlated-k matrix size:' 
+      print*,'[',L_NTREF,',',L_NPREF,',',L_REFVAR,',',L_NGAUSS,']' 
+
+!=======================================================================
+!     Get gaseous k-coefficients and interpolate onto finer pressure grid
+
+
+!        wavelength used to separate IR from VI in graybody. We will need that anyway
+         IR_VI_wnlimit=3000.
+         write(*,*)"graybody: Visible / Infrared separation set at",10000./IR_VI_wnlimit,"um"
+	 
+	 nVI_limit=0
+	 Do nw=1,L_NSPECTV
+	    if ((WNOV(nw).gt.IR_VI_wnlimit).and.(L_NSPECTV.gt.1)) then
+	       nVI_limit=nw-1
+	       exit
+	    endif
+	 End do
+	 nIR_limit=L_NSPECTI
+	 Do nw=1,L_NSPECTI
+	    if ((WNOI(nw).gt.IR_VI_wnlimit).and.(L_NSPECTI.gt.1)) then
+	       nIR_limit=nw-1
+	       exit
+	    endif
+	 End do
+
+      if (graybody) then
+!        constant absorption coefficient in visible
+         write(*,*)"graybody: constant absorption coefficient in visible:"
+         kappa_VI=-100000.
+         call getin("kappa_VI",kappa_VI)
+         write(*,*)" kappa_VI = ",kappa_VI
+	 kappa_VI=kappa_VI*1.e4* mugaz * 1.672621e-27	 ! conversion from m^2/kg to cm^2/molecule         
+      
+!        constant absorption coefficient in IR
+         write(*,*)"graybody: constant absorption coefficient in InfraRed:"
+         kappa_IR=-100000.
+         call getin("kappa_IR",kappa_IR)
+         write(*,*)" kappa_IR = ",kappa_IR	 
+         kappa_IR=kappa_IR*1.e4* mugaz * 1.672621e-27	 ! conversion from m^2/kg to cm^2/molecule 
+
+         write(*,*)"graybody: Visible / Infrared separation set at band: IR=",nIR_limit,", VI=",nVI_limit
+	       
+      Else
+         kappa_VI=1.e-30      
+         kappa_IR=1.e-30        
+      End if
+
+!      print*,corrkdir(1:4)
+      ! VISIBLE
+      if (callgasvis) then
+         if ((corrkdir(1:4).eq.'null'))then   !(TRIM(corrkdir).eq.'null_LowTeffStar')) then
+            gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTV,1:L_NGAUSS)=0.0
+            print*,'using no corrk data'
+            print*,'Visible corrk gaseous absorption is set to zero if graybody=F'
+	 else
+            file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_VI.dat' 
+            file_path=TRIM(datadir)//TRIM(file_id)
+            
+            ! check that the file exists
+            inquire(FILE=file_path,EXIST=file_ok)
+            if(.not.file_ok) then
+               write(*,*)'The file ',TRIM(file_path)
+               write(*,*)'was not found by sugas_corrk.F90.'
+               write(*,*)'Are you sure you have absorption data for these bands?'
+               call abort
+            endif
+         
+            open(111,file=TRIM(file_path),form='formatted')
+            read(111,*) gasv8
+            close(111)
+	 end if
+
+         if(nVI_limit.eq.0) then
+	    gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTV,1:L_NGAUSS)=   &
+	          gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTV,1:L_NGAUSS)+kappa_VI
+         else if (nVI_limit.eq.L_NSPECTV) then
+	    gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTV,1:L_NGAUSS)=   &
+	          gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTV,1:L_NGAUSS)+kappa_IR
+	 else
+	    gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:nVI_limit,1:L_NGAUSS)=   &
+	          gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:nVI_limit,1:L_NGAUSS)+kappa_IR
+	    gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,nVI_limit+1:L_NSPECTV,1:L_NGAUSS)=   &
+	          gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,nVI_limit+1:L_NSPECTV,1:L_NGAUSS)+kappa_VI
+	 end if
+      else
+         print*,'Visible corrk gaseous absorption is set to zero.'
+         gasv8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTV,1:L_NGAUSS)=0.0
+      endif
+
+      ! INFRA-RED
+      if ((corrkdir(1:4).eq.'null'))then       !.or.(TRIM(corrkdir).eq.'null_LowTeffStar')) then
+         print*,'Infrared corrk gaseous absorption is set to zero if graybody=F'
+         gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTI,1:L_NGAUSS)=0.0
+      else  
+         file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_IR.dat' 
+         file_path=TRIM(datadir)//TRIM(file_id)
+      
+         ! check that the file exists
+         inquire(FILE=file_path,EXIST=file_ok)
+         if(.not.file_ok) then
+            write(*,*)'The file ',TRIM(file_path)
+            write(*,*)'was not found by sugas_corrk.F90.'
+            write(*,*)'Are you sure you have absorption data for these bands?'
+            call abort
+         endif
+         
+         open(111,file=TRIM(file_path),form='formatted')
+         read(111,*) gasi8
+         close(111)
+     
+         ! 'fzero' is a currently unused feature that allows optimisation
+         ! of the radiative transfer by neglecting bands where absorption
+         ! is close to zero. As it could be useful in the future, this 
+         ! section of the code has been kept commented and not erased.
+         ! RW 7/3/12.
+
+         do nw=1,L_NSPECTI
+            fzeroi(nw) = 0.d0
+!            do nt=1,L_NTREF
+!               do np=1,L_NPREF
+!                  do nh=1,L_REFVAR
+!                     do ng = 1,L_NGAUSS
+!                        if(gasi8(nt,np,nh,nw,ng).lt.1.0e-25)then
+!                           fzeroi(nw)=fzeroi(nw)+1.d0
+!                        endif
+!                     end do
+!                  end do
+!               end do
+!            end do
+!            fzeroi(nw)=fzeroi(nw)/dble(L_NTREF*L_NPREF*L_REFVAR*L_NGAUSS)
+         end do
+
+         do nw=1,L_NSPECTV
+            fzerov(nw) = 0.d0
+!            do nt=1,L_NTREF
+!               do np=1,L_NPREF
+!                  do nh=1,L_REFVAR
+!                     do ng = 1,L_NGAUSS
+!                        if(gasv8(nt,np,nh,nw,ng).lt.1.0e-25)then
+!                           fzerov(nw)=fzerov(nw)+1.d0
+!                        endif
+!                     end do
+!                  end do
+!               end do
+!            end do
+!            fzerov(nw)=fzerov(nw)/dble(L_NTREF*L_NPREF*L_REFVAR*L_NGAUSS)
+         end do
+
+      endif
+
+      if(nIR_limit.eq.0) then
+         gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTI,1:L_NGAUSS)=   &
+	          gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTI,1:L_NGAUSS)+kappa_VI
+      else if (nIR_limit.eq.L_NSPECTI) then
+	 gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTI,1:L_NGAUSS)=   &
+	          gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:L_NSPECTI,1:L_NGAUSS)+kappa_IR
+      else
+	 gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:nIR_limit,1:L_NGAUSS)=   &
+	          gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,1:nIR_limit,1:L_NGAUSS)+kappa_IR
+	 gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,nIR_limit+1:L_NSPECTI,1:L_NGAUSS)=   &
+	          gasi8(1:L_NTREF,1:L_NPREF,1:L_REFVAR,nIR_limit+1:L_NSPECTI,1:L_NGAUSS)+kappa_VI
+      end if
+
+
+!     Take log10 of the values - this is what we will interpolate.
+!     Smallest value is 1.0E-200.
+
+      do nt=1,L_NTREF
+         do np=1,L_NPREF
+            do nh=1,L_REFVAR
+               do ng = 1,L_NGAUSS
+
+                  do nw=1,L_NSPECTV
+                     if(gasv8(nt,np,nh,nw,ng).gt.1.0d-200) then
+                        gasv8(nt,np,nh,nw,ng) = log10(gasv8(nt,np,nh,nw,ng))
+                     else
+                        gasv8(nt,np,nh,nw,ng) = -200.0
+                     end if
+                  end do
+
+                  do nw=1,L_NSPECTI
+                     if(gasi8(nt,np,nh,nw,ng).gt.1.0d-200) then
+                        gasi8(nt,np,nh,nw,ng) = log10(gasi8(nt,np,nh,nw,ng))
+                     else
+                        gasi8(nt,np,nh,nw,ng) = -200.0
+                     end if
+                  end do
+                  
+               end do
+            end do
+         end do
+      end do
+
+!     Interpolate the values:  first the longwave
+
+      do nt=1,L_NTREF
+         do nh=1,L_REFVAR
+            do nw=1,L_NSPECTI
+               do ng=1,L_NGAUSS
+
+!     First, the initial interval
+
+                  n = 1 
+                  do m=1,5
+                     x     = pfgasref(m)
+                     xi(1) = pgasref(n)
+                     xi(2) = pgasref(n+1)
+                     xi(3) = pgasref(n+2)
+                     xi(4) = pgasref(n+3)
+                     yi(1) = gasi8(nt,n,nh,nw,ng)
+                     yi(2) = gasi8(nt,n+1,nh,nw,ng)
+                     yi(3) = gasi8(nt,n+2,nh,nw,ng)
+                     yi(4) = gasi8(nt,n+3,nh,nw,ng)
+                     call lagrange(x,xi,yi,ans)
+                     gasi(nt,m,nh,nw,ng) = 10.0**ans
+                  end do 
+                  
+                  do n=2,L_NPREF-2
+                     do m=1,5
+                        i     = (n-1)*5+m
+                        x     = pfgasref(i)
+                        xi(1) = pgasref(n-1)
+                        xi(2) = pgasref(n)
+                        xi(3) = pgasref(n+1)
+                        xi(4) = pgasref(n+2)
+                        yi(1) = gasi8(nt,n-1,nh,nw,ng)
+                        yi(2) = gasi8(nt,n,nh,nw,ng)
+                        yi(3) = gasi8(nt,n+1,nh,nw,ng)
+                        yi(4) = gasi8(nt,n+2,nh,nw,ng)
+                        call lagrange(x,xi,yi,ans)
+                        gasi(nt,i,nh,nw,ng) = 10.0**ans
+                     end do 
+                  end do
+
+!     Now, get the last interval
+
+                  n = L_NPREF-1                 
+                  do m=1,5
+                     i     = (n-1)*5+m
+                     x     = pfgasref(i)
+                     xi(1) = pgasref(n-2)
+                     xi(2) = pgasref(n-1)
+                     xi(3) = pgasref(n)
+                     xi(4) = pgasref(n+1)
+                     yi(1) = gasi8(nt,n-2,nh,nw,ng)
+                     yi(2) = gasi8(nt,n-1,nh,nw,ng)
+                     yi(3) = gasi8(nt,n,nh,nw,ng)
+                     yi(4) = gasi8(nt,n+1,nh,nw,ng)
+                     call lagrange(x,xi,yi,ans)
+                     gasi(nt,i,nh,nw,ng) = 10.0**ans
+                  end do  
+
+!     Fill the last pressure point
+
+                  gasi(nt,L_PINT,nh,nw,ng) = &
+                       10.0**gasi8(nt,L_NPREF,nh,nw,ng)
+
+               end do
+            end do
+         end do
+      end do
+
+!     Interpolate the values:  now the shortwave
+
+      do nt=1,L_NTREF
+         do nh=1,L_REFVAR
+            do nw=1,L_NSPECTV
+               do ng=1,L_NGAUSS
+
+!     First, the initial interval
+
+                  n = 1 
+                  do m=1,5
+                     x     = pfgasref(m)
+                     xi(1) = pgasref(n)
+                     xi(2) = pgasref(n+1)
+                     xi(3) = pgasref(n+2)
+                     xi(4) = pgasref(n+3)
+                     yi(1) = gasv8(nt,n,nh,nw,ng)
+                     yi(2) = gasv8(nt,n+1,nh,nw,ng)
+                     yi(3) = gasv8(nt,n+2,nh,nw,ng)
+                     yi(4) = gasv8(nt,n+3,nh,nw,ng)
+                     call lagrange(x,xi,yi,ans)
+                     gasv(nt,m,nh,nw,ng) = 10.0**ans
+                  end do 
+                  
+                  do n=2,L_NPREF-2
+                     do m=1,5
+                        i     = (n-1)*5+m
+                        x     = pfgasref(i)
+                        xi(1) = pgasref(n-1)
+                        xi(2) = pgasref(n)
+                        xi(3) = pgasref(n+1)
+                        xi(4) = pgasref(n+2)
+                        yi(1) = gasv8(nt,n-1,nh,nw,ng)
+                        yi(2) = gasv8(nt,n,nh,nw,ng)
+                        yi(3) = gasv8(nt,n+1,nh,nw,ng)
+                        yi(4) = gasv8(nt,n+2,nh,nw,ng)
+                        call lagrange(x,xi,yi,ans)
+                        gasv(nt,i,nh,nw,ng) = 10.0**ans
+                     end do 
+                  end do
+
+!     Now, get the last interval
+
+                  n = L_NPREF-1
+                  do m=1,5
+                     i     = (n-1)*5+m
+                     x     = pfgasref(i)
+                     xi(1) = pgasref(n-2)
+                     xi(2) = pgasref(n-1)
+                     xi(3) = pgasref(n)
+                     xi(4) = pgasref(n+1)
+                     yi(1) = gasv8(nt,n-2,nh,nw,ng)
+                     yi(2) = gasv8(nt,n-1,nh,nw,ng)
+                     yi(3) = gasv8(nt,n,nh,nw,ng)
+                     yi(4) = gasv8(nt,n+1,nh,nw,ng)
+                     call lagrange(x,xi,yi,ans)
+                     gasv(nt,i,nh,nw,ng) = 10.0**ans
+                  end do  
+
+!     Fill the last pressure point
+
+                  gasv(nt,L_PINT,nh,nw,ng) = &
+                      10.0**gasv8(nt,L_NPREF,nh,nw,ng)
+                  
+               end do
+            end do
+         end do
+      end do
+
+
+!=======================================================================
+!     Initialise the continuum absorption data
+      if(continuum)then
+      do igas=1,ngasmx
+
+         if (igas .eq. igas_N2) then
+
+            dummy = -9999
+            call interpolateN2N2(100.D+0,250.D+0,17500.D+0,testcont,.true.,dummy)
+
+         elseif (igas .eq. igas_H2) then
+
+            ! first do self-induced absorption
+            dummy = -9999
+            call interpolateH2H2(500.D+0,250.D+0,17500.D+0,testcont,.true.,dummy)
+            ! then cross-interactions with other gases
+            do jgas=1,ngasmx
+               if (jgas .eq. igas_N2) then
+                  dummy = -9999
+                  call interpolateN2H2(592.D+0,278.15D+0,200000.D+0,10000.D+0,testcont,.true.,dummy)
+               elseif (jgas .eq. igas_He) then
+                  dummy = -9999
+                  call interpolateH2He(500.D+0,250.D+0,200000.D+0,10000.D+0,testcont,.true.,dummy)
+               endif
+            enddo
+
+         elseif (igas .eq. igas_H2O) then
+
+            ! H2O is special 
+            if(H2Ocont_simple)then
+               call interpolateH2Ocont_PPC(990.D+0,296.D+0,683.2D+0*2,0.D+0,testcont,.true.)
+            else
+               dummy = -9999
+               call interpolateH2Ocont_CKD(990.D+0,296.D+0,683.2D+0*2,0.D+0,testcont,.true.,dummy)
+            endif
+
+         endif
+
+      enddo
+      endif
+
+      print*,'----------------------------------------------------'
+      print*,'And that`s all we have. It`s possible that other'
+      print*,'continuum absorption may be present, but if it is we'
+      print*,'don`t yet have data for it...'
+      print*,''
+
+!     Deallocate local arrays
+      IF( ALLOCATED( gasi8 ) ) DEALLOCATE( gasi8 )
+      IF( ALLOCATED( gasv8 ) ) DEALLOCATE( gasv8 )
+      IF( ALLOCATED( pgasref ) ) DEALLOCATE( pgasref )
+      IF( ALLOCATED( gastype ) ) DEALLOCATE( gastype )
+
+      return
+    end subroutine sugas_corrk
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surf_heat_transp_mod.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surf_heat_transp_mod.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surf_heat_transp_mod.F90	(revision 222)
@@ -0,0 +1,233 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ocean_slab_mod.F90,v 1.3 2008-02-04 16:24:28 fairhead Exp $
+!
+MODULE surf_heat_transp_mod
+
+
+CONTAINS
+
+      SUBROUTINE divgrad_phy(nlevs,temp,delta)
+
+
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+#include "comcstfi.h"
+#include "comgeom.h"
+#include "comhdiff.h"
+      
+      INTEGER nlevs, ll
+      REAL temp(ngridmx,nlevs)
+      REAL delta_2d(ip1jmp1,nlevs)
+      REAL delta(ngridmx,nlevs)
+      REAL ghx(ip1jmp1,nlevs), ghy(ip1jm,nlevs)
+
+
+      CALL gr_fi_dyn(nlevs,ngridmx,iip1,jjp1,temp,delta_2d)
+      CALL grad(nlevs,delta_2d,ghx,ghy)
+      DO ll=1,nlevs
+          ghx(:,ll)=ghx(:,ll)*zmasqu
+! pas de diffusion zonale  
+!          ghx(:,ll)=0.
+          ghy(:,ll)=ghy(:,ll)*zmasqv
+      END DO
+      CALL diverg(nlevs,ghx,ghy,delta_2d)
+      CALL gr_dyn_fi(nlevs,iip1,jjp1,ngridmx,delta_2d,delta)
+
+
+  END SUBROUTINE divgrad_phy
+
+
+
+      SUBROUTINE init_masquv(zmasq)
+     
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+#include "comcstfi.h"   
+#include "comgeom.h"
+#include "comhdiff.h"
+
+
+      REAL zmasq(ngridmx)
+      REAL zmasq_2d(ip1jmp1)
+      REAL ff(ip1jm)
+      REAL eps
+      INTEGER i
+
+
+! Masques u,v
+      zmasqu=1.
+      zmasqv=1.
+
+      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zmasq,zmasq_2d)
+
+      DO i=1,ip1jmp1-1
+        IF (zmasq_2d(i).GT.1e-5 .OR. zmasq_2d(i+1).GT.1e-5) THEN
+                zmasqu(i)=0.
+        ENDIF
+      END DO
+      DO i=iip1,ip1jmp1,iip1
+        zmasqu(i)=zmasqu(i-iim)
+      END DO
+      DO i=1,ip1jm
+        IF (zmasq_2d(i).GT.1e-5 .OR. zmasq_2d(i+iip1).GT.1e-5) THEN  
+                zmasqv(i)=0.
+        END IF
+      END DO
+
+
+! Coriolis (pour Ekman transp.)
+      eps=1e-5
+!      CALL getin('slab_eps',eps)
+!      print *,'epsilon=',eps
+      ff=fext*unsairez       
+      DO i=1,ip1jm
+        unsev(i)=eps/(ff(i)*ff(i)+eps**2)
+        unsfv(i)=ff(i)/(ff(i)*ff(i)+eps**2)
+      ENDDO
+      CALL gr_v_scal(1,unsfv,unsfu)
+      CALL gr_v_scal(1,unsev,unseu)
+! Alpha variable?
+!      alpha_var=.FALSE.
+!      CALL getin('slab_alphav',alpha_var)
+
+
+      
+  END SUBROUTINE init_masquv
+
+
+
+      SUBROUTINE slab_ekman2(tx_phy,ty_phy,ts_phy,dt_phy)
+  
+          use slab_ice_h 
+
+      IMPLICIT NONE
+      
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comgeom.h"
+#include "comhdiff.h"
+
+      INTEGER ij
+      REAL txv(ip1jm),fluxm(ip1jm),tyv(ip1jm)
+      REAL fluxtm(ip1jm,noceanmx),fluxtz(ip1jmp1,noceanmx)
+      REAL tyu(ip1jmp1),txu(ip1jmp1),fluxz(ip1jmp1),fluxv(ip1jmp1)
+      REAL dt(ip1jmp1,noceanmx),ts(ip1jmp1,noceanmx)
+      REAL tx_phy(ngridmx),ty_phy(ngridmx)
+      REAL dt_phy(ngridmx,noceanmx),ts_phy(ngridmx,noceanmx)
+
+
+
+
+! Passage taux,y sur grilles 2d
+      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,tx_phy,txu)
+      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,ty_phy,tyu)
+! Passage grille u,v
+! Multiplication par f ou eps.
+      CALL gr_v_scal(1,txu,txv)
+      CALL gr_v_scal(1,tyu,tyv)
+      fluxm=tyv*unsev-txv*unsfv
+!      fluxm=-txv*unsfv
+      CALL gr_u_scal(1,txu,txu)
+      CALL gr_u_scal(1,tyu,tyu)
+      fluxz=tyu*unsfu+txu*unseu
+!      fluxz=tyu*unsfu
+            
+! Calcul de T, Tdeep
+      CALL gr_fi_dyn(2,ngridmx,iip1,jjp1,ts_phy,ts)
+       
+! Flux de masse
+      fluxm=fluxm*cv*cuvsurcv*zmasqv
+      fluxz=fluxz*cu*cvusurcu*zmasqu
+! Flux de masse vertical
+      DO ij=iip2,ip1jm
+        fluxv(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
+      ENDDO
+      DO ij=iip1,ip1jmi1,iip1
+         fluxv(ij+1)=fluxv(ij+iip1)
+      END DO
+! Poles
+      fluxv(1)=-SUM(fluxm(1:iim))     
+      fluxv(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
+      fluxv=fluxv
+
+!Calcul flux de chaleur méridiens
+      DO ij=1,ip1jm
+          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
+          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
+      END DO
+
+!Calcul flux chaleur zonaux
+      DO ij=iip2,ip1jm
+      IF (fluxz(ij).GE.0.) THEN
+             fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
+             fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
+      ELSE
+             fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
+             fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
+      ENDIF
+      END DO
+      DO ij=iip1*2,ip1jmp1,iip1
+             fluxtz(ij,:)=fluxtz(ij-iim,:)
+      END DO
+                   
+! Calcul de dT
+      DO ij=iip2,ip1jm
+         dt(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:)   &
+                  +fluxtm(ij,:)-fluxtm(ij-iip1,:)
+         IF (fluxv(ij).GT.0.) THEN
+           dt(ij,1)=dt(ij,1)+fluxv(ij)*ts(ij,2)
+           dt(ij,2)=dt(ij,2)-fluxv(ij)*ts(ij,2)
+         ELSE
+           dt(ij,1)=dt(ij,1)+fluxv(ij)*ts(ij,1)
+           dt(ij,2)=dt(ij,2)-fluxv(ij)*ts(ij,1)
+         ENDIF
+         dt(ij,:)=dt(ij,:)/aire(ij)
+      END DO
+      DO ij=iip1,ip1jmi1,iip1
+         dt(ij+1,:)=dt(ij+iip1,:) 
+      END DO
+! Pôles
+      dt(1,:)=SUM(fluxtm(1:iim,:),dim=1)
+        IF (fluxv(1).GT.0.) THEN
+          dt(1,1)=dt(1,1)+fluxv(1)*ts(1,2)
+          dt(1,2)=dt(1,2)-fluxv(1)*ts(1,2)
+        ELSE
+          dt(1,1)=dt(1,1)+fluxv(1)*ts(1,1)
+          dt(1,2)=dt(1,2)-fluxv(1)*ts(1,1)
+        ENDIF
+      dt(1,:)=dt(1,:)/apoln
+      dt(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
+       IF (fluxv(ip1jmp1).GT.0.) THEN
+         dt(ip1jmp1,1)=dt(ip1jmp1,1)+fluxv(ip1jmp1)*ts(ip1jmp1,2)
+         dt(ip1jmp1,2)=dt(ip1jmp1,2)-fluxv(ip1jmp1)*ts(ip1jmp1,2)
+       ELSE
+         dt(ip1jmp1,1)=dt(ip1jmp1,1)+fluxv(ip1jmp1)*ts(ip1jmp1,1)
+         dt(ip1jmp1,2)=dt(ip1jmp1,2)-fluxv(ip1jmp1)*ts(ip1jmp1,1)
+       ENDIF
+      dt(ip1jmp1,:)=dt(ip1jmp1,:)/apols
+      dt(2:iip1,1)=dt(1,1)
+      dt(2:iip1,2)=dt(1,2)
+      dt(ip1jm+1:ip1jmp1,1)=dt(ip1jmp1,1)
+      dt(ip1jm+1:ip1jmp1,2)=dt(ip1jmp1,2)
+
+! Retour grille physique
+      CALL gr_dyn_fi(2,iip1,jjp1,ngridmx,dt,dt_phy)
+
+
+  END SUBROUTINE slab_ekman2
+
+ 
+END MODULE surf_heat_transp_mod
+
+
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surface_nature.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surface_nature.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surface_nature.F	(revision 222)
@@ -0,0 +1,69 @@
+      SUBROUTINE surface_nature(ngrid,nq,obliquit,qsurf,qsurfliquid
+     &   ,qsurfsnow,rnat,oceanarea)
+
+      USE surfdat_h
+      USE comsoil_h
+      USE comgeomfi_h
+      USE tracer_h
+
+      IMPLICIT none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Defines a few things
+!     
+!     Authors
+!     ------- 
+!     B. Charnay (2010)
+!     
+!     Called by
+!     ---------
+!     physiq.F
+!     
+!     Calls
+!     -----
+!     none
+!
+!     Notes
+!     -----
+!     rnat is terrain type: 0-ocean; 1-continent; 2-continental ice
+!     
+!==================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+        integer ngrid,nq
+
+	REAL qsurf(ngrid,nq),ps(ngrid)
+	REAL qsurfliquid(ngrid)
+	REAL qsurfsnow(ngrid)
+	INTEGER iq, ig
+	INTEGER rnat(ngrid)
+ 	REAL oceanarea
+	REAL obliquit
+
+	do ig=1,ngrid
+           rnat(ig)=1
+           dryness(ig)=1        !(coefficient for evaporation)
+           if (inertiedat(ig,1).gt.1E4) then
+              rnat(ig)=0
+           end if
+	end do
+
+! surface of all the oceans
+        
+        oceanarea=0.
+	do ig=1,ngrid
+           if (rnat(ig).eq.0)then
+              oceanarea=oceanarea+area(ig)
+           end if
+	enddo
+
+        return
+        end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surfdat_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surfdat_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surfdat_h.F90	(revision 222)
@@ -0,0 +1,22 @@
+
+       module surfdat_h
+
+       implicit none
+
+       real,allocatable,dimension(:) :: albedodat ! albedo of bare ground
+       ! Ehouarn: moved inertiedat to comsoil.h
+       !      real inertiedat, ! thermal inertia
+       real,allocatable,dimension(:) :: phisfi ! geopotential at ground level
+       real,dimension(2) :: albedice
+       real,dimension(2) :: emisice ! ice emissivity; 1:Northern hemisphere 2:Southern hemisphere
+       real emissiv
+       real,dimension(2) :: iceradius, dtemisice
+       real,allocatable,dimension(:) :: zmea,zstd,zsig,zgam,zthe
+
+       real,allocatable,dimension(:) :: dryness  !"Dryness coefficient" for grnd water ice sublimation
+                                                 ! AS: previously in tracer.h. it is more logical here.
+
+       logical,allocatable,dimension(:) :: watercaptag !! was in watercap.h
+
+       end module surfdat_h
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surfini.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surfini.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/surfini.F	(revision 222)
@@ -0,0 +1,63 @@
+      SUBROUTINE surfini(ngrid,nq,qsurf,psolaralb)
+
+      USE surfdat_h, only: albedodat, albedice
+      USE tracer_h, only: igcm_co2_ice
+      use comgeomfi_h, only: lati
+      use planetwide_mod, only: planetwide_maxval, planetwide_minval
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   creation des calottes pour l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+c
+      INTEGER,INTENT(IN) :: ngrid
+      INTEGER,INTENT(IN) :: nq
+      REAL,INTENT(OUT) :: psolaralb(ngrid)
+      REAL,INTENT(IN) :: qsurf(ngrid,nq) !tracer on surface (kg/m2)
+
+      INTEGER :: ig,icap
+      REAL :: min_albedo,max_albedo
+c
+c=======================================================================
+
+
+      DO ig=1,ngrid
+         psolaralb(ig)=albedodat(ig)
+      ENDDO
+
+      call planetwide_minval(albedodat,min_albedo)
+      call planetwide_maxval(albedodat,max_albedo)
+      write(*,*) 'surfini: minimum corrected albedo',min_albedo
+      write(*,*) 'surfini: maximum corrected albedo',max_albedo
+
+      if (igcm_co2_ice.ne.0) then
+! Change Albedo if there is CO2 ice on the surface
+        DO ig=1,ngrid
+          IF (qsurf(ig,igcm_co2_ice) .GT. 0.) THEN
+             IF(lati(ig).LT.0.) THEN
+                icap=2 ! Southern hemisphere
+             ELSE
+                icap=1 ! Northern hemisphere
+             ENDIF
+             psolaralb(ig) = albedice(icap)
+          END IF
+        ENDDO ! of DO ig=1,ngrid     
+      else
+        write(*,*) "surfini: No CO2 ice tracer on surface  ..."
+        write(*,*) "         and therefore no albedo change."
+      endif
+
+      call planetwide_minval(psolaralb,min_albedo)
+      call planetwide_maxval(psolaralb,max_albedo)
+      write(*,*) 'surfini: minimum corrected albedo',min_albedo
+      write(*,*) 'surfini: maximum corrected albedo',max_albedo
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tabfi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tabfi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tabfi.F	(revision 222)
@@ -0,0 +1,544 @@
+c=======================================================================
+      SUBROUTINE tabfi(ngrid,nid,Lmodif,tab0,day_ini,lmax,p_rad,
+     .                 p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
+c=======================================================================
+c
+c   C. Hourdin 15/11/96
+c
+c   Object:        Lecture du tab_cntrl physique dans un fichier 
+c   ------            et initialisation des constantes physiques
+c
+c   Arguments:
+c   ----------
+c
+c     Inputs:
+c     ------
+c
+c      - nid:    unitne logique du fichier ou on va lire le tab_cntrl    
+c                      (ouvert dans le programme appellant) 
+c
+c                 si nid=0:
+c                       pas de lecture du tab_cntrl mais
+c                       Valeurs par default des constantes physiques
+c        
+c      - tab0:    Offset de tab_cntrl a partir duquel sont ranges 
+c                  les parametres physiques (50 pour start_archive)
+c
+c      - Lmodif:  si on souhaite modifier les constantes  Lmodif = 1 = TRUE
+c
+c
+c     Outputs:
+c     --------
+c
+c      - day_ini: tab_cntrl(tab0+3) (Dans les cas ou l'on souhaite
+c                              comparer avec le day_ini dynamique)
+c
+c      - lmax:    tab_cntrl(tab0+2) (pour test avec nlayermx)
+c
+c      - p_rad
+c      - p_omeg   !
+c      - p_g      ! Constantes physiques ayant des 
+c      - p_mugaz  ! homonymes dynamiques
+c      - p_daysec !
+c
+c=======================================================================
+! to use  'getin'
+      use ioipsl_getincom , only: getin
+
+      use surfdat_h, only: albedice, emisice, iceradius, dtemisice,
+     &                     emissiv
+      use comsoil_h, only: volcapa
+      use iostart, only: get_var
+      use mod_phys_lmdz_para, only: is_parallel
+
+      implicit none
+ 
+#include "comcstfi.h"
+#include "planete.h"
+#include "netcdf.inc"
+#include "callkeys.h"
+
+c-----------------------------------------------------------------------
+c   Declarations
+c-----------------------------------------------------------------------
+
+c Arguments
+c ---------
+      INTEGER,INTENT(IN) :: ngrid,nid,tab0
+      INTEGER*4,INTENT(OUT) :: day_ini
+      INTEGER,INTENT(IN) :: Lmodif
+      INTEGER,INTENT(OUT) :: lmax
+      REAL,INTENT(OUT) :: p_rad,p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time
+
+c Variables
+c ---------
+      INTEGER,PARAMETER :: length=100
+      REAL tab_cntrl(length) ! array in which are stored the run's parameters
+      INTEGER  ierr,nvarid
+      INTEGER size
+      CHARACTER modif*20
+      LOGICAL :: found
+      
+      write(*,*)"tabfi: nid=",nid," tab0=",tab0," Lmodif=",Lmodif
+
+      IF (nid.eq.0) then
+c-----------------------------------------------------------------------
+c  Initialization of various physical constants to defaut values (nid = 0 case)
+c-----------------------------------------------------------------------
+      ELSE
+c-----------------------------------------------------------------------
+c  Initialization of physical constants by reading array tab_cntrl(:)
+c		which contains these parameters	(nid != 0 case)
+c-----------------------------------------------------------------------
+c Read 'controle' array
+c
+
+       call get_var("controle",tab_cntrl,found)
+       if (.not.found) then
+         write(*,*)"tabfi: Failed reading <controle> array"
+         call abort
+       else
+         write(*,*)'tabfi: tab_cntrl',tab_cntrl
+       endif
+c
+c  Initialization of some physical constants
+c informations on physics grid
+!      if(ngrid.ne.tab_cntrl(tab0+1)) then
+!         print*,'tabfi: WARNING !!! tab_cntrl(tab0+1).ne.ngrid'
+!         print*,tab_cntrl(tab0+1),ngrid
+!      endif
+      lmax = nint(tab_cntrl(tab0+2))
+      day_ini = tab_cntrl(tab0+3)
+      time = tab_cntrl(tab0+4)
+      write (*,*) 'IN tabfi day_ini=',day_ini
+c Informations about planet for dynamics and physics
+      rad = tab_cntrl(tab0+5)
+      omeg = tab_cntrl(tab0+6)
+      g = tab_cntrl(tab0+7)
+      mugaz = tab_cntrl(tab0+8)
+      rcp = tab_cntrl(tab0+9)
+      cpp=(8.314511/(mugaz/1000.0))/rcp
+      daysec = tab_cntrl(tab0+10)
+      dtphys = tab_cntrl(tab0+11)
+c Informations about planet for the physics only
+      year_day = tab_cntrl(tab0+14)
+      periastr = tab_cntrl(tab0+15)
+      apoastr = tab_cntrl(tab0+16)
+      peri_day = tab_cntrl(tab0+17)
+      obliquit = tab_cntrl(tab0+18)
+c boundary layer and turbeulence
+      z0 = tab_cntrl(tab0+19)
+      lmixmin = tab_cntrl(tab0+20)
+      emin_turb = tab_cntrl(tab0+21)
+c optical properties of polar caps and ground emissivity
+      albedice(1)= tab_cntrl(tab0+22)
+      albedice(2)= tab_cntrl(tab0+23)
+      emisice(1) = tab_cntrl(tab0+24)
+      emisice(2) = tab_cntrl(tab0+25)
+      emissiv    = tab_cntrl(tab0+26)
+      iceradius(1)= tab_cntrl(tab0+31) ! mean scat radius of CO2 snow (north)
+      iceradius(2)= tab_cntrl(tab0+32) ! mean scat radius of CO2 snow (south)
+      dtemisice(1)= tab_cntrl(tab0+33) !time scale for snow metamorphism (north)
+      dtemisice(2)= tab_cntrl(tab0+34) !time scale for snow metamorphism (south)
+c soil properties
+      volcapa = tab_cntrl(tab0+35) ! volumetric heat capacity
+c-----------------------------------------------------------------------
+c	Save some constants for later use (as routine arguments)
+c-----------------------------------------------------------------------
+      p_omeg = omeg
+      p_g = g
+      p_cpp = cpp
+      p_mugaz = mugaz
+      p_daysec = daysec
+      p_rad=rad
+
+      ENDIF    ! end of (nid = 0) 
+
+c-----------------------------------------------------------------------
+c	Write physical constants to output before modifying them
+c-----------------------------------------------------------------------
+ 
+   6  FORMAT(a20,e15.6,e15.6)
+   5  FORMAT(a20,f12.2,f12.2)
+ 
+      write(*,*) '*****************************************************'
+      write(*,*) 'Reading tab_cntrl when calling tabfi before changes'
+      write(*,*) '*****************************************************'
+      write(*,5) '(1)        = ngrid?',tab_cntrl(tab0+1),float(ngrid)
+      write(*,5) '(2)            lmax',tab_cntrl(tab0+2),float(lmax)
+      write(*,5) '(3)         day_ini',tab_cntrl(tab0+3),float(day_ini)
+      write(*,5) '(5)             rad',tab_cntrl(tab0+5),rad
+      write(*,5) '(10)         daysec',tab_cntrl(tab0+10),daysec
+      write(*,6) '(6)            omeg',tab_cntrl(tab0+6),omeg
+      write(*,5) '(7)               g',tab_cntrl(tab0+7),g
+      write(*,5) '(8)           mugaz',tab_cntrl(tab0+8),mugaz
+      write(*,5) '(9)             rcp',tab_cntrl(tab0+9),rcp
+      write(*,6) '(11)        dtphys?',tab_cntrl(tab0+11),dtphys
+
+      write(*,5) '(14)       year_day',tab_cntrl(tab0+14),year_day
+      write(*,5) '(15)       periastr',tab_cntrl(tab0+15),periastr
+      write(*,5) '(16)        apoastr',tab_cntrl(tab0+16),apoastr
+      write(*,5) '(17)       peri_day',tab_cntrl(tab0+17),peri_day
+      write(*,5) '(18)       obliquit',tab_cntrl(tab0+18),obliquit
+
+      write(*,6) '(19)             z0',tab_cntrl(tab0+19),z0
+      write(*,6) '(21)      emin_turb',tab_cntrl(tab0+21),emin_turb
+      write(*,5) '(20)        lmixmin',tab_cntrl(tab0+20),lmixmin
+
+      write(*,5) '(26)        emissiv',tab_cntrl(tab0+26),emissiv
+      write(*,5) '(24)     emisice(1)',tab_cntrl(tab0+24),emisice(1)
+      write(*,5) '(25)     emisice(2)',tab_cntrl(tab0+25),emisice(2)
+      write(*,5) '(22)    albedice(1)',tab_cntrl(tab0+22),albedice(1)
+      write(*,5) '(23)    albedice(2)',tab_cntrl(tab0+23),albedice(2)
+      write(*,6) '(31)   iceradius(1)',tab_cntrl(tab0+31),iceradius(1)
+      write(*,6) '(32)   iceradius(2)',tab_cntrl(tab0+32),iceradius(2)
+      write(*,5) '(33)   dtemisice(1)',tab_cntrl(tab0+33),dtemisice(1)
+      write(*,5) '(34)   dtemisice(2)',tab_cntrl(tab0+34),dtemisice(2)
+
+      write(*,5) '(35)        volcapa',tab_cntrl(tab0+35),volcapa
+
+      write(*,*)
+      write(*,*) 'Lmodif in tabfi!!!!!!!',Lmodif
+
+c-----------------------------------------------------------------------
+c	 Modifications...
+! NB: Modifying controls should only be done by newstart, and in seq mode
+      if ((Lmodif.eq.1).and.is_parallel) then
+        write(*,*) "tabfi: Error modifying tab_control should",
+     &             " only happen in serial mode (eg: by newstart)"
+        stop
+      endif
+c-----------------------------------------------------------------------
+
+      IF(Lmodif.eq.1) then
+
+      write(*,*)
+      write(*,*) 'Change values in tab_cntrl ? :'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      write(*,*) '(Current values given above)'
+      write(*,*)
+      write(*,*) '(3)          day_ini : Initial day (=0 at Ls=0)'
+      write(*,*) '(19)              z0 :  surface roughness (m)'
+      write(*,*) '(21)       emin_turb :  minimal energy (PBL)'
+      write(*,*) '(20)         lmixmin : mixing length (PBL)'
+      write(*,*) '(26)         emissiv : ground emissivity'
+      write(*,*) '(24 et 25)   emisice : CO2 ice max emissivity '
+      write(*,*) '(22 et 23)  albedice : CO2 ice cap albedos'
+      write(*,*) '(31 et 32) iceradius : mean scat radius of CO2 snow'
+      write(*,*) '(33 et 34) dtemisice : time scale for snow',
+     &           'metamorphism'
+      write(*,*) '(35)      volcapa : soil volumetric heat capacity'
+      write(*,*) '(18)     obliquit : planet obliquity (deg)'
+      write(*,*) '(17)     peri_day : periastron date (sols since Ls=0)'
+      write(*,*) '(15)     periastr : min. star-planet dist (UA)'
+      write(*,*) '(16)     apoastr  : max. star-planet (UA)'
+      write(*,*) '(14)     year_day : length of year (in sols)'
+      write(*,*) '(5)      rad      : radius of the planet (m)'
+      write(*,*) '(6)      omeg     : planet rotation rate (rad/s)'
+      write(*,*) '(7)      g        : gravity (m/s2)'
+      write(*,*) '(8)      mugaz    : molecular mass '
+      write(*,*) '                       of the atmosphere (g/mol)'
+      write(*,*) '(9)      rcp      : r/Cp'
+      write(*,*) '(8)+(9)  calc_cpp_mugaz : r/Cp and mugaz '
+      write(*,*) '                 computed from gases.def'
+      write(*,*) '(10)     daysec   : length of a sol (s)'
+      write(*,*)
+ 
+ 
+      do while(modif(1:1).ne.'hello')
+        write(*,*)
+        write(*,*)
+        write(*,*) 'Changes to perform ?'
+        write(*,*) '   (enter keyword or return )'
+        write(*,*)
+        read(*,fmt='(a20)') modif
+        if (modif(1:1) .eq. ' ') goto 999
+ 
+        write(*,*)
+        write(*,*) modif(1:len_trim(modif)) , ' : '
+
+        if (modif(1:len_trim(modif)) .eq. 'day_ini') then
+          write(*,*) 'current value:',day_ini
+          write(*,*) 'enter new value:'
+ 101      read(*,*,iostat=ierr) day_ini
+          if(ierr.ne.0) goto 101
+          write(*,*) ' '
+          write(*,*) 'day_ini (new value):',day_ini
+
+        else if (modif(1:len_trim(modif)) .eq. 'z0') then
+          write(*,*) 'current value:',z0
+          write(*,*) 'enter new value:'
+ 102      read(*,*,iostat=ierr) z0
+          if(ierr.ne.0) goto 102
+          write(*,*) ' '
+          write(*,*) ' z0 (new value):',z0
+
+        else if (modif(1:len_trim(modif)) .eq. 'emin_turb') then
+          write(*,*) 'current value:',emin_turb
+          write(*,*) 'enter new value:'
+ 103      read(*,*,iostat=ierr) emin_turb
+          if(ierr.ne.0) goto 103
+          write(*,*) ' '
+          write(*,*) ' emin_turb (new value):',emin_turb
+
+        else if (modif(1:len_trim(modif)) .eq. 'lmixmin') then
+          write(*,*) 'current value:',lmixmin
+          write(*,*) 'enter new value:'
+ 104      read(*,*,iostat=ierr) lmixmin
+          if(ierr.ne.0) goto 104
+          write(*,*) ' '
+          write(*,*) ' lmixmin (new value):',lmixmin
+
+        else if (modif(1:len_trim(modif)) .eq. 'emissiv') then
+          write(*,*) 'current value:',emissiv
+          write(*,*) 'enter new value:'
+ 105      read(*,*,iostat=ierr) emissiv
+          if(ierr.ne.0) goto 105
+          write(*,*) ' '
+          write(*,*) ' emissiv (new value):',emissiv
+
+        else if (modif(1:len_trim(modif)) .eq. 'emisice') then
+          write(*,*) 'current value emisice(1) North:',emisice(1)
+          write(*,*) 'enter new value:'
+ 106      read(*,*,iostat=ierr) emisice(1)
+          if(ierr.ne.0) goto 106
+          write(*,*) 
+          write(*,*) ' emisice(1) (new value):',emisice(1)
+          write(*,*)
+
+          write(*,*) 'current value emisice(2) South:',emisice(2)
+          write(*,*) 'enter new value:'
+ 107      read(*,*,iostat=ierr) emisice(2)
+          if(ierr.ne.0) goto 107
+          write(*,*) 
+          write(*,*) ' emisice(2) (new value):',emisice(2)
+
+        else if (modif(1:len_trim(modif)) .eq. 'albedice') then
+          write(*,*) 'current value albedice(1) North:',albedice(1)
+          write(*,*) 'enter new value:'
+ 108      read(*,*,iostat=ierr) albedice(1)
+          if(ierr.ne.0) goto 108
+          write(*,*) 
+          write(*,*) ' albedice(1) (new value):',albedice(1)
+          write(*,*)
+
+          write(*,*) 'current value albedice(2) South:',albedice(2)
+          write(*,*) 'enter new value:'
+ 109      read(*,*,iostat=ierr) albedice(2)
+          if(ierr.ne.0) goto 109
+          write(*,*) 
+          write(*,*) ' albedice(2) (new value):',albedice(2)
+
+        else if (modif(1:len_trim(modif)) .eq. 'iceradius') then
+          write(*,*) 'current value iceradius(1) North:',iceradius(1)
+          write(*,*) 'enter new value:'
+ 110      read(*,*,iostat=ierr) iceradius(1)
+          if(ierr.ne.0) goto 110
+          write(*,*) 
+          write(*,*) ' iceradius(1) (new value):',iceradius(1)
+          write(*,*)
+
+          write(*,*) 'current value iceradius(2) South:',iceradius(2)
+          write(*,*) 'enter new value:'
+ 111      read(*,*,iostat=ierr) iceradius(2)
+          if(ierr.ne.0) goto 111
+          write(*,*) 
+          write(*,*) ' iceradius(2) (new value):',iceradius(2)
+
+        else if (modif(1:len_trim(modif)) .eq. 'dtemisice') then
+          write(*,*) 'current value dtemisice(1) North:',dtemisice(1)
+          write(*,*) 'enter new value:'
+ 112      read(*,*,iostat=ierr) dtemisice(1)
+          if(ierr.ne.0) goto 112
+          write(*,*) 
+          write(*,*) ' dtemisice(1) (new value):',dtemisice(1)
+          write(*,*)
+
+          write(*,*) 'current value dtemisice(2) South:',dtemisice(2)
+          write(*,*) 'enter new value:'
+ 113      read(*,*,iostat=ierr) dtemisice(2)
+          if(ierr.ne.0) goto 113
+          write(*,*) 
+          write(*,*) ' dtemisice(2) (new value):',dtemisice(2)
+
+        else if (modif(1:len_trim(modif)) .eq. 'obliquit') then
+          write(*,*) 'current value:',obliquit
+          write(*,*) 'obliquit should be 25.19 on current Mars'
+          write(*,*) 'enter new value:'
+ 115      read(*,*,iostat=ierr) obliquit
+          if(ierr.ne.0) goto 115
+          write(*,*) 
+          write(*,*) ' obliquit (new value):',obliquit
+
+        else if (modif(1:len_trim(modif)) .eq. 'peri_day') then
+          write(*,*) 'current value:',peri_day
+          write(*,*) 'peri_day should be 485 on current Mars'
+          write(*,*) 'enter new value:'
+ 116      read(*,*,iostat=ierr) peri_day
+          if(ierr.ne.0) goto 116
+          write(*,*) 
+          write(*,*) ' peri_day (new value):',peri_day
+
+        else if (modif(1:len_trim(modif)) .eq. 'periastr') then
+          write(*,*) 'current value:',periastr
+          write(*,*) 'periastr should be 206.66 on present-day Mars'
+          write(*,*) 'enter new value:'
+ 117      read(*,*,iostat=ierr) periastr
+          if(ierr.ne.0) goto 117
+          write(*,*) 
+          write(*,*) ' periastr (new value):',periastr
+ 
+        else if (modif(1:len_trim(modif)) .eq. 'apoastr') then
+          write(*,*) 'current value:',apoastr
+          write(*,*) 'apoastr should be 249.22 on present-day Mars'
+          write(*,*) 'enter new value:'
+ 118      read(*,*,iostat=ierr) apoastr
+          if(ierr.ne.0) goto 118
+          write(*,*) 
+          write(*,*) ' apoastr (new value):',apoastr
+ 
+        else if (modif(1:len_trim(modif)) .eq. 'volcapa') then
+          write(*,*) 'current value:',volcapa
+          write(*,*) 'enter new value:'
+ 119      read(*,*,iostat=ierr) volcapa
+          if(ierr.ne.0) goto 119
+          write(*,*) 
+          write(*,*) ' volcapa (new value):',volcapa
+        
+        else if (modif(1:len_trim(modif)).eq.'rad') then
+          write(*,*) 'current value:',rad
+          write(*,*) 'enter new value:'
+ 120      read(*,*,iostat=ierr) rad
+          if(ierr.ne.0) goto 120
+          write(*,*) 
+          write(*,*) ' rad (new value):',rad
+
+        else if (modif(1:len_trim(modif)).eq.'omeg') then
+          write(*,*) 'current value:',omeg
+          write(*,*) 'enter new value:'
+ 121      read(*,*,iostat=ierr) omeg
+          if(ierr.ne.0) goto 121
+          write(*,*) 
+          write(*,*) ' omeg (new value):',omeg
+        
+        else if (modif(1:len_trim(modif)).eq.'g') then
+          write(*,*) 'current value:',g
+          write(*,*) 'enter new value:'
+ 122      read(*,*,iostat=ierr) g
+          if(ierr.ne.0) goto 122
+          write(*,*) 
+          write(*,*) ' g (new value):',g
+
+        else if (modif(1:len_trim(modif)).eq.'mugaz') then
+          write(*,*) 'current value:',mugaz
+          write(*,*) 'enter new value:'
+ 123      read(*,*,iostat=ierr) mugaz
+          if(ierr.ne.0) goto 123
+          write(*,*) 
+          write(*,*) ' mugaz (new value):',mugaz
+          r=8.314511/(mugaz/1000.0)
+          write(*,*) ' R (new value):',r
+
+        else if (modif(1:len_trim(modif)).eq.'rcp') then
+          write(*,*) 'current value:',rcp
+          write(*,*) 'enter new value:'
+ 124      read(*,*,iostat=ierr) rcp
+          if(ierr.ne.0) goto 124
+          write(*,*) 
+          write(*,*) ' rcp (new value):',rcp
+          r=8.314511/(mugaz/1000.0)
+          cpp=r/rcp
+          write(*,*) ' cpp (new value):',cpp
+
+        else if (modif(1:len_trim(modif)).eq.'calc_cpp_mugaz') then
+          write(*,*) 'current value rcp, mugaz:',rcp,mugaz
+          check_cpp_match=.false.
+	  force_cpp=.false.
+	  call su_gases
+	  call calc_cpp_mugaz
+          write(*,*) 
+          write(*,*) ' cpp (new value):',cpp
+          write(*,*) ' mugaz (new value):',mugaz
+          r=8.314511/(mugaz/1000.0)
+          rcp=r/cpp
+          write(*,*) ' rcp (new value):',rcp
+	  
+        else if (modif(1:len_trim(modif)).eq.'daysec') then
+          write(*,*) 'current value:',daysec
+          write(*,*) 'enter new value:'
+ 125      read(*,*,iostat=ierr) daysec
+          if(ierr.ne.0) goto 125
+          write(*,*) 
+          write(*,*) ' daysec (new value):',daysec
+
+!         added by RW!
+        else if (modif(1:len_trim(modif)).eq.'year_day') then
+          write(*,*) 'current value:',year_day
+          write(*,*) 'enter new value:' 
+ 126      read(*,*,iostat=ierr) year_day
+          if(ierr.ne.0) goto 126
+          write(*,*)
+          write(*,*) ' year_day (new value):',year_day
+
+        endif
+      enddo ! of do while(modif(1:1).ne.'hello')
+
+ 999  continue
+
+c-----------------------------------------------------------------------
+c	Write values of physical constants after modifications
+c-----------------------------------------------------------------------
+ 
+      write(*,*) '*****************************************************'
+      write(*,*) 'Reading tab_cntrl when calling tabfi AFTER changes'
+      write(*,*) '*****************************************************'
+      write(*,5) '(1)        = ngrid?',tab_cntrl(tab0+1),float(ngrid)
+      write(*,5) '(2)            lmax',tab_cntrl(tab0+2),float(lmax)
+      write(*,5) '(3)         day_ini',tab_cntrl(tab0+3),float(day_ini)
+      write(*,5) '(5)             rad',tab_cntrl(tab0+5),rad
+      write(*,5) '(10)         daysec',tab_cntrl(tab0+10),daysec
+      write(*,6) '(6)            omeg',tab_cntrl(tab0+6),omeg
+      write(*,5) '(7)               g',tab_cntrl(tab0+7),g
+      write(*,5) '(8)           mugaz',tab_cntrl(tab0+8),mugaz
+      write(*,5) '(9)             rcp',tab_cntrl(tab0+9),rcp
+      write(*,6) '(11)        dtphys?',tab_cntrl(tab0+11),dtphys
+ 
+      write(*,5) '(14)       year_day',tab_cntrl(tab0+14),year_day
+      write(*,5) '(15)       periastr',tab_cntrl(tab0+15),periastr
+      write(*,5) '(16)        apoastr',tab_cntrl(tab0+16),apoastr
+      write(*,5) '(17)       peri_day',tab_cntrl(tab0+17),peri_day
+      write(*,5) '(18)       obliquit',tab_cntrl(tab0+18),obliquit
+ 
+      write(*,6) '(19)             z0',tab_cntrl(tab0+19),z0
+      write(*,6) '(21)      emin_turb',tab_cntrl(tab0+21),emin_turb
+      write(*,5) '(20)        lmixmin',tab_cntrl(tab0+20),lmixmin
+ 
+      write(*,5) '(26)        emissiv',tab_cntrl(tab0+26),emissiv
+      write(*,5) '(24)     emisice(1)',tab_cntrl(tab0+24),emisice(1)
+      write(*,5) '(25)     emisice(2)',tab_cntrl(tab0+25),emisice(2)
+      write(*,5) '(22)    albedice(1)',tab_cntrl(tab0+22),albedice(1)
+      write(*,5) '(23)    albedice(2)',tab_cntrl(tab0+23),albedice(2)
+      write(*,6) '(31)   iceradius(1)',tab_cntrl(tab0+31),iceradius(1)
+      write(*,6) '(32)   iceradius(2)',tab_cntrl(tab0+32),iceradius(2)
+      write(*,5) '(33)   dtemisice(1)',tab_cntrl(tab0+33),dtemisice(1)
+      write(*,5) '(34)   dtemisice(2)',tab_cntrl(tab0+34),dtemisice(2)
+ 
+      write(*,5) '(35)        volcapa',tab_cntrl(tab0+35),volcapa
+
+      write(*,*)  
+      write(*,*) 
+
+      ENDIF 			!	of if (Lmodif == 1)
+
+c-----------------------------------------------------------------------
+c	Save some constants for later use (as routine arguments)
+c-----------------------------------------------------------------------
+      p_omeg = omeg
+      p_g = g
+      p_cpp = cpp
+      p_mugaz = mugaz
+      p_daysec = daysec
+      p_rad=rad
+
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/totalcloudfrac.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/totalcloudfrac.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/totalcloudfrac.F90	(revision 222)
@@ -0,0 +1,113 @@
+      subroutine totalcloudfrac(ngrid,nq,rneb,totalrneb,pplev,pq,tau)
+
+      use watercommon_h
+      use comdiurn_h
+      USE comgeomfi_h
+      USE tracer_h, only: igcm_h2o_ice
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Calculates the total cloud fraction 
+!     
+!     Authors
+!     -------
+!     Adapted from the LMDTERRE code by B Charnay (2010)
+!     
+!==================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+      integer,intent(in) :: ngrid        ! number of atmospheric columns
+      integer,intent(in) :: nq           ! number of tracers
+      real,intent(in) :: rneb(ngrid,nlayermx)    ! cloud fraction     
+      real,intent(out) :: totalrneb(ngrid)       ! total cloud fraction 
+      real,intent(in) :: pplev(ngrid,nlayermx+1) ! inter-layer pressure (Pa)
+      real,intent(in) :: pq(ngrid,nlayermx,nq)   ! tracers (.../kg_of_air)
+      real,intent(in) :: tau(ngrid,nlayermx)
+
+      real, dimension(nlayermx+1) :: masse
+      integer, parameter          :: recovery=7
+      integer ltau_max
+      real massetot
+
+! hypothesis behind recovery. value: 
+! 1 = random recovery
+! 2 = maximal recovery
+! 3 = minimal recovery
+! 4 = fixed recovery
+! 5 = recovery on the thicker layer
+!     Local variables
+      integer ig, l
+      real clear,tau_min
+      real, parameter ::  tau_c=0.1 !threshold of optical depth for the calculation of total cloud fraction 
+      real rneb2(nlayermx)
+
+
+      do ig=1,ngrid
+         totalrneb(ig) = 0.
+
+         if (recovery.eq.1) then
+            clear = (1.-rneb(ig,1))
+            do l=2,nlayermx       
+               clear = clear*(1.-rneb(ig,l))
+            enddo
+            totalrneb(ig) = 1.-clear
+
+         elseif (recovery.eq.2) then
+            totalrneb(ig) = rneb(ig,1)
+            do l=2,14 !nlayermx       
+               totalrneb(ig) = max(rneb(ig,l),totalrneb(ig))
+            enddo
+            
+         elseif (recovery.eq.3) then
+            totalrneb(ig) = rneb(ig,1)
+            do l=2,nlayermx       
+               totalrneb(ig) = min(rneb(ig,l),totalrneb(ig))
+            enddo
+         
+         elseif (recovery.eq.4) then
+            totalrneb(ig) = CLFfixval
+
+         elseif (recovery.eq.5) then
+            totalrneb(ig) = rneb(ig,1)            
+            do l=1,nlayermx
+               masse(l)=pq(ig,l,igcm_h2o_ice)*(pplev(ig,l)-pplev(ig,l+1))
+            enddo
+            ltau_max=maxloc(masse,dim=1)
+            totalrneb(ig) = rneb(ig,ltau_max)
+
+         elseif (recovery.eq.6) then
+            totalrneb(ig) = 0.            
+            do l=1,nlayermx
+               masse(l)=pq(ig,l,igcm_h2o_ice)*(pplev(ig,l)-pplev(ig,l+1))
+               masse(l)=max(masse(l),0.)
+            enddo
+            massetot=sum(masse,dim=1)
+            do l=1,nlayermx
+               totalrneb(ig) = totalrneb(ig)+rneb(ig,l)*masse(l)/massetot
+            enddo
+
+         elseif (recovery.eq.7) then
+
+            rneb2(:)=rneb(ig,1:nlayermx)
+	    tau_min=MIN(tau_c,MAXVAL(tau(ig,1:nlayermx))/2.)
+            do l=1,nlayermx
+               if(tau(ig,l)<tau_min) rneb2(l)=0.      	
+            enddo
+            totalrneb(ig)=maxval(rneb2(1:nlayermx))
+
+         endif                  ! (recovery=)   
+
+         totalrneb(ig) = min(1.,totalrneb(ig))
+         totalrneb(ig) = max(0.,totalrneb(ig))
+         
+      enddo                     ! (ig=)
+      
+      
+    end subroutine totalcloudfrac
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tpindex.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tpindex.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tpindex.F	(revision 222)
@@ -0,0 +1,137 @@
+      subroutine tpindex(pw,tw,qvar,pref,tref,wrefvar,LCOEF,MT,MP,
+     &     NVAR,wratio)
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Interpolate K-coefficients to the given P,T and Qvar values.
+!
+!     Notes
+!     -----
+!     The interpolation is the usual one in two dimensions given
+!     in "Numerical Recipes", where the "X" are P, the "Y" are
+!     T, and the F(X,Y) are the CO2 K-coefficients.
+!
+!     The interpolating box is:
+!
+!           (PL,TU)                        (PR,TU)
+!
+!                          (TW,PW)
+!
+!           
+!           (PL,TL)                        (PR,TL)
+!
+!      PL  - Pressure left
+!      PR  - Pressure right
+!      TL  - Temperature lower
+!      TU  - Temperature upper
+!      PW  - Pressure wanted
+!      TW  - Temperature wanted
+!
+!     Inputs
+!     ------
+!     PW                 - The pressure to interpolate to
+!     TW                 - The temperature to interpolate to
+!     Pref(NP)           - The pressure grid array
+!     Tref(NT)           - The temperature grid array
+!   
+!     Outputs
+!     -------
+!     TI                 - Interpolation term (pressure)
+!     UI                 - Interpolation term (temperature)
+!     MT                 - Temperature index (bottom left temperature)
+!                          of bounding box
+!     MP                 - Pressure index (bottom left pressure)
+!                          of bounding box
+!
+!     Authors
+!     -------
+!     Adapted from the NASA Ames code by R. Wordsworth (2009)
+!     
+!==================================================================
+
+      use radinc_h
+
+      implicit none
+
+      real*8 Tref(L_NTREF)
+      real*8 pref(L_PINT)
+      real*8 wrefvar(L_REFVAR)
+
+      integer MT, MP, N, M, NP, NVAR
+      real*8  PW, TW, Qvar, wratio
+      real*8  PWL, LCOEF(4), T, U
+
+C======================================================================C
+ 
+!     Get the upper and lower temperature grid indicies that bound the
+!     requested temperature. If the requested temperature is outside
+!     the T-grid, set up to extrapolate from the appropriate end.
+
+
+      IF(TW.LE.TREF(1)) THEN
+        MT = 1
+      ELSE
+        do n=1,L_NTREF-1
+          if(tw.gt.Tref(n) .and. TW.LE.TREF(N+1)) then
+            MT = n
+            goto 10
+          end if
+        end do
+
+        MT = L_NTREF-1
+      
+   10   continue
+      END IF
+
+      U = (TW-TREF(MT))/(TREF(MT+1)-TREF(MT))
+
+!     Get the upper and lower pressure grid indicies that bound the
+!     requested pressure. If the requested pressure is outside
+!     the P-grid, set up to extrapolate from the appropriate end.
+
+      pwl = log10(pw)
+
+      do n=2,L_PINT-1
+        if(pwl.le.Pref(n)) then
+          MP = n-1
+          goto 20
+        end if
+      end do
+
+      MP = L_PINT-1
+
+   20 continue
+
+      T = (PWL-PREF(MP))/(PREF(MP+1)-PREF(MP))
+
+!  Fill in the interpolation coefficients
+      LCOEF(1) = (1.0-T)*(1.0-U)
+      LCOEF(2) = T*(1.0-U)
+      LCOEF(3) = T*U
+      LCOEF(4) = (1.0-T)*U
+
+!  Get the indicies for abundance of the varying species. There are 10 sets of 
+!  k-coefficients with differing amounts of variable vs. constant gas.
+
+      IF(QVAR.le.WREFVAR(1)) then
+        NVAR   = 1
+        WRATIO = 0.0D0
+      ELSEIF(QVAR.ge.WREFVAR(L_REFVAR)) then
+        NVAR   = L_REFVAR
+        WRATIO = 0.0D0
+      ELSE
+        DO N=2,L_REFVAR
+          IF(QVAR.GE.WREFVAR(N-1) .and. QVAR.lt.WREFVAR(N)) then
+            NVAR   = N-1
+            WRATIO = (QVAR - WREFVAR(N-1))/(WREFVAR(N) - WREFVAR(N-1))
+            GOTO 30
+          END IF
+        END DO
+      END IF
+
+   30 CONTINUE
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tracer_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tracer_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/tracer_h.F90	(revision 222)
@@ -0,0 +1,51 @@
+
+       module tracer_h
+
+       implicit none
+
+       character*20, DIMENSION(:), ALLOCATABLE :: noms   ! name of the tracer
+       real, DIMENSION(:), ALLOCATABLE :: mmol     ! mole mass of tracer (g/mol-1) 
+       real, DIMENSION(:), ALLOCATABLE :: radius   ! dust and ice particle radius (m)
+       real, DIMENSION(:), ALLOCATABLE :: rho_q    ! tracer densities (kg.m-3)
+       real, DIMENSION(:), ALLOCATABLE :: qext     ! Single Scat. Extinction coeff at 0.67 um
+       real, DIMENSION(:), ALLOCATABLE :: alpha_lift  ! saltation vertical flux/horiz flux ratio (m-1)
+       real, DIMENSION(:), ALLOCATABLE :: alpha_devil ! lifting coeeficient by dust devil
+       real, DIMENSION(:), ALLOCATABLE :: qextrhor ! Intermediate for computing opt. depth from q
+
+      real varian      ! Characteristic variance of log-normal distribution
+      real r3n_q     ! used to compute r0 from number and mass mixing ratio
+      real rho_dust     ! Mars dust density (kg.m-3)
+      real rho_ice     ! Water ice density (kg.m-3)
+      real rho_co2     ! CO2 ice density (kg.m-3)
+      real ref_r0        ! for computing reff=ref_r0*r0 (in log.n. distribution)
+
+! tracer indexes: these are initialized in initracer and should be 0 if the
+!                 corresponding tracer does not exist
+      ! dust
+      integer, DIMENSION(:), ALLOCATABLE :: igcm_dustbin ! for dustbin 'dust' tracers
+      ! dust, special doubleq case
+      integer :: igcm_dust_mass   ! dust mass mixing ratio (for transported dust)
+      integer :: igcm_dust_number ! dust number mixing ratio (transported dust)
+      ! water
+      integer :: igcm_h2o_vap ! water vapour
+      integer :: igcm_h2o_ice ! water ice
+      ! chemistry:
+      integer :: igcm_co2
+      integer :: igcm_co
+      integer :: igcm_o
+      integer :: igcm_o1d
+      integer :: igcm_o2
+      integer :: igcm_o3
+      integer :: igcm_h
+      integer :: igcm_h2
+      integer :: igcm_oh
+      integer :: igcm_ho2
+      integer :: igcm_h2o2
+      integer :: igcm_n2
+      integer :: igcm_ar
+      ! other tracers
+      integer :: igcm_ar_n2 ! for simulations using co2 +neutral gaz
+      integer :: igcm_co2_ice ! CO2 ice 
+
+       end module tracer_h
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/turbdiff.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/turbdiff.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/turbdiff.F90	(revision 222)
@@ -0,0 +1,739 @@
+      subroutine turbdiff(ngrid,nlay,nq,rnat,          &
+          ptimestep,pcapcal,lecrit,                    &   
+          pplay,pplev,pzlay,pzlev,pz0,                 &
+          pu,pv,pt,ppopsk,pq,ptsrf,pemis,pqsurf,       &
+          pdufi,pdvfi,pdtfi,pdqfi,pfluxsrf,            &
+          Pdudif,pdvdif,pdtdif,pdtsrf,sensibFlux,pq2,  &
+          pdqdif,pdqevap,pdqsdif,flux_u,flux_v,lastcall)
+
+      use watercommon_h, only : RLVTT, T_h2O_ice_liq, RCPD, mx_eau_sol,Psat_water
+      use radcommon_h, only : sigma, glat
+      use surfdat_h, only: dryness
+      use tracer_h, only: igcm_h2o_vap, igcm_h2o_ice
+
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Turbulent diffusion (mixing) for pot. T, U, V and tracers
+!     
+!     Implicit scheme
+!     We start by adding to variables x the physical tendencies
+!     already computed. We resolve the equation:
+!
+!     x(t+1) =  x(t) + dt * (dx/dt)phys(t)  +  dt * (dx/dt)difv(t+1)
+!     
+!     Authors
+!     ------- 
+!     F. Hourdin, F. Forget, R. Fournier (199X)
+!     R. Wordsworth, B. Charnay (2010)
+!     J. Leconte (2012): To f90
+!         - Rewritten the diffusion scheme to conserve total enthalpy
+!               by accounting for dissipation of turbulent kinetic energy.
+!         - Accounting for lost mean flow kinetic energy should come soon.
+!     
+!==================================================================
+
+!-----------------------------------------------------------------------
+!     declarations
+!     ------------
+
+      include "dimensions.h"
+      include "dimphys.h"
+      include "comcstfi.h"
+      include "callkeys.h"
+
+!     arguments
+!     ---------
+      INTEGER,INTENT(IN) :: ngrid,nlay
+      REAL,INTENT(IN) :: ptimestep
+      REAL,INTENT(IN) :: pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      REAL,INTENT(IN) :: pzlay(ngrid,nlay),pzlev(ngrid,nlay+1)
+      REAL,INTENT(IN) :: pu(ngrid,nlay),pv(ngrid,nlay)
+      REAL,INTENT(IN) :: pt(ngrid,nlay),ppopsk(ngrid,nlay)
+      REAL,INTENT(IN) :: ptsrf(ngrid) ! surface temperature (K)
+      REAL,INTENT(IN) :: pemis(ngrid)
+      REAL,INTENT(IN) :: pdufi(ngrid,nlay),pdvfi(ngrid,nlay)
+      REAL,INTENT(IN) :: pdtfi(ngrid,nlay)
+      REAL,INTENT(IN) :: pfluxsrf(ngrid)
+      REAL,INTENT(OUT) :: pdudif(ngrid,nlay),pdvdif(ngrid,nlay)
+      REAL,INTENT(OUT) :: pdtdif(ngrid,nlay)
+      REAL,INTENT(OUT) :: pdtsrf(ngrid) ! tendency (K/s) on surface temperature
+      REAL,INTENT(OUT) :: sensibFlux(ngrid)
+      REAL,INTENT(IN) :: pcapcal(ngrid)
+      REAL,INTENT(INOUT) :: pq2(ngrid,nlay+1)
+      REAL,INTENT(OUT) :: flux_u(ngrid),flux_v(ngrid)
+      REAL,INTENT(IN) :: rnat(ngrid)      
+      LOGICAL,INTENT(IN) :: lastcall ! not used
+
+!     Arguments added for condensation
+      logical,intent(in) :: lecrit ! not used.
+      REAL,INTENT(IN) :: pz0
+
+!     Tracers
+!     --------
+      integer,intent(in) :: nq 
+      real,intent(in) :: pqsurf(ngrid,nq)
+      real,intent(in) :: pq(ngrid,nlay,nq), pdqfi(ngrid,nlay,nq) 
+      real,intent(out) :: pdqdif(ngrid,nlay,nq) 
+      real,intent(out) :: pdqsdif(ngrid,nq) 
+      
+!     local
+!     -----
+      integer ilev,ig,ilay,nlev
+
+      REAL z4st,zdplanck(ngrid)
+      REAL zkv(ngrid,nlayermx+1),zkh(ngrid,nlayermx+1)
+      REAL zcdv(ngrid),zcdh(ngrid)
+      REAL zcdv_true(ngrid),zcdh_true(ngrid)
+      REAL zu(ngrid,nlayermx),zv(ngrid,nlayermx)
+      REAL zh(ngrid,nlayermx),zt(ngrid,nlayermx)
+      REAL ztsrf(ngrid)
+      REAL z1(ngrid),z2(ngrid)
+      REAL zmass(ngrid,nlayermx)
+      REAL zfluxv(ngrid,nlayermx),zfluxt(ngrid,nlayermx),zfluxq(ngrid,nlayermx)
+      REAL zb0(ngrid,nlayermx)
+      REAL zExner(ngrid,nlayermx),zovExner(ngrid,nlayermx)
+      REAL zcv(ngrid,nlayermx),zdv(ngrid,nlayermx)  !inversion coefficient for winds
+      REAL zct(ngrid,nlayermx),zdt(ngrid,nlayermx)  !inversion coefficient for temperature
+      REAL zcq(ngrid,nlayermx),zdq(ngrid,nlayermx)  !inversion coefficient for tracers
+      REAL zcst1
+      REAL zu2!, a
+      REAL zcq0(ngrid),zdq0(ngrid)
+      REAL zx_alf1(ngrid),zx_alf2(ngrid)
+
+      LOGICAL,SAVE :: firstcall=.true.
+      
+!     Tracers
+!     -------
+      INTEGER iq
+      REAL zq(ngrid,nlayermx,nq)
+      REAL zqnoevap(ngrid,nlayermx) !special for water case to compute where evaporated water goes.
+      REAL pdqevap(ngrid,nlayermx) !special for water case to compute where evaporated water goes.
+      REAL zdmassevap(ngrid)
+      REAL rho(ngrid)         ! near-surface air density
+      REAL qsat(ngrid),psat(ngrid)
+      REAL kmixmin
+
+!     Variables added for implicit latent heat inclusion
+!     --------------------------------------------------
+      real dqsat(ngrid), qsat_temp1, qsat_temp2,psat_temp
+
+      integer, save :: ivap, iliq, iliq_surf,iice_surf ! also make liq for clarity on surface...
+
+      real, parameter :: karman=0.4
+      real cd0, roughratio
+
+      real dqsdif_total(ngrid) 
+      real zq0(ngrid) 
+
+
+!     Coherence test
+!     --------------
+
+      IF (firstcall) THEN
+
+         if(water)then
+             ivap=igcm_h2o_vap
+             iliq=igcm_h2o_ice
+             iliq_surf=igcm_h2o_vap
+	     iice_surf=igcm_h2o_ice ! simply to make the code legible               
+                                  ! to be generalised
+	 else
+             ivap=0
+             iliq=0
+             iliq_surf=0
+	     iice_surf=0 ! simply to make the code legible               	  
+         endif
+         sensibFlux(:)=0.
+
+         firstcall=.false.
+      ENDIF
+
+!-----------------------------------------------------------------------
+!     1. Initialisation
+!     -----------------
+
+      nlev=nlay+1
+
+!     Calculate rho*dz, (P/Ps)**(R/cp) and dt*rho/dz=dt*rho**2 g/dp
+!     with rho=p/RT=p/ (R Theta) (p/ps)**kappa
+!     ---------------------------------------------
+
+      DO ilay=1,nlay
+         DO ig=1,ngrid
+            zmass(ig,ilay)=(pplev(ig,ilay)-pplev(ig,ilay+1))/glat(ig)
+	    zExner(ig,ilay)=(pplev(ig,ilay)/pplev(ig,1))**rcp
+	    zovExner(ig,ilay)=1./ppopsk(ig,ilay)
+         ENDDO
+      ENDDO
+
+      zcst1=4.*g*ptimestep/(R*R)
+      DO ilev=2,nlev-1
+         DO ig=1,ngrid
+            zb0(ig,ilev)=pplev(ig,ilev)/(pt(ig,ilev-1)+pt(ig,ilev))
+            zb0(ig,ilev)=zcst1*zb0(ig,ilev)*zb0(ig,ilev)/(pplay(ig,ilev-1)-pplay(ig,ilev))
+         ENDDO
+      ENDDO
+      DO ig=1,ngrid
+         zb0(ig,1)=ptimestep*pplev(ig,1)/(R*ptsrf(ig))
+      ENDDO
+      dqsdif_total(:)=0.0
+
+!-----------------------------------------------------------------------
+!     2. Add the physical tendencies computed so far
+!     ----------------------------------------------
+
+      DO ilev=1,nlay
+         DO ig=1,ngrid
+            zu(ig,ilev)=pu(ig,ilev)+pdufi(ig,ilev)*ptimestep
+            zv(ig,ilev)=pv(ig,ilev)+pdvfi(ig,ilev)*ptimestep
+            zt(ig,ilev)=pt(ig,ilev)+pdtfi(ig,ilev)*ptimestep
+            zh(ig,ilev)=pt(ig,ilev)*zovExner(ig,ilev) !for call vdif_kc, but could be moved and computed there
+        ENDDO
+      ENDDO
+      if(tracer) then
+         DO iq =1, nq
+            DO ilev=1,nlay
+               DO ig=1,ngrid
+                  zq(ig,ilev,iq)=pq(ig,ilev,iq) + pdqfi(ig,ilev,iq)*ptimestep
+               ENDDO
+            ENDDO
+         ENDDO
+         if (water) then
+            DO ilev=1,nlay
+               DO ig=1,ngrid
+                  zqnoevap(ig,ilev)=pq(ig,ilev,ivap) + pdqfi(ig,ilev,ivap)*ptimestep
+               ENDDO
+            ENDDO
+         Endif
+      end if
+
+!-----------------------------------------------------------------------
+!     3. Turbulence scheme
+!     --------------------
+!
+!     Source of turbulent kinetic energy at the surface
+!     ------------------------------------------------- 
+!     Formula is Cd_0 = (karman / log[1+z1/z0])^2
+
+      DO ig=1,ngrid
+         roughratio = 1. + pzlay(ig,1)/pz0
+         cd0 = karman/log(roughratio)
+         cd0 = cd0*cd0
+         zcdv_true(ig) = cd0
+         zcdh_true(ig) = cd0
+       if(nosurf)then
+         zcdv_true(ig)=0.D+0 !JL12 disable atm/surface momentum flux
+         zcdh_true(ig)=0.D+0 !JL12 disable sensible heat flux 
+       endif
+      ENDDO
+
+      DO ig=1,ngrid
+         zu2=pu(ig,1)*pu(ig,1)+pv(ig,1)*pv(ig,1)
+         zcdv(ig)=zcdv_true(ig)*sqrt(zu2)
+         zcdh(ig)=zcdh_true(ig)*sqrt(zu2)
+      ENDDO
+
+!     Turbulent diffusion coefficients in the boundary layer
+!     ------------------------------------------------------ 
+
+      call vdif_kc(ngrid,ptimestep,g,pzlev,pzlay,pu,pv,zh,zcdv_true,pq2,zkv,zkh) !JL12 why not call vdif_kc with updated winds and temperature 
+      
+!     Adding eddy mixing to mimic 3D general circulation in 1D
+!     R. Wordsworth & F. Forget (2010)
+      if ((ngrid.eq.1)) then
+         kmixmin = 1.0e-2       ! minimum eddy mix coeff in 1D
+         do ilev=1,nlay
+            do ig=1,ngrid
+               zkh(ig,ilev) = max(kmixmin,zkh(ig,ilev))
+               zkv(ig,ilev) = max(kmixmin,zkv(ig,ilev)) 
+            end do
+         end do
+      end if
+
+!JL12 change zkv at the surface by zcdv to calculate the surface momentum flux properly
+      DO ig=1,ngrid
+         zkv(ig,1)=zcdv(ig)
+      ENDDO
+!we treat only winds, energy and tracers coefficients will be computed with upadted winds
+ 
+!JL12 calculate the flux coefficients (tables multiplied elements by elements)
+      zfluxv(1:ngrid,1:nlayermx)=zkv(1:ngrid,1:nlayermx)*zb0(1:ngrid,1:nlayermx)
+      
+!-----------------------------------------------------------------------
+!     4. Implicit inversion of u
+!     --------------------------
+
+!     u(t+1) =  u(t) + dt * {(du/dt)phys}(t)  +  dt * {(du/dt)difv}(t+1)
+!     avec
+!     /zu/ = u(t) + dt * {(du/dt)phys}(t)   (voir paragraphe 2.)
+!     et
+!     dt * {(du/dt)difv}(t+1) = dt * {(d/dz)[ Ku (du/dz) ]}(t+1)
+!     donc les entrees sont /zcdv/ pour la condition a la limite sol
+!     et /zkv/ = Ku
+
+      DO ig=1,ngrid
+         z1(ig)=1./(zmass(ig,nlay)+zfluxv(ig,nlay))
+         zcv(ig,nlay)=zmass(ig,nlay)*zu(ig,nlay)*z1(ig)
+         zdv(ig,nlay)=zfluxv(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(zmass(ig,ilay)+zfluxv(ig,ilay) + zfluxv(ig,ilay+1)*(1.-zdv(ig,ilay+1)))
+            zcv(ig,ilay)=(zmass(ig,ilay)*zu(ig,ilay)+zfluxv(ig,ilay+1)*zcv(ig,ilay+1))*z1(ig)
+            zdv(ig,ilay)=zfluxv(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         zu(ig,1)=zcv(ig,1)
+      ENDDO
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            zu(ig,ilay)=zcv(ig,ilay)+zdv(ig,ilay)*zu(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+!-----------------------------------------------------------------------
+!     5. Implicit inversion of v
+!     --------------------------
+
+!     v(t+1) =  v(t) + dt * {(dv/dt)phys}(t)  +  dt * {(dv/dt)difv}(t+1)
+!     avec
+!     /zv/ = v(t) + dt * {(dv/dt)phys}(t)   (voir paragraphe 2.)
+!     et
+!     dt * {(dv/dt)difv}(t+1) = dt * {(d/dz)[ Kv (dv/dz) ]}(t+1)
+!     donc les entrees sont /zcdv/ pour la condition a la limite sol
+!     et /zkv/ = Kv
+
+      DO ig=1,ngrid
+         z1(ig)=1./(zmass(ig,nlay)+zfluxv(ig,nlay)) 
+         zcv(ig,nlay)=zmass(ig,nlay)*zv(ig,nlay)*z1(ig)
+         zdv(ig,nlay)=zfluxv(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(zmass(ig,ilay)+zfluxv(ig,ilay)+zfluxv(ig,ilay+1)*(1.-zdv(ig,ilay+1)))
+            zcv(ig,ilay)=(zmass(ig,ilay)*zv(ig,ilay)+zfluxv(ig,ilay+1)*zcv(ig,ilay+1))*z1(ig)
+            zdv(ig,ilay)=zfluxv(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         zv(ig,1)=zcv(ig,1)
+      ENDDO
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            zv(ig,ilay)=zcv(ig,ilay)+zdv(ig,ilay)*zv(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+!     Calcul of wind stress
+
+      DO ig=1,ngrid
+         flux_u(ig) = zfluxv(ig,1)/ptimestep*zu(ig,1)
+         flux_v(ig) = zfluxv(ig,1)/ptimestep*zv(ig,1)
+      ENDDO
+
+
+!----------------------------------------------------------------------------
+!     6. Implicit inversion of h, not forgetting the coupling with the ground
+
+!     h(t+1) =  h(t) + dt * {(dh/dt)phys}(t)  +  dt * {(dh/dt)difv}(t+1)
+!     avec
+!     /zh/ = h(t) + dt * {(dh/dt)phys}(t)   (voir paragraphe 2.)
+!     et
+!     dt * {(dh/dt)difv}(t+1) = dt * {(d/dz)[ Kh (dh/dz) ]}(t+1)
+!     donc les entrees sont /zcdh/ pour la condition de raccord au sol
+!     et /zkh/ = Kh
+
+!     Using the wind modified by friction for lifting and sublimation
+!     ---------------------------------------------------------------
+      DO ig=1,ngrid
+         zu2      = zu(ig,1)*zu(ig,1)+zv(ig,1)*zv(ig,1)
+         zcdv(ig) = zcdv_true(ig)*sqrt(zu2)
+         zcdh(ig) = zcdh_true(ig)*sqrt(zu2)
+         zkh(ig,1)= zcdh(ig)
+      ENDDO
+
+!     JL12 calculate the flux coefficients (tables multiplied elements by elements)
+!     ---------------------------------------------------------------
+      zfluxq(1:ngrid,1:nlayermx)=zkh(1:ngrid,1:nlayermx)*zb0(1:ngrid,1:nlayermx) !JL12 we save zfluxq which doesn't need the Exner factor
+      zfluxt(1:ngrid,1:nlayermx)=zfluxq(1:ngrid,1:nlayermx)*zExner(1:ngrid,1:nlayermx)
+
+      DO ig=1,ngrid
+         z1(ig)=1./(zmass(ig,nlay)+zfluxt(ig,nlay)*zovExner(ig,nlay))
+         zct(ig,nlay)=zmass(ig,nlay)*zt(ig,nlay)*z1(ig)
+         zdt(ig,nlay)=zfluxt(ig,nlay)*zovExner(ig,nlay-1)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,2,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(zmass(ig,ilay)+zfluxt(ig,ilay)*zovExner(ig,ilay)+   &
+            zfluxt(ig,ilay+1)*(zovExner(ig,ilay)-zdt(ig,ilay+1)*zovExner(ig,ilay+1)))
+            zct(ig,ilay)=(zmass(ig,ilay)*zt(ig,ilay)+zfluxt(ig,ilay+1)*zct(ig,ilay+1)*zovExner(ig,ilay+1))*z1(ig)
+            zdt(ig,ilay)=zfluxt(ig,ilay)*z1(ig)*zovExner(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+!JL12 we treat last point afterward because zovExner(ig,ilay-1) does not exist there
+      DO ig=1,ngrid
+         z1(ig)=1./(zmass(ig,1)+zfluxt(ig,1)*zovExner(ig,1)+  &
+             zfluxt(ig,2)*(zovExner(ig,1)-zdt(ig,2)*zovExner(ig,2)))
+         zct(ig,1)=(zmass(ig,1)*zt(ig,1)+zfluxt(ig,2)*zct(ig,2)*zovExner(ig,2))*z1(ig)
+         zdt(ig,1)=zfluxt(ig,1)*z1(ig)
+      ENDDO
+
+
+!     Calculate (d Planck / dT) at the interface temperature
+!     ------------------------------------------------------
+
+      z4st=4.0*sigma*ptimestep
+      DO ig=1,ngrid
+         zdplanck(ig)=z4st*pemis(ig)*ptsrf(ig)*ptsrf(ig)*ptsrf(ig)
+      ENDDO
+
+!     Calculate temperature tendency at the interface (dry case)
+!     ----------------------------------------------------------
+!     Sum of fluxes at interface at time t + \delta t gives change in T:
+!       radiative fluxes
+!       turbulent convective (sensible) heat flux
+!       flux (if any) from subsurface
+
+      if(.not.water) then
+
+         DO ig=1,ngrid
+            z1(ig)=pcapcal(ig)*ptsrf(ig)+cpp*zfluxt(ig,1)*zct(ig,1)*zovExner(ig,1) &
+                + pfluxsrf(ig)*ptimestep + zdplanck(ig)*ptsrf(ig) 
+            z2(ig) = pcapcal(ig)+zdplanck(ig)+cpp*zfluxt(ig,1)*(1.-zovExner(ig,1)*zdt(ig,1)) 
+            ztsrf(ig) = z1(ig) / z2(ig)
+            pdtsrf(ig) = (ztsrf(ig) - ptsrf(ig))/ptimestep
+            zt(ig,1)   = zct(ig,1) + zdt(ig,1)*ztsrf(ig)
+         ENDDO
+! JL12 note that the black body radiative flux emitted by the surface has been updated by the implicit scheme 
+
+
+!     Recalculate temperature to top of atmosphere, starting from ground
+!     ------------------------------------------------------------------
+
+         DO ilay=2,nlay
+            DO ig=1,ngrid
+               zt(ig,ilay)=zct(ig,ilay)+zdt(ig,ilay)*zt(ig,ilay-1)
+            ENDDO
+         ENDDO
+
+      endif                     ! not water
+
+!-----------------------------------------------------------------------
+!     TRACERS (no vapour)
+!     -------
+
+      if(tracer) then
+
+!     Calculate vertical flux from the bottom to the first layer (dust)
+!     -----------------------------------------------------------------
+         do ig=1,ngrid
+            rho(ig) = zb0(ig,1) /ptimestep
+         end do
+
+         pdqsdif(:,:)=0.
+
+!     Implicit inversion of q
+!     -----------------------
+         do iq=1,nq 
+
+            if (iq.ne.ivap) then
+
+               DO ig=1,ngrid
+                  z1(ig)=1./(zmass(ig,nlay)+zfluxq(ig,nlay))
+                  zcq(ig,nlay)=zmass(ig,nlay)*zq(ig,nlay,iq)*z1(ig)
+                  zdq(ig,nlay)=zfluxq(ig,nlay)*z1(ig)
+               ENDDO 
+            
+               DO ilay=nlay-1,2,-1
+                  DO ig=1,ngrid
+                     z1(ig)=1./(zmass(ig,ilay)+zfluxq(ig,ilay)+zfluxq(ig,ilay+1)*(1.-zdq(ig,ilay+1)))
+                     zcq(ig,ilay)=(zmass(ig,ilay)*zq(ig,ilay,iq)+zfluxq(ig,ilay+1)*zcq(ig,ilay+1))*z1(ig)
+                     zdq(ig,ilay)=zfluxq(ig,ilay)*z1(ig)
+                  ENDDO
+               ENDDO
+
+               if ((water).and.(iq.eq.iliq)) then
+                  ! special case for condensed water tracer: do not include
+                  ! h2o ice tracer from surface (which is set when handling
+                  ! h2o vapour case (see further down).
+                  ! zb(ig,1)=0 if iq ne ivap
+                  DO ig=1,ngrid
+                     z1(ig)=1./(zmass(ig,1)+zfluxq(ig,2)*(1.-zdq(ig,2)))
+                     zcq(ig,1)=(zmass(ig,1)*zq(ig,1,iq)+zfluxq(ig,2)*zcq(ig,2))*z1(ig)
+                  ENDDO
+               else             ! general case
+                  do ig=1,ngrid
+                     z1(ig)=1./(zmass(ig,1)+zfluxq(ig,2)*(1.-zdq(ig,2)))
+                     zcq(ig,1)=(zmass(ig,1)*zq(ig,1,iq)+zfluxq(ig,2)*zcq(ig,2)+(-pdqsdif(ig,iq))*ptimestep)*z1(ig)
+                          ! tracer flux from surface
+                          ! currently pdqsdif always zero here,
+                          ! so last line is superfluous
+                  enddo
+               endif            ! of if (water.and.(iq.eq.igcm_h2o_ice))
+
+
+!     Starting upward calculations for simple tracer mixing (e.g., dust)
+               do ig=1,ngrid
+                  zq(ig,1,iq)=zcq(ig,1)
+               end do
+
+               do ilay=2,nlay
+                  do ig=1,ngrid
+                     zq(ig,ilay,iq)=zcq(ig,ilay)+zdq(ig,ilay)*zq(ig,ilay-1,iq)
+                  end do
+               end do
+
+            endif               ! if (iq.ne.ivap)
+
+!     Calculate temperature tendency including latent heat term
+!     and assuming an infinite source of water on the ground
+!     ------------------------------------------------------------------
+
+            if (water.and.(iq.eq.ivap)) then 
+            
+               ! compute evaporation efficiency
+               do ig=1,ngrid
+                  if(nint(rnat(ig)).eq.1)then
+                     dryness(ig)=pqsurf(ig,iliq_surf)+pqsurf(ig,iice_surf) 
+                     dryness(ig)=MIN(1.,2*dryness(ig)/mx_eau_sol)
+                     dryness(ig)=MAX(0.,dryness(ig))
+                  endif
+               enddo
+
+               do ig=1,ngrid
+                ! Calculate the value of qsat at the surface (water)
+                call Psat_water(ptsrf(ig),pplev(ig,1),psat(ig),qsat(ig))
+                call Psat_water(ptsrf(ig)-0.0001,pplev(ig,1),psat_temp,qsat_temp1)
+                call Psat_water(ptsrf(ig)+0.0001,pplev(ig,1),psat_temp,qsat_temp2)
+                dqsat(ig)=(qsat_temp2-qsat_temp1)/0.0002
+                ! calculate dQsat / dT by finite differences
+                ! we cannot use the updated temperature value yet...
+	       enddo
+
+! coefficients for q
+
+               do ig=1,ngrid
+                  z1(ig)=1./(zmass(ig,nlay)+zfluxq(ig,nlay))
+                  zcq(ig,nlay)=zmass(ig,nlay)*zq(ig,nlay,iq)*z1(ig)
+                  zdq(ig,nlay)=zfluxq(ig,nlay)*z1(ig)
+               enddo 
+          
+               do ilay=nlay-1,2,-1
+                  do ig=1,ngrid
+                     z1(ig)=1./(zmass(ig,ilay)+zfluxq(ig,ilay)+zfluxq(ig,ilay+1)*(1.-zdq(ig,ilay+1)))
+                     zcq(ig,ilay)=(zmass(ig,ilay)*zq(ig,ilay,iq)+zfluxq(ig,ilay+1)*zcq(ig,ilay+1))*z1(ig)
+                     zdq(ig,ilay)=zfluxq(ig,ilay)*z1(ig)
+                  enddo
+               enddo
+
+               do ig=1,ngrid
+                  z1(ig)=1./(zmass(ig,1)+zfluxq(ig,1)*dryness(ig)+zfluxq(ig,2)*(1.-zdq(ig,2)))
+                  zcq(ig,1)=(zmass(ig,1)*zq(ig,1,iq)+zfluxq(ig,2)*zcq(ig,2))*z1(ig)
+                  zdq(ig,1)=dryness(ig)*zfluxq(ig,1)*z1(ig)
+               enddo
+
+              do ig=1,ngrid
+!calculation of surface temperature
+                  zdq0(ig) = dqsat(ig)
+                  zcq0(ig) = qsat(ig)-dqsat(ig)*ptsrf(ig)
+
+                  z1(ig) = pcapcal(ig)*ptsrf(ig) +cpp*zfluxt(ig,1)*zct(ig,1)*zovExner(ig,1)   &
+		      + zdplanck(ig)*ptsrf(ig) + pfluxsrf(ig)*ptimestep                       &
+                      + zfluxq(ig,1)*dryness(ig)*RLVTT*((zdq(ig,1)-1.0)*zcq0(ig)+zcq(ig,1))
+
+                  z2(ig) = pcapcal(ig) + cpp*zfluxt(ig,1)*(1.-zovExner(ig,1)*zdt(ig,1))       &
+                      + zdplanck(ig)+zfluxq(ig,1)*dryness(ig)*RLVTT*zdq0(ig)*(1.0-zdq(ig,1))
+
+                  ztsrf(ig) = z1(ig) / z2(ig)
+
+! calculation of qs and q1
+                  zq0(ig)     = zcq0(ig)+zdq0(ig)*ztsrf(ig)
+                  zq(ig,1,iq) = zcq(ig,1)+zdq(ig,1)*zq0(ig)
+
+! calculation of evaporation              
+                  dqsdif_total(ig)=zfluxq(ig,1)*dryness(ig)*(zq(ig,1,ivap)-zq0(ig))
+
+!     --------------------------------------------------------
+!     Now check if we've taken too much water from the surface
+!     This can only occur on the continent 
+!     If we do, we recompute Tsurf, T1 and q1 accordingly
+                  if((-dqsdif_total(ig).gt.(pqsurf(ig,iice_surf)+pqsurf(ig,iliq_surf))).and.rnat(ig).eq.1)then
+                      !water flux * ptimestep
+	              dqsdif_total(ig)=-(pqsurf(ig,iice_surf)+pqsurf(ig,iliq_surf))
+
+                      !recompute surface temperature  
+                      z1(ig) = pcapcal(ig)*ptsrf(ig) +cpp*zfluxq(ig,1)*zct(ig,1)*zovExner(ig,1)   &
+		        + zdplanck(ig)*ptsrf(ig) + pfluxsrf(ig)*ptimestep                       &
+                        + RLVTT*dqsdif_total(ig)
+                      z2(ig) = pcapcal(ig) + cpp*zfluxq(ig,1)*(1.-zovExner(ig,1)*zdt(ig,1))       &
+                        + zdplanck(ig)
+                      ztsrf(ig) = z1(ig) / z2(ig)
+
+                      !recompute q1 with new water flux from surface  
+                      zq(ig,1,iq) = (zmass(ig,1)*(pq(ig,1,iq)+ptimestep*pdqfi(ig,1,iq))  &
+		                            +zfluxq(ig,2)*zcq(ig,2)-dqsdif_total(ig))     &
+                                 / (zmass(ig,1)+(1.-zdq(ig,2))*zfluxq(ig,2))		     
+                  end if
+		  
+! calculation surface T tendency  and T(1)           
+		  pdtsrf(ig) = (ztsrf(ig) - ptsrf(ig))/ptimestep
+                  zt(ig,1)   = zct(ig,1) + zdt(ig,1)*ztsrf(ig)		      
+               enddo
+
+
+! recalculate temperature and q(vap) to top of atmosphere, starting from ground
+               do ilay=2,nlay
+                  do ig=1,ngrid
+                     zq(ig,ilay,iq)=zcq(ig,ilay)+zdq(ig,ilay)*zq(ig,ilay-1,iq)
+                     zt(ig,ilay)=zct(ig,ilay)+zdt(ig,ilay)*zt(ig,ilay-1)
+                  end do
+               end do
+
+
+               do ig=1,ngrid
+!     --------------------------------------------------------------------------
+!     On the ocean, if T > 0 C then the vapour tendency must replace the ice one
+!     The surface vapour tracer is actually liquid. To make things difficult.
+
+                  if (nint(rnat(ig)).eq.0) then ! unfrozen ocean
+                     
+                     pdqsdif(ig,iliq_surf)=dqsdif_total(ig)/ptimestep
+                     pdqsdif(ig,iice_surf)=0.0
+
+                  elseif (nint(rnat(ig)).eq.1) then ! (continent)
+!     If water is evaporating / subliming, we take it from ice before liquid
+!     -- is this valid??
+                     if(dqsdif_total(ig).lt.0)then
+                        if (-dqsdif_total(ig).gt.pqsurf(ig,iice_surf))then
+                           pdqsdif(ig,iice_surf) = -pqsurf(ig,iice_surf)/ptimestep ! removes all the ice!
+                           pdqsdif(ig,iliq_surf) = dqsdif_total(ig)/ptimestep- pdqsdif(ig,iice_surf) ! take the remainder from the liquid instead
+			else               
+                           pdqsdif(ig,iice_surf)=dqsdif_total(ig)/ptimestep
+			   pdqsdif(ig,iliq_surf)=0.
+			end if
+	             else !dqsdif_total(ig).ge.0
+                        !If water vapour is condensing, we must decide whether it forms ice or liquid.
+                        if(ztsrf(ig).gt.T_h2O_ice_liq)then
+                           pdqsdif(ig,iice_surf)=0.0
+                           pdqsdif(ig,iliq_surf)=dqsdif_total(ig)/ptimestep
+                        else
+                           pdqsdif(ig,iice_surf)=dqsdif_total(ig)/ptimestep
+                           pdqsdif(ig,iliq_surf)=0.0
+                        endif               
+                     endif
+
+                  elseif (nint(rnat(ig)).eq.2) then ! (continental glaciers)
+		     pdqsdif(ig,iliq_surf)=0.0
+                     pdqsdif(ig,iice_surf)=dqsdif_total(ig)/ptimestep
+
+		  endif !rnat
+               end do            ! of DO ig=1,ngrid
+
+           endif                ! if (water et iq=ivap)
+        end do                  ! of do iq=1,nq
+
+        if (water) then  ! special case where we recompute water mixing without any evaporation.
+	                 !    The difference with the first calculation then tells us where evaporated water has gone
+
+            DO ig=1,ngrid
+               z1(ig)=1./(zmass(ig,nlay)+zfluxq(ig,nlay))
+               zcq(ig,nlay)=zmass(ig,nlay)*zqnoevap(ig,nlay)*z1(ig)
+               zdq(ig,nlay)=zfluxq(ig,nlay)*z1(ig)
+            ENDDO 
+            
+            DO ilay=nlay-1,2,-1
+               DO ig=1,ngrid
+                  z1(ig)=1./(zmass(ig,ilay)+zfluxq(ig,ilay)+zfluxq(ig,ilay+1)*(1.-zdq(ig,ilay+1)))
+                  zcq(ig,ilay)=(zmass(ig,ilay)*zqnoevap(ig,ilay)+zfluxq(ig,ilay+1)*zcq(ig,ilay+1))*z1(ig)
+                  zdq(ig,ilay)=zfluxq(ig,ilay)*z1(ig)
+               ENDDO
+            ENDDO
+
+            do ig=1,ngrid
+               z1(ig)=1./(zmass(ig,1)+zfluxq(ig,2)*(1.-zdq(ig,2)))
+               zcq(ig,1)=(zmass(ig,1)*zqnoevap(ig,1)+zfluxq(ig,2)*zcq(ig,2))*z1(ig)
+            enddo
+
+!     Starting upward calculations for simple tracer mixing (e.g., dust)
+            do ig=1,ngrid
+               zqnoevap(ig,1)=zcq(ig,1)
+            end do
+
+            do ilay=2,nlay
+               do ig=1,ngrid
+                  zqnoevap(ig,ilay)=zcq(ig,ilay)+zdq(ig,ilay)*zqnoevap(ig,ilay-1)
+               end do
+            end do
+
+         endif               ! if water
+	
+	
+      endif                     ! tracer
+
+
+!-----------------------------------------------------------------------
+!     8. Final calculation of the vertical diffusion tendencies
+!     -----------------------------------------------------------------
+
+      do ilev = 1, nlay
+         do ig=1,ngrid
+            pdudif(ig,ilev)=(zu(ig,ilev)-(pu(ig,ilev)+pdufi(ig,ilev)*ptimestep))/ptimestep
+            pdvdif(ig,ilev)=(zv(ig,ilev)-(pv(ig,ilev)+pdvfi(ig,ilev)*ptimestep))/ptimestep
+            pdtdif(ig,ilev)=( zt(ig,ilev)- pt(ig,ilev))/ptimestep-pdtfi(ig,ilev)
+         enddo
+      enddo
+      
+      DO ig=1,ngrid ! computing sensible heat flux (atm => surface)
+	 sensibFlux(ig)=cpp*zfluxt(ig,1)/ptimestep*(zt(ig,1)*zovExner(ig,1)-ztsrf(ig))
+      ENDDO
+
+      if (tracer) then
+         do iq = 1, nq
+            do ilev = 1, nlay
+               do ig=1,ngrid
+                  pdqdif(ig,ilev,iq)=(zq(ig,ilev,iq)-(pq(ig,ilev,iq)+pdqfi(ig,ilev,iq)*ptimestep))/ptimestep
+               enddo
+            enddo
+         enddo
+	 if (water) then
+            do ilev = 1, nlay
+               do ig=1,ngrid
+                  pdqevap(ig,ilev)=(zq(ig,ilev,ivap)-zqnoevap(ig,ilev))/ptimestep
+               enddo
+            enddo
+            do ig=1,ngrid
+	       zdmassevap(ig)=SUM(pdqevap(ig,:)*zmass(ig,:))*ptimestep
+	    end do	    
+	 endif
+      endif 
+
+      if(water)then
+         call writediagfi(ngrid,'beta','Dryness coefficient',' ',2,dryness)
+         if (tracer) then
+            call writediagfi(ngrid,'dqevap','evaporated water vapor specific concentration','s-1',3,pdqevap)
+	 endif
+      endif
+
+!      if(lastcall)then
+!        if(ngrid.eq.1)then
+!           print*,'Saving k.out...'
+!           OPEN(12,file='k.out',form='formatted')
+!           DO ilay=1,nlay
+!              write(12,*) zkh(1,ilay), pplay(1,ilay)
+!           ENDDO
+!           CLOSE(12)
+!         endif
+!      endif
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdif_cd.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdif_cd.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdif_cd.F	(revision 222)
@@ -0,0 +1,75 @@
+      SUBROUTINE vdif_cd( ngrid,nlay,pz0,pg,pz,pu,pv,pts,ph,pcdv,pcdh)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Subject: computation of the surface drag coefficient using the
+c   -------  approch developed by Loui for ECMWF.
+c
+c   Author: Frederic Hourdin  15 /10 /93
+c   -------
+c
+c   Arguments:
+c   ----------
+c
+c   inputs:
+c   ------
+c     ngrid            size of the horizontal grid
+c     pg               gravity (m s -2)
+c     pz(ngrid)        height of the first atmospheric layer
+c     pu(ngrid)        u component of the wind in that layer
+c     pv(ngrid)        v component of the wind in that layer
+c     pts(ngrid)       surfacte temperature
+c     ph(ngrid)        potential temperature T*(p/ps)^kappa
+c
+c   outputs:
+c   --------
+c     pcdv(ngrid)      Cd for the wind
+c     pcdh(ngrid)      Cd for potential temperature
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+c   Arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL pz0
+      REAL pg,pz(ngrid,nlay)
+      REAL pu(ngrid,nlay),pv(ngrid,nlay)
+      REAL pts(ngrid,nlay),ph(ngrid,nlay)
+      REAL pcdv(ngrid),pcdh(ngrid)
+
+c   Local:
+c   ------
+
+      INTEGER ig
+
+      REAL zu2,z1,zri,zcd0,zz
+
+      REAL karman,b,c,d,c2b,c3bc,c3b,umin2
+      LOGICAL firstcal
+      DATA karman,b,c,d,umin2/.4,5.,5.,5.,1.e-12/
+      DATA firstcal/.true./
+      SAVE b,c,d,karman,c2b,c3bc,c3b,firstcal,umin2
+
+c-----------------------------------------------------------------------
+c   couche de surface:
+c   ------------------
+
+! simplified calculation
+
+      DO ig=1,ngrid
+         z1=1.E+0 + pz(ig,1)/pz0
+         zcd0=karman/log(z1)
+         zcd0=zcd0*zcd0
+         pcdv(ig)=zcd0
+         pcdh(ig)=zcd0
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdif_kc.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdif_kc.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdif_kc.F	(revision 222)
@@ -0,0 +1,534 @@
+      SUBROUTINE vdif_kc(ngrid,dt,g,zlev,zlay,u,v,teta,cd,q2,km,kn)
+      IMPLICIT NONE
+c.......................................................................
+#include "dimensions.h"
+#include "dimphys.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c 
+c.......................................................................
+      INTEGER,INTENT(IN) :: ngrid
+      REAL,INTENT(IN) :: dt,g
+      REAL,INTENT(IN) :: zlev(ngrid,nlayermx+1)
+      REAL,INTENT(IN) :: zlay(ngrid,nlayermx)
+      REAL,INTENT(IN) :: u(ngrid,nlayermx)
+      REAL,INTENT(IN) :: v(ngrid,nlayermx)
+      REAL,INTENT(IN) :: teta(ngrid,nlayermx)
+      REAL,INTENT(IN) :: cd(ngrid)
+      REAL,INTENT(INOUT) :: q2(ngrid,nlayermx+1)
+      REAL,INTENT(OUT) :: km(ngrid,nlayermx+1)
+      REAL,INTENT(OUT) :: kn(ngrid,nlayermx+1)
+c.......................................................................
+c
+c nlay : nombre de couches        
+c nlev : nombre de niveaux
+c ngrid : nombre de points de grille       
+c unsdz : 1 sur l'epaisseur de couche
+c unsdzdec : 1 sur la distance entre le centre de la couche et le
+c            centre de la couche inferieure
+c q : echelle de vitesse au bas de chaque couche
+c     (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      INTEGER,PARAMETER :: nlay=nlayermx
+      INTEGER,PARAMETER :: nlev=nlayermx+1
+      REAL unsdz(ngrid,nlayermx)
+      REAL unsdzdec(ngrid,nlayermx+1)
+      REAL q(ngrid,nlayermx+1)
+c.......................................................................
+c
+c kmpre : km au debut du pas de temps
+c qcstat : q : solution stationnaire du probleme couple
+c          (valeur a la fin du pas de temps)
+c q2cstat : q2 : solution stationnaire du probleme couple
+c           (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL kmpre(ngrid,nlayermx+1)
+      REAL qcstat
+      REAL q2cstat
+c.......................................................................
+c
+c long : longueur de melange calculee selon Blackadar
+c
+c.......................................................................
+      REAL long(ngrid,nlayermx+1)
+c.......................................................................
+c
+c kmq3 : terme en q^3 dans le developpement de km
+c        (valeur au debut du pas de temps)
+c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c knq3 : terme en q^3 dans le developpement de kn
+c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+c          (valeur a la fin du pas de temps)
+c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c m : valeur a la fin du pas de temps
+c mpre : valeur au debut du pas de temps
+c m2 : valeur a la fin du pas de temps
+c n2 : valeur a la fin du pas de temps
+c 
+c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(ngrid,nlayermx+1)
+      REAL mpre(ngrid,nlayermx+1)
+      REAL m2(ngrid,nlayermx+1)
+      REAL n2(ngrid,nlayermx+1)
+c.......................................................................
+c
+c gn : intermediaire pour les coefficients de stabilite
+c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+c gnmax : borne superieure de gn (0.0233)
+c gninf : vrai si gn est en dessous de sa borne inferieure
+c gnsup : vrai si gn est en dessus de sa borne superieure
+c gm : drole d'objet bien utile
+c ri : nombre de Richardson
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c sm : coefficient de stabilite pour m
+c smq2 : premier terme du developement limite de sm en q2
+c
+c.......................................................................
+      REAL gn
+      REAL,PARAMETER :: gnmin=-10.E+0
+      REAL,PARAMETER :: gnmax=0.0233E+0
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+c      REAL ri(ngrid,nlayermx+1)
+      REAL sn(ngrid,nlayermx+1)
+      REAL snq2(ngrid,nlayermx+1)
+      REAL sm(ngrid,nlayermx+1)
+      REAL smq2(ngrid,nlayermx+1)
+c.......................................................................
+c
+c kappa : consatnte de Von Karman (0.4)
+c long0 : longueur de reference pour le calcul de long (160)
+c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+c cn1,cn2 : constantes pour sn
+c cm1,cm2,cm3,cm4 : constantes pour sm
+c
+c.......................................................................
+      REAL,PARAMETER :: kappa=0.4E+0
+      REAL,PARAMETER :: long0=160.E+0
+      REAL,PARAMETER :: a1=0.92E+0,a2=0.74E+0
+      REAL,PARAMETER :: b1=16.6E+0,b2=10.1E+0,c1=0.08E+0
+      REAL,PARAMETER :: cn1=a2*(1.E+0 -6.E+0 *a1/b1)
+      REAL,PARAMETER :: cn2=-3.E+0 *a2*(6.E+0 *a1+b2)
+      REAL,PARAMETER :: cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)
+      REAL,PARAMETER :: cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*
+     &          (1.E+0 -6.E+0 *a1/b1)-3.E+0 *c1*(b2+6.E+0 *a1)))
+      REAL,PARAMETER :: cm3=-3.E+0 *a2*(6.E+0 *a1+b2)
+      REAL,PARAMETER :: cm4=-9.E+0 *a1*a2
+c.......................................................................
+c
+c termq : termes en $q$ dans l'equation de q2
+c termq3 : termes en $q^3$ dans l'equation de q2
+c termqm2 : termes en $q*m^2$ dans l'equation de q2
+c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+c
+c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+c.......................................................................
+c
+c q2min : borne inferieure de q2
+c q2max : borne superieure de q2
+c
+c.......................................................................
+      REAL,PARAMETER :: q2min=1.E-3
+      REAL,PARAMETER :: q2max=1.E+2
+c.......................................................................
+c knmin : borne inferieure de kn
+c kmmin : borne inferieure de km
+c.......................................................................
+      REAL,PARAMETER :: knmin=1.E-5
+      REAL,PARAMETER :: kmmin=1.E-5
+c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+c.......................................................................
+c
+
+! initialization of local variables:
+      long(:,:)=0.
+      n2(:,:)=0.
+      sn(:,:)=0.
+      snq2(:,:)=0.
+      sm(:,:)=0.
+      smq2(:,:)=0.
+
+c.......................................................................
+c  traitment des valeur de q2 en entree
+c.......................................................................
+c
+      DO ilev=1,nlev
+       DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+       ENDDO
+      ENDDO
+c
+      DO igrid=1,ngrid
+        tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+        q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+        q2(igrid,1)=amax1(q2(igrid,1),q2min)
+        q(igrid,1)=sqrt(q2(igrid,1))
+      ENDDO
+c
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+c                                                     DO igrid=1,ngrid 
+c           zlev(igrid,nlev)=zlay(igrid,nlay)
+c    &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+c                                                     ENDDO            
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO ilay=1,nlay
+       DO igrid=1,ngrid
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+       ENDDO
+      ENDDO
+
+      DO igrid=1,ngrid
+        unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+      ENDDO
+
+      DO ilay=2,nlay
+        DO igrid=1,ngrid
+          unsdzdec(igrid,ilay)=1.E+0/
+     &                          (zlay(igrid,ilay)-zlay(igrid,ilay-1))
+        ENDDO
+      ENDDO
+      
+      DO igrid=1,ngrid
+        unsdzdec(igrid,nlay+1)=1.E+0/
+     &                          (zlev(igrid,nlay+1)-zlay(igrid,nlay))
+      ENDDO
+c
+c.......................................................................
+c  le cisaillement et le gradient de temperature
+c.......................................................................
+c
+      DO igrid=1,ngrid
+        m2(igrid,1)=(unsdzdec(igrid,1)
+     &                   *u(igrid,1))**2
+     &                 +(unsdzdec(igrid,1)
+     &                   *v(igrid,1))**2
+        m(igrid,1)=sqrt(m2(igrid,1))
+        mpre(igrid,1)=m(igrid,1)
+      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+       DO igrid=1,ngrid
+c-----------------------------------------------------------------------
+c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)
+     &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))
+     &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+c
+c --->
+c       on ne sais traiter que les cas stratifies. et l'ajustement
+c       convectif est cense faire en sorte que seul des configurations
+c       stratifiees soient rencontrees en entree de cette routine.
+c       mais, bon ... on sait jamais (meme on sait que n2 prends
+c       quelques valeurs negatives ... parfois) alors : 
+c<---
+c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)
+     &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2
+     &                   +(unsdzdec(igrid,ilev)
+     &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+       ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+      DO igrid=1,ngrid
+        m2(igrid,nlev)=m2(igrid,nlev-1)
+        m(igrid,nlev)=m(igrid,nlev-1)
+        mpre(igrid,nlev)=m(igrid,nlev)
+      ENDDO
+      
+c
+c.......................................................................
+c  calcul des fonctions de stabilite
+c.......................................................................
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+       DO igrid=1,ngrid
+c-----------------------------------------------------------------------
+c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0)
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * m2(igrid,ilev)
+c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)
+     &     *(1.E+0 +cm4*gn) )
+c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=
+     &     -gn
+     &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=
+     &     -gn
+     &     *( cm2*(1.E+0 +cm3*gn)
+     &           *(1.E+0 +cm4*gn)
+     &       -( cm3*(1.E+0 +cm4*gn)
+     &         +cm4*(1.E+0 +cm3*gn) )
+     &       *(cm1+cm2*gn)            )
+     &     /( (1.E+0 +cm3*gn)
+     &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+c
+c --->
+c       la decomposition de Taylor en q2 n'a de sens que
+c       dans les cas stratifies ou sn et sm sont quasi
+c       proportionnels a q2. ailleurs on laisse le meme
+c       algorithme car l'ajustement convectif fait le travail.
+c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+c       signe : dans ces cas, on ne fait pas la decomposition.
+c<---
+c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)
+     &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)
+     &      smq2(igrid,ilev)=0.E+0
+c
+c-----------------------------------------------------------------------
+       ENDDO ! of DO igrid=1,ngrid
+      ENDDO ! of DO ilev=2,nlev-1
+c-----------------------------------------------------------------------
+c
+c.......................................................................
+c  calcul de km et kn au debut du pas de temps
+c.......................................................................
+c
+      DO igrid=1,ngrid
+        kn(igrid,1)=knmin
+        km(igrid,1)=kmmin
+        kmpre(igrid,1)=km(igrid,1)
+      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+       DO igrid=1,ngrid
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+       ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+      DO igrid=1,ngrid
+        kn(igrid,nlev)=kn(igrid,nlev-1)
+        km(igrid,nlev)=km(igrid,nlev-1)
+        kmpre(igrid,nlev)=km(igrid,nlev)
+      ENDDO
+c
+c.......................................................................
+c  boucle sur les niveaux 2 a nlev-1
+c.......................................................................
+c
+c---->
+      DO 10001 ilev=2,nlev-1
+c---->
+      DO 10002 igrid=1,ngrid
+c
+c.......................................................................
+c
+c  calcul des termes sources et puits de l'equation de q2
+c  ------------------------------------------------------
+c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)
+     &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)
+     &                                    /sm(igrid,ilev)
+c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2
+     &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+     &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2
+     &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+c 
+        termq=termq
+     &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)
+     &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3
+     &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+c
+        termq3=termq3
+     &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+c
+c.......................................................................
+c
+c  resolution stationnaire couplee avec le gradient de vitesse local
+c  -----------------------------------------------------------------
+c
+c  -----{on cherche le cisaillement qui annule l'equation de q^2
+c        supposee en q3}
+c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)
+     &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)
+     &              *cd(igrid)
+     &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)
+     &                -mcstat/unsdzdec(igrid,ilev)
+     &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)
+     &                          *mpre(igrid,ilev-1) )
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat
+     &      /( sm(igrid,ilev)/q2(igrid,ilev) )
+     &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+c
+c.......................................................................
+c
+c  choix de la solution finale
+c  ---------------------------
+c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+          m2(igrid,ilev)=m2cstat
+c
+c --->
+c       pour des raisons simples q2 est minore 
+c<---
+c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+c
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sm(igrid,ilev)
+c
+c.......................................................................
+c
+10002 CONTINUE
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+c
+      DO igrid=1,ngrid
+        kn(igrid,1)=knmin
+        km(igrid,1)=kmmin
+        q2(igrid,nlev)=q2(igrid,nlev-1)
+        q(igrid,nlev)=q(igrid,nlev-1)
+        kn(igrid,nlev)=kn(igrid,nlev-1)
+        km(igrid,nlev)=km(igrid,nlev-1)
+      ENDDO
+
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdifc.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdifc.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vdifc.F	(revision 222)
@@ -0,0 +1,729 @@
+      subroutine vdifc(ngrid,nlay,nq,rnat,ppopsk,         
+     &     ptimestep,pcapcal,lecrit,                        
+     &     pplay,pplev,pzlay,pzlev,pz0,
+     &     pu,pv,ph,pq,ptsrf,pemis,pqsurf,
+     &     pdufi,pdvfi,pdhfi,pdqfi,pfluxsrf,
+     &     pdudif,pdvdif,pdhdif,pdtsrf,sensibFlux,pq2,
+     &     pdqdif,pdqsdif,lastcall)
+
+      use watercommon_h, only : RLVTT, T_h2O_ice_liq, RCPD, mx_eau_sol
+      use radcommon_h, only : sigma
+      USE surfdat_h
+      USE comgeomfi_h
+      USE tracer_h
+
+      implicit none
+
+!==================================================================
+!     
+!     Purpose
+!     -------
+!     Turbulent diffusion (mixing) for pot. T, U, V and tracers
+!     
+!     Implicit scheme
+!     We start by adding to variables x the physical tendencies
+!     already computed. We resolve the equation:
+!
+!     x(t+1) =  x(t) + dt * (dx/dt)phys(t)  +  dt * (dx/dt)difv(t+1)
+!     
+!     Authors
+!     ------- 
+!     F. Hourdin, F. Forget, R. Fournier (199X)
+!     R. Wordsworth, B. Charnay (2010)
+!     
+!==================================================================
+
+!-----------------------------------------------------------------------
+!     declarations
+!     ------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+
+!     arguments
+!     ---------
+      INTEGER ngrid,nlay
+      REAL ptimestep
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      REAL pzlay(ngrid,nlay),pzlev(ngrid,nlay+1)
+      REAL pu(ngrid,nlay),pv(ngrid,nlay),ph(ngrid,nlay)
+      REAL ptsrf(ngrid),pemis(ngrid)
+      REAL pdufi(ngrid,nlay),pdvfi(ngrid,nlay),pdhfi(ngrid,nlay)
+      REAL pfluxsrf(ngrid)
+      REAL pdudif(ngrid,nlay),pdvdif(ngrid,nlay),pdhdif(ngrid,nlay)
+      REAL pdtsrf(ngrid),sensibFlux(ngrid),pcapcal(ngrid)
+      REAL pq2(ngrid,nlay+1)
+      
+      real rnat(ngrid)      
+
+!     Arguments added for condensation
+      REAL ppopsk(ngrid,nlay)
+      logical lecrit
+      REAL pz0
+
+!     Tracers
+!     --------
+      integer nq 
+      real pqsurf(ngrid,nq)
+      real pq(ngrid,nlay,nq), pdqfi(ngrid,nlay,nq) 
+      real pdqdif(ngrid,nlay,nq) 
+      real pdqsdif(ngrid,nq) 
+      
+!     local
+!     -----
+      integer ilev,ig,ilay,nlev
+
+      REAL z4st,zdplanck(ngrid)
+      REAL zkv(ngrid,nlayermx+1),zkh(ngrid,nlayermx+1)
+      REAL zcdv(ngrid),zcdh(ngrid)
+      REAL zcdv_true(ngrid),zcdh_true(ngrid)
+      REAL zu(ngrid,nlayermx),zv(ngrid,nlayermx)
+      REAL zh(ngrid,nlayermx)
+      REAL ztsrf2(ngrid)
+      REAL z1(ngrid),z2(ngrid)
+      REAL za(ngrid,nlayermx),zb(ngrid,nlayermx)
+      REAL zb0(ngrid,nlayermx)
+      REAL zc(ngrid,nlayermx),zd(ngrid,nlayermx)
+      REAL zcst1
+      REAL zu2!, a
+      REAL zcq(ngrid,nlayermx),zdq(ngrid,nlayermx)
+      REAL evap(ngrid)
+      REAL zcq0(ngrid),zdq0(ngrid)
+      REAL zx_alf1(ngrid),zx_alf2(ngrid)
+
+      LOGICAL firstcall
+      SAVE firstcall
+      
+      LOGICAL lastcall
+
+!     variables added for CO2 condensation
+!     ------------------------------------
+      REAL hh                   !, zhcond(ngrid,nlayermx)
+!     REAL latcond,tcond1mb
+!     REAL acond,bcond
+!     SAVE acond,bcond
+!     DATA latcond,tcond1mb/5.9e5,136.27/
+
+!     Tracers
+!     -------
+      INTEGER iq
+      REAL zq(ngrid,nlayermx,nq)
+      REAL zq1temp(ngrid)
+      REAL rho(ngrid)         ! near-surface air density
+      REAL qsat(ngrid)
+      DATA firstcall/.true./
+      REAL kmixmin
+
+!     Variables added for implicit latent heat inclusion
+!     --------------------------------------------------
+      real latconst, dqsat(ngrid), qsat_temp1, qsat_temp2
+      real z1_Tdry(ngrid), z2_Tdry(ngrid)
+      real z1_T(ngrid), z2_T(ngrid)
+      real zb_T(ngrid)
+      real zc_T(ngrid,nlayermx)
+      real zd_T(ngrid,nlayermx)
+      real lat1(ngrid), lat2(ngrid)
+      real surfh2otot
+      logical surffluxdiag
+      integer isub ! sub-loop for precision
+
+      integer ivap, iice ! also make liq for clarity on surface...
+      save ivap, iice
+
+      real, parameter :: karman=0.4
+      real cd0, roughratio
+
+      logical forceWC
+      real masse, Wtot, Wdiff
+
+      real dqsdif_total(ngrid) 
+      real zq0(ngrid) 
+
+      forceWC=.true.
+!      forceWC=.false.
+
+
+!     Coherence test
+!     --------------
+
+      IF (firstcall) THEN
+!     To compute: Tcond= 1./(bcond-acond*log(.0095*p)) (p in pascal)
+!     bcond=1./tcond1mb
+!     acond=r/latcond
+!     PRINT*,'In vdifc: Tcond(P=1mb)=',tcond1mb,' Lcond=',latcond
+!     PRINT*,'          acond,bcond',acond,bcond
+
+         if(water)then
+!                iliq=igcm_h2o_vap
+                ivap=igcm_h2o_vap
+                iice=igcm_h2o_ice ! simply to make the code legible               
+                                  ! to be generalised later
+         endif
+
+         firstcall=.false.
+      ENDIF
+
+!-----------------------------------------------------------------------
+!     1. Initialisation
+!     -----------------
+
+      nlev=nlay+1
+
+!     Calculate rho*dz and dt*rho/dz=dt*rho**2 g/dp
+!     with rho=p/RT=p/ (R Theta) (p/ps)**kappa
+!     ---------------------------------------------
+
+      DO ilay=1,nlay
+         DO ig=1,ngrid
+            za(ig,ilay)=(pplev(ig,ilay)-pplev(ig,ilay+1))/g
+         ENDDO
+      ENDDO
+
+      zcst1=4.*g*ptimestep/(R*R)
+      DO ilev=2,nlev-1
+         DO ig=1,ngrid
+            zb0(ig,ilev)=pplev(ig,ilev)*
+     s           (pplev(ig,1)/pplev(ig,ilev))**rcp /
+     s           (ph(ig,ilev-1)+ph(ig,ilev))
+            zb0(ig,ilev)=zcst1*zb0(ig,ilev)*zb0(ig,ilev)/
+     s           (pplay(ig,ilev-1)-pplay(ig,ilev))
+         ENDDO
+      ENDDO
+      DO ig=1,ngrid
+         zb0(ig,1)=ptimestep*pplev(ig,1)/(R*ptsrf(ig))
+      ENDDO
+
+      dqsdif_total(:)=0.0
+
+!-----------------------------------------------------------------------
+!     2. Add the physical tendencies computed so far
+!     ----------------------------------------------
+
+      DO ilev=1,nlay
+         DO ig=1,ngrid
+            zu(ig,ilev)=pu(ig,ilev)+pdufi(ig,ilev)*ptimestep
+            zv(ig,ilev)=pv(ig,ilev)+pdvfi(ig,ilev)*ptimestep
+            zh(ig,ilev)=ph(ig,ilev)+pdhfi(ig,ilev)*ptimestep
+         ENDDO
+      ENDDO
+      if(tracer) then
+         DO iq =1, nq
+            DO ilev=1,nlay
+               DO ig=1,ngrid
+                  zq(ig,ilev,iq)=pq(ig,ilev,iq) + 
+     &                 pdqfi(ig,ilev,iq)*ptimestep
+               ENDDO
+            ENDDO
+         ENDDO
+      end if
+
+!-----------------------------------------------------------------------
+!     3. Turbulence scheme
+!     --------------------
+!
+!     Source of turbulent kinetic energy at the surface
+!     ------------------------------------------------- 
+!     Formula is Cd_0 = (karman / log[1+z1/z0])^2
+
+      DO ig=1,ngrid
+         roughratio = 1.E+0 + pzlay(ig,1)/pz0
+         cd0 = karman/log(roughratio)
+         cd0 = cd0*cd0
+         zcdv_true(ig) = cd0
+         zcdh_true(ig) = cd0
+         if (nosurf) then
+             zcdv_true(ig) = 0.   !! disable sensible momentum flux
+             zcdh_true(ig) = 0.   !! disable sensible heat flux
+         endif
+      ENDDO
+
+      DO ig=1,ngrid
+         zu2=pu(ig,1)*pu(ig,1)+pv(ig,1)*pv(ig,1)
+         zcdv(ig)=zcdv_true(ig)*sqrt(zu2)
+         zcdh(ig)=zcdh_true(ig)*sqrt(zu2)
+      ENDDO
+
+!     Turbulent diffusion coefficients in the boundary layer
+!     ------------------------------------------------------ 
+
+      call vdif_kc(ngrid,ptimestep,g,pzlev,pzlay
+     &     ,pu,pv,ph,zcdv_true
+     &     ,pq2,zkv,zkh)
+
+!     Adding eddy mixing to mimic 3D general circulation in 1D
+!     R. Wordsworth & F. Forget (2010)
+      if ((ngrid.eq.1)) then
+         kmixmin = 1.0e-2       ! minimum eddy mix coeff in 1D
+         do ilev=1,nlay
+            do ig=1,ngrid
+               !zkh(ig,ilev) = 1.0
+               zkh(ig,ilev) = max(kmixmin,zkh(ig,ilev))
+               zkv(ig,ilev) = max(kmixmin,zkv(ig,ilev))
+            end do
+         end do
+      end if
+
+!-----------------------------------------------------------------------
+!     4. Implicit inversion of u
+!     --------------------------
+
+!     u(t+1) =  u(t) + dt * {(du/dt)phys}(t)  +  dt * {(du/dt)difv}(t+1)
+!     avec
+!     /zu/ = u(t) + dt * {(du/dt)phys}(t)   (voir paragraphe 2.)
+!     et
+!     dt * {(du/dt)difv}(t+1) = dt * {(d/dz)[ Ku (du/dz) ]}(t+1)
+!     donc les entrees sont /zcdv/ pour la condition a la limite sol
+!     et /zkv/ = Ku
+      
+      CALL multipl((nlay-1)*ngrid,zkv(1,2),zb0(1,2),zb(1,2))
+      CALL multipl(ngrid,zcdv,zb0,zb)
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+         zc(ig,nlay)=za(ig,nlay)*zu(ig,nlay)*z1(ig)
+         zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $           zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+            zc(ig,ilay)=(za(ig,ilay)*zu(ig,ilay)+
+     $           zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+            zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         zu(ig,1)=zc(ig,1)
+      ENDDO
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            zu(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*zu(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+!-----------------------------------------------------------------------
+!     5. Implicit inversion of v
+!     --------------------------
+
+!     v(t+1) =  v(t) + dt * {(dv/dt)phys}(t)  +  dt * {(dv/dt)difv}(t+1)
+!     avec
+!     /zv/ = v(t) + dt * {(dv/dt)phys}(t)   (voir paragraphe 2.)
+!     et
+!     dt * {(dv/dt)difv}(t+1) = dt * {(d/dz)[ Kv (dv/dz) ]}(t+1)
+!     donc les entrees sont /zcdv/ pour la condition a la limite sol
+!     et /zkv/ = Kv
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+         zc(ig,nlay)=za(ig,nlay)*zv(ig,nlay)*z1(ig)
+         zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $           zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+            zc(ig,ilay)=(za(ig,ilay)*zv(ig,ilay)+
+     $           zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+            zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         zv(ig,1)=zc(ig,1)
+      ENDDO
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            zv(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*zv(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+!----------------------------------------------------------------------------
+!     6. Implicit inversion of h, not forgetting the coupling with the ground
+
+!     h(t+1) =  h(t) + dt * {(dh/dt)phys}(t)  +  dt * {(dh/dt)difv}(t+1)
+!     avec
+!     /zh/ = h(t) + dt * {(dh/dt)phys}(t)   (voir paragraphe 2.)
+!     et
+!     dt * {(dh/dt)difv}(t+1) = dt * {(d/dz)[ Kh (dh/dz) ]}(t+1)
+!     donc les entrees sont /zcdh/ pour la condition de raccord au sol
+!     et /zkh/ = Kh
+
+!     Using the wind modified by friction for lifting and sublimation
+!     ---------------------------------------------------------------
+         DO ig=1,ngrid
+            zu2      = zu(ig,1)*zu(ig,1)+zv(ig,1)*zv(ig,1)
+            zcdv(ig) = zcdv_true(ig)*sqrt(zu2)
+            zcdh(ig) = zcdh_true(ig)*sqrt(zu2)
+         ENDDO
+
+      CALL multipl((nlay-1)*ngrid,zkh(1,2),zb0(1,2),zb(1,2))
+      CALL multipl(ngrid,zcdh,zb0,zb)
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+         zc(ig,nlay)=za(ig,nlay)*zh(ig,nlay)*z1(ig)
+         zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,2,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     &           zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+            zc(ig,ilay)=(za(ig,ilay)*zh(ig,ilay)+
+     &           zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+            zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,1)+zb(ig,1)+
+     &        zb(ig,2)*(1.-zd(ig,2)))
+         zc(ig,1)=(za(ig,1)*zh(ig,1)+
+     &        zb(ig,2)*zc(ig,2))*z1(ig)
+         zd(ig,1)=zb(ig,1)*z1(ig)
+      ENDDO
+
+!     Calculate (d Planck / dT) at the interface temperature
+!     ------------------------------------------------------
+
+      z4st=4.0*sigma*ptimestep
+      DO ig=1,ngrid
+         zdplanck(ig)=z4st*pemis(ig)*ptsrf(ig)*ptsrf(ig)*ptsrf(ig)
+      ENDDO
+
+!     Calculate temperature tendency at the interface (dry case)
+!     ----------------------------------------------------------
+!     Sum of fluxes at interface at time t + \delta t gives change in T:
+!       radiative fluxes
+!       turbulent convective (sensible) heat flux
+!       flux (if any) from subsurface
+
+      if(.not.water) then
+
+         DO ig=1,ngrid
+
+            z1(ig) = pcapcal(ig)*ptsrf(ig) + cpp*zb(ig,1)*zc(ig,1)
+     &           + zdplanck(ig)*ptsrf(ig) + pfluxsrf(ig)*ptimestep
+            z2(ig) = pcapcal(ig) + cpp*zb(ig,1)*(1.-zd(ig,1)) 
+     &           +zdplanck(ig)
+            ztsrf2(ig) = z1(ig) / z2(ig)
+            pdtsrf(ig) = (ztsrf2(ig) - ptsrf(ig))/ptimestep
+            zh(ig,1)   = zc(ig,1) + zd(ig,1)*ztsrf2(ig)
+         ENDDO
+
+!     Recalculate temperature to top of atmosphere, starting from ground
+!     ------------------------------------------------------------------
+
+         DO ilay=2,nlay
+            DO ig=1,ngrid
+               hh = zh(ig,ilay-1)
+               zh(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*hh
+            ENDDO
+         ENDDO
+
+      endif                     ! not water
+
+!-----------------------------------------------------------------------
+!     TRACERS (no vapour)
+!     -------
+
+      if(tracer) then
+
+!     Calculate vertical flux from the bottom to the first layer (dust)
+!     -----------------------------------------------------------------
+         do ig=1,ngrid  
+            rho(ig) = zb0(ig,1) /ptimestep
+         end do
+
+         call zerophys(ngrid*nq,pdqsdif)
+
+!     Implicit inversion of q
+!     -----------------------
+         do iq=1,nq 
+
+            if (iq.ne.igcm_h2o_vap) then
+
+               DO ig=1,ngrid
+                  z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+                  zcq(ig,nlay)=za(ig,nlay)*zq(ig,nlay,iq)*z1(ig)
+                  zdq(ig,nlay)=zb(ig,nlay)*z1(ig)
+               ENDDO 
+            
+               DO ilay=nlay-1,2,-1
+                  DO ig=1,ngrid
+                     z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     &                    zb(ig,ilay+1)*(1.-zdq(ig,ilay+1)))
+                     zcq(ig,ilay)=(za(ig,ilay)*zq(ig,ilay,iq)+
+     &                    zb(ig,ilay+1)*zcq(ig,ilay+1))*z1(ig)
+                     zdq(ig,ilay)=zb(ig,ilay)*z1(ig)
+                  ENDDO
+               ENDDO
+
+               if ((water).and.(iq.eq.iice)) then
+                  ! special case for water ice tracer: do not include
+                  ! h2o ice tracer from surface (which is set when handling
+                  ! h2o vapour case (see further down).
+                  ! zb(ig,1)=0 if iq ne ivap
+                  DO ig=1,ngrid
+                     z1(ig)=1./(za(ig,1)+
+     &                    zb(ig,2)*(1.-zdq(ig,2)))
+                     zcq(ig,1)=(za(ig,1)*zq(ig,1,iq)+
+     &                    zb(ig,2)*zcq(ig,2))*z1(ig)
+                  ENDDO
+               else             ! general case
+                  DO ig=1,ngrid
+                     z1(ig)=1./(za(ig,1)+
+     &                    zb(ig,2)*(1.-zdq(ig,2)))
+                     zcq(ig,1)=(za(ig,1)*zq(ig,1,iq)+
+     &                    zb(ig,2)*zcq(ig,2)
+     &                    +(-pdqsdif(ig,iq))*ptimestep)*z1(ig)
+                          ! tracer flux from surface
+                          ! currently pdqsdif always zero here,
+                          ! so last line is superfluous
+                  enddo
+               endif            ! of if (water.and.(iq.eq.igcm_h2o_ice))
+
+
+!     Starting upward calculations for simple tracer mixing (e.g., dust)
+               do ig=1,ngrid
+                  zq(ig,1,iq)=zcq(ig,1)
+               end do
+
+               do ilay=2,nlay
+                  do ig=1,ngrid
+                     zq(ig,ilay,iq)=zcq(ig,ilay)+
+     $                    zdq(ig,ilay)*zq(ig,ilay-1,iq)
+                  end do
+               end do
+
+            endif               ! if (iq.ne.igcm_h2o_vap)
+
+!     Calculate temperature tendency including latent heat term
+!     and assuming an infinite source of water on the ground
+!     ------------------------------------------------------------------
+
+            if (water.and.(iq.eq.igcm_h2o_vap)) then 
+            
+               ! compute evaporation efficiency
+               do ig = 1, ngrid
+                  if(nint(rnat(ig)).eq.1)then
+                     dryness(ig)=pqsurf(ig,ivap)+pqsurf(ig,iice) 
+                     dryness(ig)=MIN(1.,2*dryness(ig)/mx_eau_sol)
+                     dryness(ig)=MAX(0.,dryness(ig))
+                  endif
+               enddo
+
+               do ig=1,ngrid
+
+                ! Calculate the value of qsat at the surface (water)
+                call watersat(ptsrf(ig),pplev(ig,1),qsat(ig))
+                call watersat(ptsrf(ig)-0.0001,pplev(ig,1),qsat_temp1)
+                call watersat(ptsrf(ig)+0.0001,pplev(ig,1),qsat_temp2)
+                dqsat(ig)=(qsat_temp2-qsat_temp1)/0.0002
+                ! calculate dQsat / dT by finite differences
+                ! we cannot use the updated temperature value yet...
+ 
+               enddo
+
+! coefficients for q
+
+               do ig=1,ngrid
+                  z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+                  zcq(ig,nlay)=za(ig,nlay)*zq(ig,nlay,iq)*z1(ig)
+                  zdq(ig,nlay)=zb(ig,nlay)*z1(ig)
+               enddo 
+            
+               do ilay=nlay-1,2,-1
+                  do ig=1,ngrid
+                     z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $                    zb(ig,ilay+1)*(1.-zdq(ig,ilay+1)))
+                     zcq(ig,ilay)=(za(ig,ilay)*zq(ig,ilay,iq)+
+     $                    zb(ig,ilay+1)*zcq(ig,ilay+1))*z1(ig)
+                     zdq(ig,ilay)=zb(ig,ilay)*z1(ig)
+                  enddo
+               enddo
+
+               do ig=1,ngrid
+                  z1(ig)=1./(za(ig,1)+zb(ig,1)*dryness(ig)+
+     $                 zb(ig,2)*(1.-zdq(ig,2)))
+                  zcq(ig,1)=(za(ig,1)*zq(ig,1,iq)+
+     $                 zb(ig,2)*zcq(ig,2))*z1(ig)
+                  zdq(ig,1)=dryness(ig)*zb(ig,1)*z1(ig)
+               enddo
+
+! calculation of h0 and h1
+               do ig=1,ngrid
+                  zdq0(ig) = dqsat(ig)
+                  zcq0(ig) = qsat(ig)-dqsat(ig)*ptsrf(ig)
+
+                  z1(ig) = pcapcal(ig)*ptsrf(ig) +cpp*zb(ig,1)*zc(ig,1)
+     &                 + zdplanck(ig)*ptsrf(ig) + pfluxsrf(ig)*ptimestep 
+     &                 +  zb(ig,1)*dryness(ig)*RLVTT*
+     &                 ((zdq(ig,1)-1.0)*zcq0(ig)+zcq(ig,1))
+
+                  z2(ig) = pcapcal(ig) + cpp*zb(ig,1)*(1.-zd(ig,1))
+     &                 +zdplanck(ig)
+     &                 +zb(ig,1)*dryness(ig)*RLVTT*zdq0(ig)*
+     &                 (1.0-zdq(ig,1))
+
+                  ztsrf2(ig) = z1(ig) / z2(ig)
+                  pdtsrf(ig) = (ztsrf2(ig) - ptsrf(ig))/ptimestep
+                  zh(ig,1)   = zc(ig,1) + zd(ig,1)*ztsrf2(ig)
+               enddo
+
+! calculation of qs and q1
+               do ig=1,ngrid
+                  zq0(ig)     = zcq0(ig)+zdq0(ig)*ztsrf2(ig)
+                  zq(ig,1,iq) = zcq(ig,1)+zdq(ig,1)*zq0(ig)
+               enddo
+
+! calculation of evaporation              
+               do ig=1,ngrid 
+                  evap(ig)= zb(ig,1)*dryness(ig)*(zq(ig,1,ivap)-zq0(ig))
+                  dqsdif_total(ig)=evap(ig)
+               enddo
+
+! recalculate temperature and q(vap) to top of atmosphere, starting from ground
+               do ilay=2,nlay
+                  do ig=1,ngrid
+                     zq(ig,ilay,iq)=zcq(ig,ilay)
+     &                    +zdq(ig,ilay)*zq(ig,ilay-1,iq)
+                     zh(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*zh(ig,ilay-1)
+                  end do
+               end do
+
+               do ig=1,ngrid
+
+!     --------------------------------------------------------------------------
+!     On the ocean, if T > 0 C then the vapour tendency must replace the ice one
+!     The surface vapour tracer is actually liquid. To make things difficult.
+
+                  if (nint(rnat(ig)).eq.0) then ! unfrozen ocean
+                     
+                     pdqsdif(ig,ivap)=dqsdif_total(ig)/ptimestep
+                     pdqsdif(ig,iice)=0.0
+
+
+                  elseif (nint(rnat(ig)).eq.1) then ! (continent)
+
+!     --------------------------------------------------------
+!     Now check if we've taken too much water from the surface
+!     This can only occur on the continent 
+
+!     If water is evaporating / subliming, we take it from ice before liquid
+!     -- is this valid??
+                     if(dqsdif_total(ig).lt.0)then
+                        pdqsdif(ig,iice)=dqsdif_total(ig)/ptimestep
+                        pdqsdif(ig,iice)=max(-pqsurf(ig,iice)/ptimestep
+     &                       ,pdqsdif(ig,iice))
+                     endif
+                     ! sublimation only greater than qsurf(ice)
+                     ! ----------------------------------------
+                     ! we just convert some liquid to vapour too
+                     ! if latent heats are the same, no big deal
+                     if (-dqsdif_total(ig).gt.pqsurf(ig,iice))then            
+                       pdqsdif(ig,iice) = -pqsurf(ig,iice)/ptimestep ! removes all the ice!
+                       pdqsdif(ig,ivap) = dqsdif_total(ig)/ptimestep
+     &                       - pdqsdif(ig,iice) ! take the remainder from the liquid instead
+                       pdqsdif(ig,ivap) = max(-pqsurf(ig,ivap)/ptimestep
+     &                       ,pdqsdif(ig,ivap))
+                    endif
+
+                 endif          ! if (rnat.ne.1)
+
+!     If water vapour is condensing, we must decide whether it forms ice or liquid.
+                 if(dqsdif_total(ig).gt.0)then ! a bug was here!
+                    if(ztsrf2(ig).gt.T_h2O_ice_liq)then
+                       pdqsdif(ig,iice)=0.0
+                       pdqsdif(ig,ivap)=dqsdif_total(ig)/ptimestep
+                    else
+                       pdqsdif(ig,iice)=dqsdif_total(ig)/ptimestep
+                       pdqsdif(ig,ivap)=0.0
+                    endif
+                 endif
+
+              end do            ! of DO ig=1,ngrid
+           endif                ! if (water et iq=ivap)
+        end do                  ! of do iq=1,nq
+      endif                     ! traceur
+
+
+!-----------------------------------------------------------------------
+!     8. Final calculation of the vertical diffusion tendencies
+!     -----------------------------------------------------------------
+
+      do ilev = 1, nlay
+         do ig=1,ngrid
+            pdudif(ig,ilev)=(zu(ig,ilev)-
+     &           (pu(ig,ilev)+pdufi(ig,ilev)*ptimestep))/ptimestep
+            pdvdif(ig,ilev)=(zv(ig,ilev)-
+     &           (pv(ig,ilev)+pdvfi(ig,ilev)*ptimestep))/ptimestep
+            hh = ph(ig,ilev)+pdhfi(ig,ilev)*ptimestep 
+
+            pdhdif(ig,ilev)=( zh(ig,ilev)- hh )/ptimestep
+         enddo
+      enddo
+
+      DO ig=1,ngrid  ! computing sensible heat flux (atm => surface)
+	 sensibFlux(ig)=cpp*zb(ig,1)/ptimestep*(zh(ig,1)-ztsrf2(ig))
+      ENDDO      
+
+      if (tracer) then
+         do iq = 1, nq
+            do ilev = 1, nlay
+               do ig=1,ngrid
+                  pdqdif(ig,ilev,iq)=(zq(ig,ilev,iq)-
+     &           (pq(ig,ilev,iq)+pdqfi(ig,ilev,iq)*ptimestep))/
+     &           ptimestep
+               enddo
+            enddo
+         enddo
+
+         if(water.and.forceWC)then ! force water conservation in model
+                                   ! we calculate the difference and add it to the ground
+                                   ! this is ugly and should be improved in the future
+            do ig=1,ngrid
+               Wtot=0.0
+               do ilay=1,nlay
+                  masse = (pplev(ig,ilay) - pplev(ig,ilay+1))/g
+!                  Wtot=Wtot+masse*(zq(ig,ilay,iice)-
+!     &                 (pq(ig,ilay,iice)+pdqfi(ig,ilay,iice)*ptimestep))
+                  Wtot=Wtot+masse*(zq(ig,ilay,ivap)-
+     &                 (pq(ig,ilay,ivap)+pdqfi(ig,ilay,ivap)*ptimestep))
+               enddo
+               Wdiff=Wtot/ptimestep+pdqsdif(ig,ivap)+pdqsdif(ig,iice)
+
+               if(ztsrf2(ig).gt.T_h2O_ice_liq)then
+                  pdqsdif(ig,ivap)=pdqsdif(ig,ivap)-Wdiff
+               else
+                  pdqsdif(ig,iice)=pdqsdif(ig,iice)-Wdiff
+               endif
+            enddo
+
+         endif
+
+      endif 
+
+      if(water)then
+      call writediagfi(ngrid,'beta','Dryness coefficient',' ',2,dryness)
+      endif
+
+!      if(lastcall)then
+!        if(ngrid.eq.1)then
+!           print*,'Saving k.out...'
+!           OPEN(12,file='k.out',form='formatted')
+!           DO ilay=1,nlay
+!              write(12,*) zkh(1,ilay), pplay(1,ilay)
+!           ENDDO
+!           CLOSE(12)
+!         endif
+!      endif
+
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vlz_fi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vlz_fi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/vlz_fi.F	(revision 222)
@@ -0,0 +1,195 @@
+      SUBROUTINE vlz_fi(ngrid,q,pente_max,masse,w,wq)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " dans la verticale
+c    pour appel dans la physique (sedimentation)
+c    ********************************************************************
+c    q rapport de melange (kg/kg)...
+c    masse : masse de la couche Dp/g
+c    w : masse d'atm ``transferee'' a chaque pas de temps (kg.m-2)
+c    pente_max = 2 conseillee
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "dimphys.h"
+
+c
+c
+c   Arguments:
+c   ----------
+      integer ngrid
+      real masse(ngrid,llm),pente_max
+      REAL q(ngrid,llm)
+      REAL w(ngrid,llm)
+      REAL wq(ngrid,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+
+      real dzq(ngrid,llm),dzqw(ngrid,llm),adzqw(ngrid,llm),dzqmax
+      real newmasse
+      real sigw, Mtot, MQtot
+      integer m
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+
+
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+      do l=2,llm
+         do ij=1,ngrid
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm-1
+         do ij=1,ngrid
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            if(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) then
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            else
+                dzq(ij,l)=0.
+            endif
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         enddo
+      enddo
+
+      do ij=1,ngrid
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      enddo
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+c
+c      No flux at the model top:
+       do ij=1,ngrid
+          wq(ij,llm+1)=0.
+       enddo
+
+c      1) Compute wq where w > 0 (down) (ALWAYS FOR SEDIMENTATION)     
+c      ===============================
+
+       do l = 1,llm          ! loop different than when w<0
+        do ij=1,ngrid
+
+         if(w(ij,l).gt.0.)then
+
+c         Regular scheme (transfered mass < 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(w(ij,l).le.masse(ij,l))then
+            sigw=w(ij,l)/masse(ij,l)
+            wq(ij,l)=w(ij,l)*(q(ij,l)+0.5*(1.-sigw)*dzq(ij,l))
+            
+
+c         Extended scheme (transfered mass > 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          else 
+            m=l
+            Mtot = masse(ij,m)
+            MQtot = masse(ij,m)*q(ij,m)
+            if(m.ge.llm)goto 88
+            do while(w(ij,l).gt.(Mtot+masse(ij,m+1)))
+                m=m+1
+                Mtot = Mtot + masse(ij,m)
+                MQtot = MQtot + masse(ij,m)*q(ij,m)
+                if(m.ge.llm)goto 88
+            end do
+ 88         continue
+            if (m.lt.llm) then
+                sigw=(w(ij,l)-Mtot)/masse(ij,m+1)
+                wq(ij,l)=(MQtot + (w(ij,l)-Mtot)*
+     &          (q(ij,m+1)+0.5*(1.-sigw)*dzq(ij,m+1)) )
+            else
+                w(ij,l) = Mtot
+                wq(ij,l) = Mqtot 
+            end if
+          end if
+         end if
+        enddo
+       enddo
+
+c      2) Compute wq where w < 0 (up) (NOT USEFUL FOR SEDIMENTATION)     
+c      ===============================
+       goto 99 ! SKIPPING THIS PART FOR SEDIMENTATION 
+
+c      Surface flux up:
+       do ij=1,ngrid
+         if(w(ij,1).lt.0.) wq(ij,1)=0. ! warning : not always valid
+       end do
+
+       do l = 1,llm-1  ! loop different than when w>0
+        do ij=1,ngrid
+         if(w(ij,l+1).le.0)then
+
+c         Regular scheme (transfered mass < 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(-w(ij,l+1).le.masse(ij,l))then
+            sigw=w(ij,l+1)/masse(ij,l)
+            wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+c         Extended scheme (transfered mass > 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          else 
+             m = l-1
+             Mtot = masse(ij,m+1)
+             MQtot = masse(ij,m+1)*q(ij,m+1)
+             if (m.le.0)goto 77
+             do while(-w(ij,l+1).gt.(Mtot+masse(ij,m)))
+                m=m-1
+                Mtot = Mtot + masse(ij,m+1)
+                MQtot = MQtot + masse(ij,m+1)*q(ij,m+1)
+                if (m.le.0)goto 77
+             end do
+ 77          continue
+
+             if (m.gt.0) then
+                sigw=(w(ij,l+1)+Mtot)/masse(ij,m)
+                wq(ij,l+1)= (MQtot + (-w(ij,l+1)-Mtot)*
+     &          (q(ij,m)-0.5*(1.+sigw)*dzq(ij,m))  )
+             else
+c               wq(ij,l+1)= (MQtot + (-w(ij,l+1)-Mtot)*qm(ij,1))
+                write(*,*) 'a rather weird situation in vlz_fi !'
+                stop
+             end if
+          endif
+         endif
+        enddo
+       enddo
+ 99    continue
+
+      do l=1,llm
+         do ij=1,ngrid
+
+cccccccc lines below not used for sedimentation (No real flux)
+ccccc       newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) 
+ccccc       q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+ccccc&         /newmasse
+ccccc       masse(ij,l)=newmasse
+
+            q(ij,l)=q(ij,l) +  (wq(ij,l+1)-wq(ij,l))/masse(ij,l)
+
+         enddo
+      enddo
+
+
+
+      return
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watercommon_h.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watercommon_h.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watercommon_h.F90	(revision 222)
@@ -0,0 +1,288 @@
+module watercommon_h
+
+      implicit none
+
+      real, parameter :: T_coup = 234.0
+      real, parameter :: T_h2O_ice_liq = 273.16
+      real, parameter :: T_h2O_ice_clouds = T_h2O_ice_liq-15. 
+      real, parameter :: mH2O = 18.01528   
+
+      ! benjamin additions
+      real, parameter :: RLVTT = 2.257E+6 ! Latent heat of vaporization (J kg-1) 
+      real, parameter :: RLSTT = 2.257E+6 ! 2.591E+6 in reality ! Latent heat of sublimation (J kg-1)
+
+      real, parameter :: RLFTT = 3.334E+5 ! Latent heat of fusion (J kg-1) ! entails an energy sink but better description of albedo
+      real, parameter :: rhowater = 1.0E+3 ! mass of water (kg/m^3)
+      real, parameter :: rhowaterice = 9.2E+2 ! mass of water (kg/m^3)
+      real, parameter :: capcal_h2o_liq = 4181.3 ! specific heat capacity of liquid water J/kg/K
+      real, parameter :: mx_eau_sol = 150 ! mass of water (kg/m^2)
+
+      real, save :: epsi, RCPD, RCPV, RV, RVTMP2
+      
+      contains
+
+      
+!==================================================================
+      subroutine Psat_water(T,p,psat,qsat)
+
+         implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the saturation vapor pressure and mass mixing ratio at saturation (kg/kg)
+!     for a given pressure (Pa) and temperature (K)
+!     Based on the Tetens formula from L.Li physical parametrization manual
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+
+!        input
+         real, intent(in) :: T, p
+  
+!        output
+         real psat,qsat
+
+! JL12 variables for tetens formula
+         real,parameter :: Pref_solid_liquid=611.14
+         real,parameter :: Trefvaporization=35.86
+         real,parameter :: Trefsublimation=7.66
+         real,parameter :: Tmin=8.
+         real,parameter :: r3vaporization=17.269
+         real,parameter :: r3sublimation=21.875
+
+! checked vs. old watersat data 14/05/2012 by JL.
+
+         if (T.gt.T_h2O_ice_liq) then 
+            psat = Pref_solid_liquid*Exp(r3vaporization*(T-T_h2O_ice_liq)/(T-Trefvaporization)) ! liquid / vapour
+         else if (T.lt.Tmin) then
+	    print*, "careful, T<Tmin in psat water"
+          !  psat = Pref_solid_liquid*Exp(r3sublimation*(Tmin-T_h2O_ice_liq)/(Tmin-Trefsublimation)) ! min psat  
+         ! Ehouarn: gfortran says: Error: Result of EXP underflows its kind,
+         !          so set psat to the smallest possible value instead
+            psat=tiny(psat)
+         else                 
+            psat = Pref_solid_liquid*Exp(r3sublimation*(T-T_h2O_ice_liq)/(T-Trefsublimation)) ! solid / vapour
+         endif
+         if(psat.gt.p) then
+            qsat=1.
+         else
+            qsat=epsi*psat/(p-(1.-epsi)*psat)
+         endif
+         return
+      end subroutine Psat_water
+
+
+
+
+!==================================================================
+      subroutine Lcpdqsat_water(T,p,psat,qsat,dqsat,dlnpsat)
+
+         implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute dqsat=L/cp*d (q_sat)/d T and dlnpsat=L/cp d(ln Psat)/d T
+!     for a given temperature (K)! 
+!     Based on the Tetens formula from L.Li physical parametrization manual
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+
+!        input
+         real T, p, psat, qsat
+  
+!        output
+         real dqsat,dlnpsat
+
+! JL12 variables for tetens formula
+         real,parameter :: Pref_solid_liquid=611.14
+         real,parameter :: Trefvaporization=35.86
+         real,parameter :: Tmin=8.
+         real,parameter :: Trefsublimation=7.66
+         real,parameter :: r3vaporization=17.269
+         real,parameter :: r3sublimation=21.875
+
+         real :: dummy
+
+         if (psat.gt.p) then
+	    dqsat=0.
+	    return
+	 endif
+
+         if (T.gt.T_h2O_ice_liq) then
+            dummy = r3vaporization*(T_h2O_ice_liq-Trefvaporization)/(T-Trefvaporization)**2  ! liquid / vapour
+         else if (T.lt.Tmin) then
+	    print*, "careful, T<Tmin in Lcp psat water"
+            dummy = r3sublimation*(T_h2O_ice_liq-Trefsublimation)/(Tmin-Trefsublimation)**2  ! solid / vapour
+         else               
+            dummy = r3sublimation*(T_h2O_ice_liq-Trefsublimation)/(T-Trefsublimation)**2  ! solid / vapour
+         endif
+
+         dqsat=RLVTT/RCPD*qsat*(p/(p-(1.-epsi)*psat))*dummy
+	 dlnpsat=RLVTT/RCPD*dummy
+         return
+      end subroutine Lcpdqsat_water
+
+
+
+
+!==================================================================
+      subroutine Tsat_water(p,Tsat)
+
+         implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the saturation temperature
+!     for a given pressure (Pa) 
+!     Based on the Tetens formula from L.Li physical parametrization manual
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+
+!        input
+         real p
+  
+!        output
+         real Tsat
+
+! JL12 variables for tetens formula
+         real,parameter :: Pref_solid_liquid=611.14
+         real,parameter :: Trefvaporization=35.86
+         real,parameter :: Trefsublimation=7.66
+         real,parameter :: r3vaporization=17.269
+         real,parameter :: r3sublimation=21.875
+
+         if (p.lt.Pref_solid_liquid) then ! solid / vapour
+            Tsat =(T_h2O_ice_liq*r3sublimation- Trefsublimation*Log(p/Pref_solid_liquid))/(r3sublimation-Log(p/Pref_solid_liquid))
+         else                 ! liquid / vapour
+            Tsat =(T_h2O_ice_liq*r3vaporization- Trefvaporization*Log(p/Pref_solid_liquid))/(r3vaporization-Log(p/Pref_solid_liquid))
+         endif
+
+         return
+      end subroutine Tsat_water
+
+!==================================================================
+      subroutine Psat_waterDP(T,p,psat,qsat)
+
+         implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the saturation vapor pressure and mass mixing ratio at saturation (kg/kg)
+!     for a given pressure (Pa) and temperature (K)
+!     DOUBLE PRECISION
+!     Based on the Tetens formula from L.Li physical parametrization manual
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+
+!        input
+         double precision, intent(in) :: T, p
+  
+!        output
+         double precision psat,qsat
+
+! JL12 variables for tetens formula
+         double precision,parameter :: Pref_solid_liquid=611.14d0
+         double precision,parameter :: Trefvaporization=35.86D0
+         double precision,parameter :: Trefsublimation=7.66d0
+         double precision,parameter :: Tmin=8.d0
+         double precision,parameter :: r3vaporization=17.269d0
+         double precision,parameter :: r3sublimation=21.875d0
+
+! checked vs. old watersat data 14/05/2012 by JL.
+
+         if (T.gt.T_h2O_ice_liq) then 
+            psat = Pref_solid_liquid*Exp(r3vaporization*(T-T_h2O_ice_liq)/(T-Trefvaporization)) ! liquid / vapour
+         else if (T.lt.Tmin) then
+	    print*, "careful, T<Tmin in psat water"
+         !   psat = Pref_solid_liquid*Exp(r3sublimation*(Tmin-T_h2O_ice_liq)/(Tmin-Trefsublimation)) ! min psat  
+         ! Ehouarn: gfortran says: Error: Result of EXP underflows its kind,
+         !          so set psat to the smallest possible value instead
+            psat=tiny(psat)
+         else                 
+            psat = Pref_solid_liquid*Exp(r3sublimation*(T-T_h2O_ice_liq)/(T-Trefsublimation)) ! solid / vapour
+         endif
+         if(psat.gt.p) then
+            qsat=1.d0
+         else
+            qsat=epsi*psat/(p-(1.d0-epsi)*psat)
+         endif
+         return
+      end subroutine Psat_waterDP
+
+
+
+
+!==================================================================
+      subroutine Lcpdqsat_waterDP(T,p,psat,qsat,dqsat,dlnpsat)
+
+         implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute dqsat=L/cp*d (q_sat)/d T and dlnpsat=L/cp d(ln Psat)/d T
+!     for a given temperature (K)! 
+!     Based on the Tetens formula from L.Li physical parametrization manual
+!
+!     Authors
+!     -------
+!     Jeremy Leconte (2012)
+!
+!==================================================================
+
+!        input
+         double precision T, p, psat, qsat
+  
+!        output
+         double precision dqsat,dlnpsat
+
+! JL12 variables for tetens formula
+         double precision,parameter :: Pref_solid_liquid=611.14d0
+         double precision,parameter :: Trefvaporization=35.86d0
+         double precision,parameter :: Tmin=8.d0
+         double precision,parameter :: Trefsublimation=7.66d0
+         double precision,parameter :: r3vaporization=17.269d0
+         double precision,parameter :: r3sublimation=21.875d0
+
+         double precision :: dummy
+
+         if (psat.gt.p) then
+	    dqsat=0.d0
+	    return
+	 endif
+
+         if (T.gt.T_h2O_ice_liq) then
+            dummy = r3vaporization*(T_h2O_ice_liq-Trefvaporization)/(T-Trefvaporization)**2  ! liquid / vapour
+         else if (T.lt.Tmin) then
+	    print*, "careful, T<Tmin in Lcp psat water"
+            dummy = r3sublimation*(T_h2O_ice_liq-Trefsublimation)/(Tmin-Trefsublimation)**2  ! solid / vapour
+         else               
+            dummy = r3sublimation*(T_h2O_ice_liq-Trefsublimation)/(T-Trefsublimation)**2  ! solid / vapour
+         endif
+
+         dqsat=RLVTT/RCPD*qsat*(p/(p-(1.d0-epsi)*psat))*dummy
+	 dlnpsat=RLVTT/RCPD*dummy
+         return
+      end subroutine Lcpdqsat_waterDP
+
+
+end module watercommon_h
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watersat.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watersat.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watersat.F90	(revision 222)
@@ -0,0 +1,45 @@
+subroutine watersat(T,p,qsat)
+
+  use watercommon_h, only: T_h2O_ice_liq, epsi
+  implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the water mass mixing ratio at saturation (kg/kg)
+!     for a given pressure (Pa) and temperature (K)
+!     A replacement for the old watersat.F in the Martian GCM.
+!     Based on FCTTRE.h in the LMDTERRE model.
+!
+!     Authors
+!     -------
+!     Robin Wordsworth (2010)
+!
+!==================================================================
+
+!   input
+  real T, p
+  
+!   output
+  real qsat
+
+! checked vs. NIST data 22/06/2010 by RW.
+! / by p gives partial pressure
+! x by epsi converts to mass mixing ratio
+
+  if (T.lt.T_h2O_ice_liq) then ! solid / vapour
+     qsat = 100.0 * 10**(2.07023 - 0.00320991             &
+          * T - 2484.896 / T + 3.56654 * alog10(T))
+  else                 ! liquid / vapour
+     qsat = 100.0 * 10**(23.8319 - 2948.964 / T - 5.028  &
+          * alog10(T) - 29810.16 * exp( -0.0699382 * T)  &
+          + 25.21935 * exp(-2999.924/T))
+  endif
+!  qsat=epsi*qsat/p
+  if(qsat.gt.p) then
+     qsat=1.
+  else
+     qsat=epsi*qsat/(p-(1.-epsi)*qsat)
+  endif
+  return
+end subroutine watersat
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watersat_grad.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watersat_grad.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/watersat_grad.F90	(revision 222)
@@ -0,0 +1,38 @@
+subroutine watersat_grad(T,qsat,dqsat)
+
+  use watercommon_h, only: T_h2O_ice_liq, RLVTT, RCPD,T_coup
+  implicit none
+
+!==================================================================
+!     Purpose
+!     -------
+!     Compute the L/cp*d (q_sat)/d T
+!     for a given temperature (K)
+!
+!     Authors
+!     -------
+!     Robin Wordsworth (2010)
+!
+!==================================================================
+
+!   input
+  real T,qsat
+  
+!   output
+  real dqsat
+
+!  if (T.lt.T_coup) then ! solid / vapour !why use T_coup?????????? JL12
+  if (T.lt.T_h2O_ice_liq) then ! solid / vapour
+     dqsat = RLVTT/RCPD*qsat*(3.56654/T             &
+          +2484.896*LOG(10.)/T**2                   &
+          -0.00320991*LOG(10.))
+  else                 ! liquid / vapour
+     dqsat = RLVTT/RCPD*qsat*LOG(10.)*              &
+          (2948.964/T**2-5.028/LOG(10.)/T           &
+          +25.21935*2999.924/T**2*EXP(-2999.924/T)  &
+          +29810.16*0.0699382*EXP(-0.0699382*T))
+  end if
+
+  return
+end subroutine watersat_grad
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/write_archive.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/write_archive.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/write_archive.F	(revision 222)
@@ -0,0 +1,250 @@
+c=======================================================================
+      subroutine write_archive(nid,ntime,nom,titre,unite,dim,px)
+c=======================================================================
+c
+c
+c   Date:    01/1997
+c   ----
+c
+c   Objet:   Ecriture de champs sur grille scalaire (iip1*jjp1)
+c   -----    dans un fichier DRS nomme "start_archive"
+c
+c    Il faut au prealable avoir cree un entete avec un "call ini_archive".
+c    Ces variables peuvent etre 3d (ex: temperature), 2d (ex: temperature
+c    de surface), ou 0d (pour un scalaire qui ne depend que du temps)
+c    (ex: la longitude solaire)
+c
+c
+c   Arguments: 
+c   ----------
+c
+c     Inputs:
+c     ------
+c
+c		  nid      Unite logique du fichier "start_archive"
+c         nom      nom du champ a ecrire dans le fichier "start_archive"
+c         titre    titre de la variable dans le fichier DRS "start_archive"
+c         unite    unite de la variable ....
+c         dim      dimension de la variable a ecrire
+c         px       tableau contenant la variable a ecrire
+c
+c
+c=======================================================================
+
+      use comsoil_h, only: nsoilmx
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "netcdf.inc"
+
+c-----------------------------------------------------------------------
+c	Declarations   
+c-----------------------------------------------------------------------
+
+c Arguments:
+
+      INTEGER nid
+      integer ntime ! time index
+      integer dim 
+      REAL px(iip1,jjp1,llm) 
+
+      CHARACTER*(*) nom, titre, unite
+
+      integer ierr
+
+
+c local
+      integer, dimension(4) :: edges,corner,id
+      integer :: varid,i,j,l
+c-----------------------------------------------------------------------
+c      Ecriture du champs dans le fichier            (3 cas)      
+c-----------------------------------------------------------------------
+
+! For an atmospheric 3D Variable
+!--------------------------------
+        if (dim.eq.3) then
+
+!         Ecriture du champs
+
+! nom de la variable
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! choix du nom des coordonnees
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+              ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+! Creation de la variable si elle n'existait pas
+
+              write (*,*) "====================="
+              write (*,*) "creation de ",nom
+              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+
+           endif
+
+! mars s'arranger pour qu'il n'y ai plus besoin de ca
+
+c          do l=1,llm
+c             do j=1,jjp1
+c                do i=1,iip1
+c                   pxbis(i,j,l)=px(i,j,llm-l+1)
+c                enddo
+c             enddo
+c          enddo
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=llm
+           edges(4)=1
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in write_archive"
+              write(*,*) "***** with ",nom," ",nf_STRERROR(ierr)
+              call abort
+           endif
+
+
+! For a subterranean 3D Variable
+!-------------------------------
+
+        else if (dim.eq.-3) then
+	! get variables' ID, if it exists
+	ierr=NF_INQ_VARID(nid,nom,varid)
+	
+	 if (ierr.ne.NF_NOERR) then ! variable not defined yet
+	  ! build related coordinates
+	  ierr=NF_INQ_DIMID(nid,"longitude",id(1))
+	  ierr=NF_INQ_DIMID(nid,"latitude",id(2))
+	  ierr=NF_INQ_DIMID(nid,"subsurface_layers",id(3))
+	  if (ierr.ne.NF_NOERR) then
+	   write(*,*)"write_archive: dimension <subsurface_layers>",
+     &               " is missing !!!"
+	   call abort
+	  endif
+          ierr=NF_INQ_DIMID(nid,"Time",id(4))
+	  
+	  ! define the variable
+	  write(*,*)"====================="
+	  write(*,*)"defining ",nom
+	  call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+	  
+	 endif
+
+        ! build cedges and corners
+        corner(1)=1
+        corner(2)=1
+        corner(3)=1
+        corner(4)=ntime
+
+        edges(1)=iip1
+        edges(2)=jjp1
+        edges(3)=nsoilmx
+        edges(4)=1
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif
+
+
+! For a surface 2D Variable
+!--------------------------
+
+        else if (dim.eq.2) then
+
+!         Ecriture du champs
+
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+!  choix du nom des coordonnees
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"Time",id(3))
+
+! Creation de la variable si elle n'existait pas
+
+              write (*,*) "====================="
+              write (*,*) "creation de ",nom
+
+              call def_var(nid,nom,titre,unite,3,id,varid,ierr)
+
+           endif
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=ntime
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=1
+
+
+#ifdef NC_DOUBLE
+           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
+#else         
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif     
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in write_archive"
+              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
+              call abort
+           endif
+
+
+!Cas Variable 0D (scalaire dependant du temps)
+!---------------------------------------------
+
+        else if (dim.eq.0) then
+
+!         Ecriture du champs
+
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+!  choix du nom des coordonnees
+              ierr= NF_INQ_DIMID(nid,"Time",id(1))
+
+! Creation de la variable si elle n'existait pas
+
+              write (*,*) "====================="
+              write (*,*) "creation de ",nom
+
+              call def_var(nid,nom,titre,unite,1,id,varid,ierr)
+
+           endif
+
+           corner(1)=ntime
+           edges(1)=1
+
+#ifdef NC_DOUBLE
+           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in write_archive"
+              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
+              call abort
+           endif
+
+        else
+	  write(*,*) "write_archive: dim=",dim," ?!?"
+	  call abort
+        endif ! of if (dim.eq.3) else if (dim.eq.-3) ....
+
+      return
+      end
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagfi.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagfi.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagfi.F	(revision 222)
@@ -0,0 +1,541 @@
+      subroutine writediagfi(ngrid,nom,titre,unite,dim,px)
+
+!  Ecriture de variables diagnostiques au choix dans la physique 
+!  dans un fichier NetCDF nomme  'diagfi'. Ces variables peuvent etre
+!  3d (ex : temperature), 2d (ex : temperature de surface), ou
+!  0d (pour un scalaire qui ne depend que du temps : ex : la longitude
+!  solaire)
+!  (ou encore 1d, dans le cas de testphys1d, pour sortir une colonne)
+!  La periode d'ecriture est donnee par 
+!  "ecritphy " regle dans le fichier de controle de run :  run.def
+!
+!    writediagfi peut etre appele de n'importe quelle subroutine
+!    de la physique, plusieurs fois. L'initialisation et la creation du
+!    fichier se fait au tout premier appel.
+!
+! WARNING : les variables dynamique (u,v,t,q,ps)
+!  sauvees par writediagfi avec une
+! date donnee sont legerement differentes que dans le fichier histoire car 
+! on ne leur a pas encore ajoute de la dissipation et de la physique !!!
+! IL est  RECOMMANDE d'ajouter les tendance physique a ces variables
+! avant l'ecriture dans diagfi (cf. physiq.F)
+!  
+! Modifs: Aug.2010 Ehouarn: enforce outputs to be real*4
+!         Oct 2011 Francois: enable having a 'diagfi.def' file to select
+!                            at runtime, which variables to put in file
+!
+!  parametres (input) :
+!  ----------
+!      ngrid : nombres de point ou est calcule la physique
+!                (ngrid = 2+(jjm-1)*iim - 1/jjm)
+!                 (= nlon ou klon dans la physique terrestre)
+!      
+!      unit : unite logique du fichier de sortie (toujours la meme)
+!      nom  : nom de la variable a sortir (chaine de caracteres)
+!      titre: titre de la variable (chaine de caracteres)
+!      unite : unite de la variable (chaine de caracteres)
+!      px : variable a sortir (real 0, 1, 2, ou 3d)
+!      dim : dimension de px : 0, 1, 2, ou 3 dimensions
+!
+!=================================================================
+      use surfdat_h, only: phisfi
+      use control_mod, only: ecritphy, day_step, iphysiq
+      USE mod_phys_lmdz_para, only : is_parallel, is_mpi_root,
+     &                               is_master, gather
+      USE mod_grid_phy_lmdz, only : klon_glo, Grid1Dto2D_glo
+      implicit none
+
+! Commons
+      include "dimensions.h"
+      include "paramet.h"
+      include "comvert.h"
+      include "comgeom.h"
+      include "netcdf.inc"
+      include "temps.h"
+
+! Arguments on input:
+      integer,intent(in) :: ngrid
+      character (len=*),intent(in) :: nom,titre,unite
+      integer,intent(in) :: dim
+      real,intent(in) :: px(ngrid,llm)
+
+! Local variables:
+
+      real*4 dx3(iip1,jjp1,llm) ! to store a 3D data set
+      real*4 dx2(iip1,jjp1)     ! to store a 2D (surface) data set
+      real*4 dx1(llm)           ! to store a 1D (column) data set
+      real*4 dx0
+
+      real*4,save :: date
+
+      REAL phis(ip1jmp1)
+
+      integer irythme
+      integer ierr,ierr2
+      integer iq
+      integer i,j,l,zmax , ig0
+
+      integer,save :: zitau=0
+      character(len=20),save :: firstnom='1234567890'
+
+! Ajouts
+      integer, save :: ntime=0
+      integer :: idim,varid
+      integer :: nid
+      character(len=*),parameter :: fichnom="diagfi.nc"
+      integer, dimension(4) :: id
+      integer, dimension(4) :: edges,corner
+
+! Added to use diagfi.def to select output variable
+      logical,save :: diagfi_def
+      logical :: getout
+      integer,save :: n_nom_def
+      integer :: n
+      integer,parameter :: n_nom_def_max=199
+      character(len=120),save :: nom_def(n_nom_def_max)
+      logical,save :: firstcall=.true.
+      
+#ifndef MESOSCALE
+
+#ifdef CPP_PARA
+! Added to work in parallel mode
+      real dx3_glop(klon_glo,llm)
+      real dx3_glo(iim,jjp1,llm) ! to store a global 3D data set
+      real dx2_glop(klon_glo)
+      real dx2_glo(iim,jjp1)     ! to store a global 2D (surface) data set
+      real px2(ngrid)
+!      real dx1_glo(llm)          ! to store a 1D (column) data set
+!      real dx0_glo
+      real phisfi_glo(klon_glo) ! surface geopotential on global physics grid
+#else
+      real phisfi_glo(ngrid) ! surface geopotential on global physics grid
+#endif
+
+!***************************************************************
+!Sortie des variables au rythme voulu
+
+      irythme = ecritphy ! sortie au rythme de ecritphy
+!     irythme = iconser  ! sortie au rythme des variables de controle
+!     irythme = iphysiq  ! sortie a tous les pas physique
+!     irythme = iecri*day_step ! sortie au rythme des fichiers histoires
+!     irythme = periodav*day_step ! sortie au rythme des fichiers histmoy
+
+!***************************************************************
+
+! At very first call, check if there is a "diagfi.def" to use and read it
+! -----------------------------------------------------------------------
+      IF (firstcall) THEN
+         firstcall=.false.
+
+  !      Open diagfi.def definition file if there is one:
+         open(99,file="diagfi.def",status='old',form='formatted',
+     s   iostat=ierr2)
+
+         if(ierr2.eq.0) then
+            diagfi_def=.true.
+            write(*,*) "******************"
+            write(*,*) "Reading diagfi.def"
+            write(*,*) "******************"
+            do n=1,n_nom_def_max
+              read(99,fmt='(a)',end=88) nom_def(n)
+              write(*,*) 'Output in diagfi: ', trim(nom_def(n))
+            end do 
+ 88         continue
+            if (n.ge.n_nom_def_max) then
+               write(*,*)"n_nom_def_max too small in writediagfi.F:",n
+               stop
+            end if 
+            n_nom_def=n-1
+            close(99)
+         else
+            diagfi_def=.false.
+         endif
+      END IF ! of IF (firstcall)
+
+! Get out of write_diagfi if there is diagfi.def AND variable not listed
+!  ---------------------------------------------------------------------
+      if (diagfi_def) then
+          getout=.true.
+          do n=1,n_nom_def
+             if(trim(nom_def(n)).eq.nom) getout=.false.
+          end do
+          if (getout) return
+      end if
+
+! Initialisation of 'firstnom' and create/open the "diagfi.nc" NetCDF file
+! ------------------------------------------------------------------------
+! (at very first call to the subroutine, in accordance with diagfi.def)
+
+      if (firstnom.eq.'1234567890') then ! .true. for the very first valid
+      !   call to this subroutine; now set 'firstnom'
+         firstnom = nom
+         ! just to be sure, check that firstnom is large enough to hold nom
+         if (len_trim(firstnom).lt.len_trim(nom)) then
+           write(*,*) "writediagfi: Error !!!"
+           write(*,*) "   firstnom string not long enough!!"
+           write(*,*) "   increase its size to at least ",len_trim(nom)
+           stop
+         endif
+         
+         zitau = -1 ! initialize zitau
+
+#ifdef CPP_PARA
+          ! Gather phisfi() geopotential on physics grid
+          call Gather(phisfi,phisfi_glo)
+#else
+         phisfi_glo(:)=phisfi(:)
+#endif
+
+         !! parallel: we cannot use the usual writediagfi method
+!!         call iophys_ini
+         if (is_master) then
+         ! only the master is required to do this
+
+         ! Create the NetCDF file
+         ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+         ! Define the 'Time' dimension
+         ierr = nf_def_dim(nid,"Time",NF_UNLIMITED,idim)
+         ! Define the 'Time' variable
+!#ifdef NC_DOUBLE
+!         ierr = NF_DEF_VAR (nid, "Time", NF_DOUBLE, 1, idim,varid)
+!#else
+         ierr = NF_DEF_VAR (nid, "Time", NF_FLOAT, 1, idim,varid)
+!#endif
+         ! Add a long_name attribute
+         ierr = NF_PUT_ATT_TEXT (nid, varid, "long_name",
+     .          4,"Time")
+         ! Add a units attribute
+         ierr = NF_PUT_ATT_TEXT(nid, varid,'units',29,
+     .          "days since 0000-00-0 00:00:00")
+         ! Switch out of NetCDF Define mode
+         ierr = NF_ENDDEF(nid)
+
+         ! write "header" of file (longitudes, latitudes, geopotential, ...)
+         call gr_fi_dyn(1,size(phisfi_glo),iip1,jjp1,phisfi_glo,phis)
+         call iniwrite(nid,day_ini,phis)
+
+         endif ! of if (is_master)
+
+      else
+
+         if (is_master) then
+           ! only the master is required to do this
+
+           ! Open the NetCDF file
+           ierr = NF_OPEN(fichnom,NF_WRITE,nid)
+         endif ! of if (is_master)
+
+      endif ! if (firstnom.eq.'1234567890')
+
+      if (ngrid.eq.1) then
+        ! in testphys1d, for the 1d version of the GCM, iphysiq and irythme
+        ! are undefined; so set them to 1
+        iphysiq=1 
+        irythme=1
+        ! NB: 
+      endif
+
+! Increment time index 'zitau' if it is the "fist call" (at given time level)
+! to writediagfi
+!------------------------------------------------------------------------
+      if (nom.eq.firstnom) then
+          zitau = zitau + iphysiq
+      end if
+
+!--------------------------------------------------------
+! Write the variables to output file if it's time to do so
+!--------------------------------------------------------
+
+      if ( MOD(zitau+1,irythme) .eq.0.) then
+
+! Compute/write/extend 'Time' coordinate (date given in days)
+! (done every "first call" (at given time level) to writediagfi)
+! Note: date is incremented as 1 step ahead of physics time
+!--------------------------------------------------------
+
+        if (is_master) then
+           ! only the master is required to do this
+        if (nom.eq.firstnom) then
+        ! We have identified a "first call" (at given date)
+           ntime=ntime+1 ! increment # of stored time steps
+           ! compute corresponding date (in days and fractions thereof)
+           date= float (zitau +1)/float (day_step)
+           ! Get NetCDF ID of 'Time' variable
+           ierr= NF_INQ_VARID(nid,"Time",varid)
+           ! Write (append) the new date to the 'Time' array
+!#ifdef NC_DOUBLE
+!           ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+!#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+!#endif
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi_nc"
+              write(*,*) "***** with time"
+              write(*,*) 'ierr=', ierr   
+c             call abort
+           endif
+
+           write(6,*)'WRITEDIAGFI: date= ', date
+        end if ! of if (nom.eq.firstnom)
+
+        endif ! of if (is_master)
+
+!Case of a 3D variable
+!---------------------
+        if (dim.eq.3) then
+
+#ifdef CPP_PARA
+          ! Gather field on a "global" (without redundant longitude) array
+          call Gather(px,dx3_glop)
+!$OMP MASTER
+          if (is_mpi_root) then
+            call Grid1Dto2D_glo(dx3_glop,dx3_glo)
+            ! copy dx3_glo() to dx3(:) and add redundant longitude
+            dx3(1:iim,:,:)=dx3_glo(1:iim,:,:)
+            dx3(iip1,:,:)=dx3(1,:,:)
+          endif
+!$OMP END MASTER
+!$OMP BARRIER
+#else
+!         Passage variable physique -->  variable dynamique
+!         recast (copy) variable from physics grid to dynamics grid
+           DO l=1,llm
+             DO i=1,iip1
+                dx3(i,1,l)=px(1,l)
+                dx3(i,jjp1,l)=px(ngrid,l)
+             ENDDO
+             DO j=2,jjm
+                ig0= 1+(j-2)*iim
+                DO i=1,iim
+                   dx3(i,j,l)=px(ig0+i,l)
+                ENDDO
+                dx3(iip1,j,l)=dx3(1,j,l)
+             ENDDO
+           ENDDO
+#endif
+!         Ecriture du champs
+
+          if (is_master) then
+           ! only the master writes to output
+! name of the variable
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+              ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+
+           endif 
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=llm
+           edges(4)=1
+!#ifdef NC_DOUBLE
+!           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,dx3)
+!#else
+!           write(*,*)"test:  nid=",nid," varid=",varid
+!           write(*,*)"       corner()=",corner
+!           write(*,*)"       edges()=",edges
+!           write(*,*)"       dx3()=",dx3
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx3)
+!#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR problem in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr,": ",NF_STRERROR(ierr)
+c             call abort
+           endif 
+
+          endif !of if (is_master)
+
+!Case of a 2D variable
+!---------------------
+
+        else if (dim.eq.2) then
+
+#ifdef CPP_PARA
+          ! Gather field on a "global" (without redundant longitude) array
+          px2(:)=px(:,1)
+          call Gather(px2,dx2_glop)
+!$OMP MASTER
+          if (is_mpi_root) then
+            call Grid1Dto2D_glo(dx2_glop,dx2_glo)
+            ! copy dx2_glo() to dx2(:) and add redundant longitude
+            dx2(1:iim,:)=dx2_glo(1:iim,:)
+            dx2(iip1,:)=dx2(1,:)
+          endif
+!$OMP END MASTER
+!$OMP BARRIER
+#else
+
+!         Passage variable physique -->  physique dynamique
+!         recast (copy) variable from physics grid to dynamics grid
+
+             DO i=1,iip1
+                dx2(i,1)=px(1,1)
+                dx2(i,jjp1)=px(ngrid,1)
+             ENDDO
+             DO j=2,jjm
+                ig0= 1+(j-2)*iim
+                DO i=1,iim
+                   dx2(i,j)=px(ig0+i,1)
+                ENDDO
+                dx2(iip1,j)=dx2(1,j)
+             ENDDO
+#endif
+
+          if (is_master) then
+           ! only the master writes to output
+!         write (*,*) 'In  writediagfi, on sauve:  ' , nom
+!         write (*,*) 'In  writediagfi. Estimated date = ' ,date
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"Time",id(3))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+
+              call def_var(nid,nom,titre,unite,3,id,varid,ierr)
+
+           endif
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=ntime
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=1
+
+
+!#ifdef NC_DOUBLE
+!           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,dx2) 
+!#else         
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx2)
+!#endif     
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr,": ",NF_STRERROR(ierr)
+c             call abort
+           endif 
+
+          endif !of if (is_master)
+
+!Case of a 1D variable (ie: a column)
+!---------------------------------------------------
+
+       else if (dim.eq.1) then
+         if (is_parallel) then
+           write(*,*) "writediagfi error: dim=1 not implemented ",
+     &                 "in parallel mode"
+           stop
+         endif
+!         Passage variable physique -->  physique dynamique
+!         recast (copy) variable from physics grid to dynamics grid
+          do l=1,llm
+            dx1(l)=px(1,l)
+          enddo
+          
+          ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"altitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"Time",id(2))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+
+              call def_var(nid,nom,titre,unite,2,id,varid,ierr)
+              
+           endif
+           
+           corner(1)=1
+           corner(2)=ntime
+           
+           edges(1)=llm
+           edges(2)=1
+!#ifdef NC_DOUBLE
+!           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,dx1)
+!#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx1)
+!#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR problem in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr,": ",NF_STRERROR(ierr)
+c             call abort
+           endif 
+
+!Case of a 0D variable (ie: a time-dependent scalar)
+!---------------------------------------------------
+
+        else if (dim.eq.0) then
+
+           dx0 = px (1,1)
+
+          if (is_master) then
+           ! only the master writes to output
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"Time",id(1))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+
+              call def_var(nid,nom,titre,unite,1,id,varid,ierr)
+
+           endif
+
+           corner(1)=ntime
+           edges(1)=1
+
+!#ifdef NC_DOUBLE
+!           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,dx0)  
+!#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx0)
+!#endif
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr,": ",NF_STRERROR(ierr)
+c             call abort
+           endif 
+
+          endif !of if (is_master)
+
+        endif ! of if (dim.eq.3) elseif(dim.eq.2)...
+
+      endif ! of if ( MOD(zitau+1,irythme) .eq.0.)
+
+      if (is_master) then
+        ierr= NF_CLOSE(nid)
+      endif
+
+#endif
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagsoil.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagsoil.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagsoil.F90	(revision 222)
@@ -0,0 +1,329 @@
+subroutine writediagsoil(ngrid,name,title,units,dimpx,px)
+
+! Write variable 'name' to NetCDF file 'diagsoil.nc'.
+! The variable may be 3D (lon,lat,depth) subterranean field,
+! a 2D (lon,lat) surface field, or a simple scalar (0D variable).
+!
+! Calls to 'writediagsoil' can originate from anywhere in the program;
+! An initialisation of variable 'name' is done if it is the first time
+! that this routine is called with given 'name'; otherwise data is appended
+! (yielding the sought time series of the variable)
+
+! Modifs: Aug.2010 Ehouarn: enforce outputs to be real*4
+
+use comsoil_h, only: nsoilmx
+use control_mod, only: ecritphy, day_step, iphysiq
+use mod_phys_lmdz_para, only : is_mpi_root, is_master, gather
+use mod_grid_phy_lmdz, only : klon_glo, Grid1Dto2D_glo
+
+implicit none
+
+#include"dimensions.h"
+#include"paramet.h"
+#include"netcdf.inc"
+
+! Arguments:
+integer,intent(in) :: ngrid ! number of (horizontal) points of physics grid
+! i.e. ngrid = 2+(jjm-1)*iim - 1/jjm
+character(len=*),intent(in) :: name ! 'name' of the variable
+character(len=*),intent(in) :: title ! 'long_name' attribute of the variable
+character(len=*),intent(in) :: units ! 'units' attribute of the variable
+integer,intent(in) :: dimpx ! dimension of the variable (3,2 or 0)
+real,dimension(ngrid,nsoilmx),intent(in) :: px ! variable
+! Note: nsoilmx is a parameter set in 'comsoil_h'
+
+! Local variables:
+real*4,dimension(iip1,jjp1,nsoilmx) :: data3 ! to store 3D data
+! Note iip1,jjp1 known from paramet.h; nsoilmx known from comsoil_h
+real*4,dimension(iip1,jjp1) :: data2 ! to store 2D data
+real*4 :: data0 ! to store 0D data
+integer :: i,j,l ! for loops
+integer :: ig0
+
+real*4,save :: date ! time counter (in elapsed days)
+integer,save :: isample ! sample rate at which data is to be written to output
+integer,save :: ntime=0 ! counter to internally store time steps
+character(len=20),save :: firstname="1234567890"
+integer,save :: zitau=0
+
+character(len=30) :: filename="diagsoil.nc"
+
+! NetCDF stuff:
+integer :: nid ! NetCDF output file ID
+integer :: varid ! NetCDF ID of a variable
+integer :: ierr ! NetCDF routines return code
+integer,dimension(4) :: id ! NetCDF IDs of the dimensions of the variable
+integer,dimension(4) :: edges,corners
+
+#ifdef CPP_PARA
+! Added to work in parallel mode
+real dx3_glop(klon_glo,nsoilmx)
+real dx3_glo(iim,jjp1,nsoilmx) ! to store a global 3D data set
+real dx2_glop(klon_glo)
+real dx2_glo(iim,jjp1)     ! to store a global 2D (surface) data set
+real px2(ngrid)
+#endif
+
+! 1. Initialization step
+if (firstname.eq."1234567890") then
+  ! Store 'name' as 'firstname'
+  firstname=name
+  ! From now on, if 'name'.eq.'firstname', then it is a new time cycle
+
+  ! just to be sure, check that firstnom is large enough to hold nom
+  if (len_trim(firstname).lt.len_trim(name)) then
+    write(*,*) "writediagsoil: Error !!!"
+    write(*,*) "   firstname string not long enough!!"
+    write(*,*) "   increase its size to at least ",len_trim(name)
+    stop
+  endif
+  
+  ! Set output sample rate
+  isample=ecritphy ! same as for diagfi outputs
+  ! Note ecritphy is known from control.h
+  
+  ! Create output NetCDF file
+  if (is_master) then
+   ierr=NF_CREATE(filename,NF_CLOBBER,nid)
+   if (ierr.ne.NF_NOERR) then
+    write(*,*)'writediagsoil: Error, failed creating file '//trim(filename)
+    stop
+   endif
+  endif ! of if (is_master)
+
+  ! Define dimensions and axis attributes
+  call iniwritesoil(nid,ngrid)
+  
+  ! set zitau to -1 to be compatible with zitau incrementation step below
+  zitau=-1
+  
+else
+  ! If not an initialization call, simply open the NetCDF file
+  if (is_master) then
+   ierr=NF_OPEN(filename,NF_WRITE,nid)
+  endif
+endif ! of if (firstname.eq."1234567890")
+
+! 2. Increment local time counter, if necessary
+if (name.eq.firstname) then
+  ! if we run across 'firstname', then it is a new time step
+  zitau=zitau+iphysiq
+  ! Note iphysiq is known from control.h
+endif
+
+! 3. Write data, if the time index matches the sample rate
+if (mod(zitau+1,isample).eq.0) then
+
+! 3.1 If first call at this date, update 'time' variable
+  if (name.eq.firstname) then
+    ntime=ntime+1
+    date=float(zitau+1)/float(day_step)
+    ! Note: day_step is known from control.h
+    
+    if (is_master) then
+     ! Get NetCDF ID for "time"
+     ierr=NF_INQ_VARID(nid,"time",varid)
+     ! Add the current value of date to the "time" array
+!#ifdef NC_DOUBLE
+!     ierr=NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+!#else
+     ierr=NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+!#endif
+     if (ierr.ne.NF_NOERR) then
+      write(*,*)"writediagsoil: Failed writing date to time variable"
+      stop 
+     endif
+    endif ! of if (is_master)
+  endif ! of if (name.eq.firstname)
+
+! 3.2 Write the variable to the NetCDF file
+if (dimpx.eq.3) then ! Case of a 3D variable
+  ! A. Recast data along 'dynamics' grid
+#ifdef CPP_PARA
+  ! gather field on a "global" (without redundant longitude) array
+  call Gather(px,dx3_glop)
+!$OMP MASTER
+  if (is_mpi_root) then
+    call Grid1Dto2D_glo(dx3_glop,dx3_glo)
+    ! copy dx3_glo() to dx3(:) and add redundant longitude
+    data3(1:iim,:,:)=dx3_glo(1:iim,:,:)
+    data3(iip1,:,:)=data3(1,:,:)
+  endif
+!$OMP END MASTER
+!$OMP BARRIER
+#else
+  do l=1,nsoilmx
+    ! handle the poles
+    do i=1,iip1
+      data3(i,1,l)=px(1,l)
+      data3(i,jjp1,l)=px(ngrid,l)
+    enddo
+    ! rest of the grid
+    do j=2,jjm
+      ig0=1+(j-2)*iim
+      do i=1,iim
+        data3(i,j,l)=px(ig0+i,l)
+      enddo
+      data3(iip1,j,l)=data3(1,j,l) ! extra (modulo) longitude
+    enddo
+  enddo
+#endif
+  
+  ! B. Write (append) the variable to the NetCDF file
+  if (is_master) then
+  ! B.1. Get the ID of the variable
+  ierr=NF_INQ_VARID(nid,name,varid)
+  if (ierr.ne.NF_NOERR) then
+    ! If we failed geting the variable's ID, we assume it is because
+    ! the variable doesn't exist yet and must be created.
+    ! Start by obtaining corresponding dimensions IDs
+    ierr=NF_INQ_DIMID(nid,"longitude",id(1))
+    ierr=NF_INQ_DIMID(nid,"latitude",id(2))
+    ierr=NF_INQ_DIMID(nid,"depth",id(3))
+    ierr=NF_INQ_DIMID(nid,"time",id(4))
+    ! Tell the world about it
+    write(*,*) "====================="
+    write(*,*) "writediagsoil: creating variable "//trim(name)
+    call def_var(nid,name,title,units,4,id,varid,ierr)
+  endif ! of if (ierr.ne.NF_NOERR)
+  
+  ! B.2. Prepare things to be able to write/append the variable
+  corners(1)=1
+  corners(2)=1
+  corners(3)=1
+  corners(4)=ntime
+  
+  edges(1)=iip1
+  edges(2)=jjp1
+  edges(3)=nsoilmx
+  edges(4)=1
+  
+  ! B.3. Write the slab of data
+!#ifdef NC_DOUBLE
+!  ierr=NF_PUT_VARA_DOUBLE(nid,varid,corners,edges,data3)
+!#else
+  ierr=NF_PUT_VARA_REAL(nid,varid,corners,edges,data3)
+!#endif
+  if (ierr.ne.NF_NOERR) then
+    write(*,*) "writediagsoil: Error: Failed writing "//trim(name)//&
+               " to file "//trim(filename)//" at time",date
+  endif
+  endif ! of if (is_master)
+
+elseif (dimpx.eq.2) then ! Case of a 2D variable
+
+  ! A. Recast data along 'dynamics' grid
+#ifdef CPP_PARA
+  ! gather field on a "global" (without redundant longitude) array
+  px2(:)=px(:,1)
+  call Gather(px2,dx2_glop)
+!$OMP MASTER
+  if (is_mpi_root) then
+    call Grid1Dto2D_glo(dx2_glop,dx2_glo)
+    ! copy dx3_glo() to dx3(:) and add redundant longitude
+    data2(1:iim,:)=dx2_glo(1:iim,:)
+    data2(iip1,:)=data2(1,:)
+  endif
+!$OMP END MASTER
+!$OMP BARRIER
+#else
+  ! handle the poles
+  do i=1,iip1
+    data2(i,1)=px(1,1)
+    data2(i,jjp1)=px(ngrid,1)
+  enddo
+  ! rest of the grid
+  do j=2,jjm
+    ig0=1+(j-2)*iim
+    do i=1,iim
+      data2(i,j)=px(ig0+i,1)
+    enddo
+    data2(iip1,j)=data2(1,j) ! extra (modulo) longitude
+  enddo
+#endif
+
+  ! B. Write (append) the variable to the NetCDF file
+  if (is_master) then
+  ! B.1. Get the ID of the variable
+  ierr=NF_INQ_VARID(nid,name,varid)
+  if (ierr.ne.NF_NOERR) then
+    ! If we failed geting the variable's ID, we assume it is because
+    ! the variable doesn't exist yet and must be created.
+    ! Start by obtaining corresponding dimensions IDs
+    ierr=NF_INQ_DIMID(nid,"longitude",id(1))
+    ierr=NF_INQ_DIMID(nid,"latitude",id(2))
+    ierr=NF_INQ_DIMID(nid,"time",id(3))
+    ! Tell the world about it
+    write(*,*) "====================="
+    write(*,*) "writediagsoil: creating variable "//trim(name)
+    call def_var(nid,name,title,units,3,id,varid,ierr)
+  endif ! of if (ierr.ne.NF_NOERR)
+
+  ! B.2. Prepare things to be able to write/append the variable
+  corners(1)=1
+  corners(2)=1
+  corners(3)=ntime
+  
+  edges(1)=iip1
+  edges(2)=jjp1
+  edges(3)=1
+  
+  ! B.3. Write the slab of data
+!#ifdef NC_DOUBLE
+!  ierr=NF_PUT_VARA_DOUBLE(nid,varid,corners,edges,data2)
+!#else
+  ierr=NF_PUT_VARA_REAL(nid,varid,corners,edges,data2)
+!#endif
+  if (ierr.ne.NF_NOERR) then
+    write(*,*) "writediagsoil: Error: Failed writing "//trim(name)//&
+               " to file "//trim(filename)//" at time",date
+  endif
+  endif ! of if (is_master)
+
+elseif (dimpx.eq.0) then ! Case of a 0D variable
+#ifdef CPP_PARA
+  write(*,*) "writediagsoil: dimps==0 case not implemented in // mode!!"
+  stop
+#endif
+  ! A. Copy data value
+  data0=px(1,1)
+
+  ! B. Write (append) the variable to the NetCDF file
+  ! B.1. Get the ID of the variable
+  ierr=NF_INQ_VARID(nid,name,varid)
+  if (ierr.ne.NF_NOERR) then
+    ! If we failed geting the variable's ID, we assume it is because
+    ! the variable doesn't exist yet and must be created.
+    ! Start by obtaining corresponding dimensions IDs
+    ierr=NF_INQ_DIMID(nid,"time",id(1))
+    ! Tell the world about it
+    write(*,*) "====================="
+    write(*,*) "writediagsoil: creating variable "//trim(name)
+    call def_var(nid,name,title,units,1,id,varid,ierr)
+  endif ! of if (ierr.ne.NF_NOERR)
+
+  ! B.2. Prepare things to be able to write/append the variable
+  corners(1)=ntime
+  
+  edges(1)=1
+
+  ! B.3. Write the data
+!#ifdef NC_DOUBLE
+!  ierr=NF_PUT_VARA_DOUBLE(nid,varid,corners,edges,data0)
+!#else
+  ierr=NF_PUT_VARA_REAL(nid,varid,corners,edges,data0)
+!#endif
+  if (ierr.ne.NF_NOERR) then
+    write(*,*) "writediagsoil: Error: Failed writing "//trim(name)//&
+               " to file "//trim(filename)//" at time",date
+  endif
+
+endif ! of if (dimpx.eq.3) elseif (dimpx.eq.2) ...
+endif ! of if (mod(zitau+1,isample).eq.0)
+
+! 4. Close the NetCDF file
+if (is_master) then
+  ierr=NF_CLOSE(nid)
+endif
+
+end subroutine writediagsoil
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagspecIR.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagspecIR.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagspecIR.F	(revision 222)
@@ -0,0 +1,309 @@
+      subroutine writediagspecIR(ngrid,nom,titre,unite,dimpx,px)
+
+!  Ecriture de variables diagnostiques au choix dans la physique 
+!  dans un fichier NetCDF nomme  'diagfi'. Ces variables peuvent etre
+!  3d (ex : temperature), 2d (ex : temperature de surface), ou
+!  0d (pour un scalaire qui ne depend que du temps : ex : la longitude
+!  solaire)
+!  Dans la version 2000, la periode d'ecriture est celle de 
+!  "ecritphy " regle dans le fichier de controle de run :  run.def
+!
+!    writediagfi peut etre appele de n'importe quelle subroutine
+!    de la physique, plusieurs fois. L'initialisation et la creation du
+!    fichier se fait au tout premier appel.
+!
+! WARNING : les variables dynamique (u,v,t,q,ps)
+!  sauvees par writediagfi avec une
+! date donnee sont legerement differentes que dans le fichier histoire car 
+! on ne leur a pas encore ajoute de la dissipation et de la physique !!!
+! IL est  RECOMMANDE d'ajouter les tendance physique a ces variables
+! avant l'ecriture dans diagfi (cf. physiq.F)
+!  
+!
+!  parametres (input) :
+!  ----------
+!      ngrid : nombres de point ou est calcule la physique
+!                (ngrid = 2+(jjm-1)*iim - 1/jjm)
+!                 (= nlon ou klon dans la physique terrestre)
+!      
+!      unit : unite logique du fichier de sortie (toujours la meme)
+!      nom  : nom de la variable a sortir (chaine de caracteres)
+!      titre: titre de la variable (chaine de caracteres)
+!      unite : unite de la variable (chaine de caracteres)
+!      px : variable a sortir (real 0, 2, ou 3d)
+!      dimpx : dimension de px : 0, 2, ou 3 dimensions
+!
+!=================================================================
+!
+!      This is a modified version that accepts spectrally varying input
+!      RW (2010)
+!
+!=================================================================
+ 
+! Addition by RW (2010) to allow OLR to be saved in .nc format
+      use radinc_h, only : L_NSPECTI
+!      USE surfdat_h, only : phisfi
+#ifdef CPP_PARA
+      use mod_phys_lmdz_para, only : is_mpi_root, is_master, gather
+      use mod_grid_phy_lmdz, only : klon_glo, Grid1Dto2D_glo
+#endif
+      use control_mod, only: ecritphy, iphysiq, day_step
+
+      implicit none
+
+! Commons
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+!#include "control.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "netcdf.inc"
+#include "temps.h"
+#include "callkeys.h"
+
+! Arguments on input:
+      integer,intent(in) :: ngrid
+      character (len=*),intent(in) :: nom,titre,unite
+      integer,intent(in) :: dimpx
+      real,intent(in) :: px(ngrid,L_NSPECTI)
+
+! Local variables:
+
+!      real dx3(iip1,jjp1,llm) ! to store a 3D data set
+!      real dx2(iip1,jjp1)     ! to store a 2D (surface) data set
+!      real dx0
+
+      real date
+
+!      REAL phis(ip1jmp1)
+
+      integer irythme
+      integer ierr
+      integer iq
+      integer i,j,l,zmax , ig0
+
+      integer zitau
+      character firstnom*20
+      SAVE firstnom
+      SAVE zitau
+      SAVE date
+      data firstnom /'1234567890'/
+      data zitau /0/
+
+! Ajouts
+      integer, save :: ntime=0
+      integer :: idim,varid
+      integer :: nid
+      character (len =50):: fichnom
+      integer, dimension(4) :: id
+      integer, dimension(4) :: edges,corner
+
+! added by RDW for OLR output
+       real dx3(iip1,jjp1,L_NSPECTI) ! to store the data set
+
+#ifdef CPP_PARA
+! Added to work in parallel mode
+      real dx3_glop(klon_glo,L_NSPECTI)
+      real dx3_glo(iim,jjp1,L_NSPECTI) ! to store a global 3D data set
+#else
+      logical,parameter :: is_master=.true.
+      logical,parameter :: is_mpi_root=.true.
+#endif
+
+!***************************************************************
+!Sortie des variables au rythme voulu
+
+      irythme = ecritphy*iradia ! sortie au rythme de ecritphy*iradia
+!EM+JL if the spetra need to be output more frequently, need to define a ecritSpec...
+!     irythme = iphysiq  ! sortie a tous les pas physique
+
+
+!***************************************************************
+
+! Initialisation of 'firstnom' and create/open the "diagfi.nc" NetCDF file
+! ------------------------------------------------------------------------
+! (Au tout premier appel de la subroutine durant le run.)
+
+      fichnom="diagspecIR.nc"
+
+      if (firstnom.eq.'1234567890') then ! .true. for the very first call
+      !  to this subroutine; now set 'firstnom'
+         firstnom = nom
+         ! just to be sure, check that firstnom is large enough to hold nom
+         if (len_trim(firstnom).lt.len_trim(nom)) then
+           write(*,*) "writediagspecIR: Error !!!"
+           write(*,*) "   firstnom string not long enough!!"
+           write(*,*) "   increase its size to at least ",len_trim(nom)
+           stop
+         endif
+
+         ! Create the NetCDF file
+         if (is_master) then
+         ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+         ! Define the 'Time' dimension
+         ierr = nf_def_dim(nid,"Time",NF_UNLIMITED,idim)
+         ! Define the 'Time' variable
+#ifdef NC_DOUBLE
+         ierr = NF_DEF_VAR (nid, "Time", NF_DOUBLE, 1, idim,varid)
+#else
+         ierr = NF_DEF_VAR (nid, "Time", NF_FLOAT, 1, idim,varid)
+#endif
+         ! Add a long_name attribute
+         ierr = NF_PUT_ATT_TEXT (nid, varid, "long_name",
+     .          4,"Time")
+         ! Add a units attribute
+         ierr = NF_PUT_ATT_TEXT(nid, varid,'units',29,
+     .          "days since 0000-00-0 00:00:00")
+         ! Switch out of NetCDF Define mode
+         ierr = NF_ENDDEF(nid)
+
+!         call gr_fi_dyn(1,size(phisfi_glo),iip1,jjp1,phisfi_glo,phis)
+         ! write "header" of file (longitudes, latitudes, area, ...)
+         call iniwrite_specIR(nid,day_ini)
+         endif ! of if (is_master)
+
+         zitau = -1 ! initialize zitau
+      else
+         if (is_master) then
+           ! Open the NetCDF file
+           ierr = NF_OPEN(fichnom,NF_WRITE,nid)
+         endif
+      endif ! if (firstnom.eq.'1234567890')
+
+! Increment time index 'zitau' if it is the "firstcall" (at given time level)
+! to writediagfi
+!------------------------------------------------------------------------
+      if (nom.eq.firstnom) then
+          zitau = zitau + iphysiq
+      end if
+
+!--------------------------------------------------------
+! Write the variables to output file if it's time to do so
+!--------------------------------------------------------
+
+      if ( MOD(zitau+1,irythme) .eq.0.) then
+
+! Compute/write/extend 'Time' coordinate (date given in days)
+! (done every "first call" (at given time level) to writediagfi)
+! Note: date is incremented as 1 step ahead of physics time
+!       (like the 'histoire' outputs)
+!--------------------------------------------------------
+
+        if (nom.eq.firstnom) then
+
+        ! We have identified a "first call" (at given date)
+           ntime=ntime+1 ! increment # of stored time steps
+           ! compute corresponding date (in days and fractions thereof)
+           date= float (zitau +1)/float (day_step)
+
+           if (is_master) then
+             ! Get NetCDF ID of 'Time' variable
+             ierr= NF_INQ_VARID(nid,"Time",varid)
+
+             ! Write (append) the new date to the 'Time' array
+#ifdef NC_DOUBLE
+             ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+#else
+             ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+#endif
+             if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagspec_nc"
+              write(*,*) "***** with time"
+              write(*,*) 'ierr=', ierr   
+c             call abort
+             endif
+
+             write(6,*)'WRITEDIAGSPEC: date= ', date
+           endif ! of if (is_master)
+        end if ! of if (nom.eq.firstnom)
+
+
+ 
+!Case of a 3D variable
+!---------------------
+        if (dimpx.eq.3) then
+
+!         A. Recast (copy) variable from physics grid to dynamics grid
+#ifdef CPP_PARA
+  ! gather field on a "global" (without redundant longitude) array
+          call Gather(px,dx3_glop)
+!$OMP MASTER
+          if (is_mpi_root) then
+            call Grid1Dto2D_glo(dx3_glop,dx3_glo)
+            ! copy dx3_glo() to dx3(:) and add redundant longitude
+            dx3(1:iim,:,:)=dx3_glo(1:iim,:,:)
+            dx3(iip1,:,:)=dx3(1,:,:)
+          endif
+!$OMP END MASTER
+!$OMP BARRIER
+#else
+           DO l=1,L_NSPECTI
+             DO i=1,iip1
+                dx3(i,1,l)=px(1,l)
+                dx3(i,jjp1,l)=px(ngrid,l)
+             ENDDO
+             DO j=2,jjm
+                ig0= 1+(j-2)*iim
+                DO i=1,iim
+                   dx3(i,j,l)=px(ig0+i,l)
+                ENDDO
+                dx3(iip1,j,l)=dx3(1,j,l)
+             ENDDO
+           ENDDO
+#endif
+
+!         B. Write (append) the variable to the NetCDF file
+          if (is_master) then
+
+! name of the variable
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"IR Wavenumber",id(3))
+              ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGSPECIR: creating variable ",nom
+              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+
+           endif
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=L_NSPECTI
+           edges(4)=1
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,dx3)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx3)
+#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR problem in writediagspec"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr
+             call abort
+           endif 
+
+          endif ! of if (is_master)
+
+        endif ! of if (dimpx.eq.3)
+
+      endif ! of if ( MOD(zitau+1,irythme) .eq.0.)
+
+      ! Close the NetCDF file
+      if (is_master) then
+        ierr= NF_CLOSE(nid)
+      endif
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagspecVI.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagspecVI.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writediagspecVI.F	(revision 222)
@@ -0,0 +1,309 @@
+      subroutine writediagspecVI(ngrid,nom,titre,unite,dimpx,px)
+
+!  Ecriture de variables diagnostiques au choix dans la physique 
+!  dans un fichier NetCDF nomme  'diagfi'. Ces variables peuvent etre
+!  3d (ex : temperature), 2d (ex : temperature de surface), ou
+!  0d (pour un scalaire qui ne depend que du temps : ex : la longitude
+!  solaire)
+!  Dans la version 2000, la periode d'ecriture est celle de 
+!  "ecritphy " regle dans le fichier de controle de run :  run.def
+!
+!    writediagfi peut etre appele de n'importe quelle subroutine
+!    de la physique, plusieurs fois. L'initialisation et la creation du
+!    fichier se fait au tout premier appel.
+!
+! WARNING : les variables dynamique (u,v,t,q,ps)
+!  sauvees par writediagfi avec une
+! date donnee sont legerement differentes que dans le fichier histoire car 
+! on ne leur a pas encore ajoute de la dissipation et de la physique !!!
+! IL est  RECOMMANDE d'ajouter les tendance physique a ces variables
+! avant l'ecriture dans diagfi (cf. physiq.F)
+!  
+!
+!  parametres (input) :
+!  ----------
+!      ngrid : nombres de point ou est calcule la physique
+!                (ngrid = 2+(jjm-1)*iim - 1/jjm)
+!                 (= nlon ou klon dans la physique terrestre)
+!      
+!      unit : unite logique du fichier de sortie (toujours la meme)
+!      nom  : nom de la variable a sortir (chaine de caracteres)
+!      titre: titre de la variable (chaine de caracteres)
+!      unite : unite de la variable (chaine de caracteres)
+!      px : variable a sortir (real 0, 2, ou 3d)
+!      dimpx : dimension de px : 0, 2, ou 3 dimensions
+!
+!=================================================================
+!
+!      This is a modified version that accepts spectrally varying input
+!      RW (2010)
+!
+!=================================================================
+ 
+! Addition by RW (2010) to allow OSR to be saved in .nc format
+      use radinc_h, only : L_NSPECTV
+!      USE surfdat_h
+#ifdef CPP_PARA
+      use mod_phys_lmdz_para, only : is_mpi_root, is_master, gather
+      use mod_grid_phy_lmdz, only : klon_glo, Grid1Dto2D_glo
+#endif
+      use control_mod, only: ecritphy, iphysiq, day_step
+
+      implicit none
+
+! Commons
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+!#include "control.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "netcdf.inc"
+#include "temps.h"
+#include "callkeys.h"
+
+! Arguments on input:
+      integer ngrid
+      character (len=*) :: nom,titre,unite
+      integer dimpx
+      real px(ngrid,L_NSPECTV)
+
+! Local variables:
+
+!      real dx3(iip1,jjp1,llm) ! to store a 3D data set
+!      real dx2(iip1,jjp1)     ! to store a 2D (surface) data set
+!      real dx0
+
+      real date
+
+!      REAL phis(ip1jmp1)
+
+      integer irythme
+      integer ierr
+      integer iq
+      integer i,j,l,zmax , ig0
+
+      integer zitau
+      character firstnom*20
+      SAVE firstnom
+      SAVE zitau
+      SAVE date
+      data firstnom /'1234567890'/
+      data zitau /0/
+
+! Ajouts
+      integer, save :: ntime=0
+      integer :: idim,varid
+      integer :: nid
+      character (len =50):: fichnom
+      integer, dimension(4) :: id
+      integer, dimension(4) :: edges,corner
+
+! added by RDW for OSR output
+       real dx3(iip1,jjp1,L_NSPECTV) ! to store the data set
+
+#ifdef CPP_PARA
+! Added to work in parallel mode
+      real dx3_glop(klon_glo,L_NSPECTV)
+      real dx3_glo(iim,jjp1,L_NSPECTV) ! to store a global 3D data set
+#else
+      logical,parameter :: is_master=.true.
+      logical,parameter :: is_mpi_root=.true.
+#endif
+
+!***************************************************************
+!Sortie des variables au rythme voulu
+
+      irythme = ecritphy*iradia ! sortie au rythme de ecritphy
+!EM+JL if the spetra need to be output more frequently, need to define a ecritSpec...
+!     irythme = iphysiq  ! sortie a tous les pas physique
+
+!***************************************************************
+
+! Initialisation of 'firstnom' and create/open the "diagfi.nc" NetCDF file
+! ------------------------------------------------------------------------
+! (Au tout premier appel de la subroutine durant le run.)
+
+      fichnom="diagspecVI.nc"
+
+      if (firstnom.eq.'1234567890') then ! .true. for the very first call
+      !  to this subroutine; now set 'firstnom'
+         firstnom = nom
+         ! just to be sure, check that firstnom is large enough to hold nom
+         if (len_trim(firstnom).lt.len_trim(nom)) then
+           write(*,*) "writediagfi: Error !!!"
+           write(*,*) "   firstnom string not long enough!!"
+           write(*,*) "   increase its size to at least ",len_trim(nom)
+           stop
+         endif
+
+         ! Create the NetCDF file
+         if (is_master) then
+         ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+         ! Define the 'Time' dimension
+         ierr = nf_def_dim(nid,"Time",NF_UNLIMITED,idim)
+         ! Define the 'Time' variable
+#ifdef NC_DOUBLE
+         ierr = NF_DEF_VAR (nid, "Time", NF_DOUBLE, 1, idim,varid)
+#else
+         ierr = NF_DEF_VAR (nid, "Time", NF_FLOAT, 1, idim,varid)
+#endif
+         ! Add a long_name attribute
+         ierr = NF_PUT_ATT_TEXT (nid, varid, "long_name",
+     .          4,"Time")
+         ! Add a units attribute
+         ierr = NF_PUT_ATT_TEXT(nid, varid,'units',29,
+     .          "days since 0000-00-0 00:00:00")
+         ! Switch out of NetCDF Define mode
+         ierr = NF_ENDDEF(nid)
+
+         ! write "header" of file (longitudes, latitudes, geopotential, ...)
+!         call gr_fi_dyn(1,ngrid,iip1,jjp1,phisfi,phis)
+!         call iniwrite(nid,day_ini,phis)
+         call iniwrite_specVI(nid,day_ini)
+         endif ! of if (is_master)
+
+         zitau = -1 ! initialize zitau
+      else
+         if (is_master) then
+           ! Open the NetCDF file
+           ierr = NF_OPEN(fichnom,NF_WRITE,nid)
+         endif
+      endif ! if (firstnom.eq.'1234567890')
+
+! Increment time index 'zitau' if it is the "firstcall" (at given time level)
+! to writediagfi
+!------------------------------------------------------------------------
+      if (nom.eq.firstnom) then
+          zitau = zitau + iphysiq
+      end if
+
+!--------------------------------------------------------
+! Write the variables to output file if it's time to do so
+!--------------------------------------------------------
+
+      if ( MOD(zitau+1,irythme) .eq.0.) then
+
+! Compute/write/extend 'Time' coordinate (date given in days)
+! (done every "first call" (at given time level) to writediagfi)
+! Note: date is incremented as 1 step ahead of physics time
+!       (like the 'histoire' outputs)
+!--------------------------------------------------------
+
+        if (nom.eq.firstnom) then
+
+        ! We have identified a "first call" (at given date)
+           ntime=ntime+1 ! increment # of stored time steps
+           ! compute corresponding date (in days and fractions thereof)
+           date= float (zitau +1)/float (day_step)
+
+           if (is_master) then
+             ! Get NetCDF ID of 'Time' variable
+             ierr= NF_INQ_VARID(nid,"Time",varid)
+
+             ! Write (append) the new date to the 'Time' array
+#ifdef NC_DOUBLE
+             ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+#else
+             ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+#endif
+             if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagspec_nc"
+              write(*,*) "***** with time"
+              write(*,*) 'ierr=', ierr   
+c             call abort
+             endif
+
+             write(6,*)'WRITEDIAGSPEC: date= ', date
+           endif ! of if (is_master)
+        end if ! of if (nom.eq.firstnom)
+
+
+ 
+!Case of a 3D variable
+!---------------------
+        if (dimpx.eq.3) then
+
+!         A. Recast (copy) variable from physics grid to dynamics grid
+#ifdef CPP_PARA
+  ! gather field on a "global" (without redundant longitude) array
+          call Gather(px,dx3_glop)
+!$OMP MASTER
+          if (is_mpi_root) then
+            call Grid1Dto2D_glo(dx3_glop,dx3_glo)
+            ! copy dx3_glo() to dx3(:) and add redundant longitude
+            dx3(1:iim,:,:)=dx3_glo(1:iim,:,:)
+            dx3(iip1,:,:)=dx3(1,:,:)
+          endif
+!$OMP END MASTER
+!$OMP BARRIER
+#else
+           DO l=1,L_NSPECTV
+             DO i=1,iip1
+                dx3(i,1,l)=px(1,l)
+                dx3(i,jjp1,l)=px(ngrid,l)
+             ENDDO
+             DO j=2,jjm
+                ig0= 1+(j-2)*iim
+                DO i=1,iim
+                   dx3(i,j,l)=px(ig0+i,l)
+                ENDDO
+                dx3(iip1,j,l)=dx3(1,j,l)
+             ENDDO
+           ENDDO
+#endif
+
+!         B. Write (append) the variable to the NetCDF file
+          if (is_master) then
+
+! name of the variable
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"VI Wavenumber",id(3))
+              ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGSPEC: creating variable ",nom
+              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+
+           endif
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=L_NSPECTV
+           edges(4)=1
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,dx3)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx3)
+#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR problem in writediagspec"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr
+             call abort
+           endif 
+
+          endif ! of if (is_master)
+
+        endif ! of if (dimpx.eq.3)
+
+      endif ! of if ( MOD(zitau+1,irythme) .eq.0.)
+
+      ! Close the NetCDF file
+      if (is_master) then
+        ierr= NF_CLOSE(nid)
+      endif
+
+      end
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writeg1d.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writeg1d.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/writeg1d.F	(revision 222)
@@ -0,0 +1,220 @@
+      SUBROUTINE writeg1d(ngrid,nx,x,nom,titre)
+      IMPLICIT NONE
+
+c.......................................................................
+c
+c  ecriture de x pour GRADS-1D
+c
+c  in :
+c         * ngrid      ---> pour controler que l'on est bien en 1D
+c         * nx         ---> taille du vecteur a stocker
+c                             "1" pour une variable de surface
+c                             "nlayer" pour une variable de centre de couche
+c                             "nlayer+1" pour une variable d'interface
+c         * x          ---> variable a stocker
+c         * nom        ---> nom "pour grads"
+c         * titre      ---> titre "pour grads"
+c
+c.......................................................................
+c
+#include "comg1d.h"
+
+c
+c.......................................................................
+c  declaration des arguments 
+c
+      INTEGER ngrid,nx,i
+      REAL*4 xr4(1000)
+      REAL x(nx)
+      CHARACTER*(*) nom,titre
+c
+c  declaration des arguments 
+c....................................................................... 
+c  declaration des variables locales
+c
+      INTEGER ilayer,ivar
+      LOGICAL test 
+c
+c  declaration des variables locales
+c.......................................................................
+c  controle 1D
+c
+c     print*,'ngrid=',ngrid
+      IF (ngrid.NE.1) return
+c
+c  controle 1D
+c.......................................................................
+c  copy => force en reel 4 pour l'ecriture dans grads1d.dat
+
+      do i=1,nx
+        xr4(i) = x(i)
+      enddo
+
+c  copy => force en reel 4 pour l'ecriture dans grads1d.dat
+c.......................................................................
+c  ouverture du fichier au premier appel
+
+
+      g1d_nomfich='g1d.dat'
+
+      IF (g1d_premier) THEN
+        OPEN (g1d_unitfich,FILE=g1d_nomfich
+     &       ,FORM='unformatted',ACCESS='direct',RECL=4)
+        g1d_irec=0
+        g1d_nvar=0
+        g1d_premier=.false.
+      ENDIF
+
+c  ouverture du fichier au premier appel
+c.......................................................................
+c  pour l'ecriture du fichier ctl
+
+      test=.true.
+      DO ivar=1,g1d_nvar
+        IF (nom.EQ.g1d_nomvar(ivar)) test=.false.
+        IF (nx .GT. 1000) then
+          print*,'ERROR:  nx > 1000 dans writeg1d.F' 
+          print*,'Changer la dimension de xr4'
+          call exit(1)
+        ENDIF
+      ENDDO
+      IF (test) THEN
+        g1d_nvar=g1d_nvar+1
+        g1d_nomvar(g1d_nvar)=nom
+        g1d_titrevar(g1d_nvar)=titre
+        IF (nx.EQ.1) THEN
+           g1d_dimvar(g1d_nvar)=0
+        ELSEIF (nx.EQ.g1d_nlayer) THEN
+           g1d_dimvar(g1d_nvar)=g1d_nlayer
+        ELSEIF (nx.EQ.g1d_nlayer+1) THEN
+           g1d_dimvar(g1d_nvar)=g1d_nlayer+1
+        ELSE
+           PRINT *,'._. probleme de dimension dans GRADS-1D ._.'
+           print*,'NX = ',nx
+           print*,'g1d_nlayer = ',g1d_nlayer
+        ENDIF
+      ENDIF
+c
+c  pour l'ecriture du fichier ctl
+c.......................................................................
+c  ecriture
+c
+      IF (nx.EQ.1) THEN
+        g1d_irec=g1d_irec+1
+        WRITE(g1d_unitfich,REC=g1d_irec) xr4(1)
+      ELSE
+        DO ilayer=1,g1d_nlayer
+          g1d_irec=g1d_irec+1
+          WRITE(g1d_unitfich,REC=g1d_irec) xr4(ilayer)
+        ENDDO
+      ENDIF
+c
+c  ecriture
+c.......................................................................
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+      RETURN
+      END
+
+
+
+
+
+c *********************************************************************
+c *********************************************************************
+
+      SUBROUTINE endg1d(ngrid,nlayer,zlayer,ndt)
+      IMPLICIT NONE
+c.......................................................................
+c
+c  ecriture du fichier de controle pour GRADS-1D
+c
+c  in :
+c         * ngrid      ---> pour controler que l'on est bien en 1D
+c         * nlayer     ---> nombre de couches
+c         * zlayer     ---> altitude au centre de chaque couche (km)
+c         * ndt        ---> nombre de pas de temps
+c
+c.......................................................................
+c
+#include "comg1d.h"
+#include "comcstfi.h"
+
+
+c
+c.......................................................................
+c  declaration des arguments 
+c
+      INTEGER ngrid,nlayer
+      REAL zlayer(nlayer)
+      INTEGER ndt
+c
+c  declaration des arguments 
+c....................................................................... 
+c  declaration des variables locales
+c
+      INTEGER ivar,ilayer
+c
+
+
+!      integer saveG1D
+
+c  declaration des variables locales
+c.......................................................................
+c  contole 1D
+c
+      IF (ngrid.NE.1) GOTO 10001
+c
+c  contole 1D
+c.......................................................................
+c
+      IF (nlayer.ne.g1d_nlayer) 
+     &PRINT *,'._. probleme de dimension dans GRADS-1D (endg1d.F) '
+c
+c.......................................................................
+c
+      CLOSE (g1d_unitfich)
+c
+c.......................................................................
+
+
+      OPEN (g1d_unitctl,FILE=g1d_nomctl,FORM='formatted',RECL=4*100)
+      WRITE (g1d_unitctl,'(a4,2x,a1,a20)') 'DSET','^',g1d_nomfich
+      WRITE (g1d_unitctl,'(a5,2x,a20)') 'UNDEF ','1.E+30'
+      WRITE (g1d_unitctl,'(a11)') 'FORMAT YREV'
+      WRITE (g1d_unitctl,'(a5,2x,a30)') 'TITLE ','champs 1D'
+      WRITE (g1d_unitctl,'(a5,i4,a20)') 'XDEF ',1,' LINEAR 0 1'
+      WRITE (g1d_unitctl,'(a5,i4,a20)') 'YDEF ',1,' LINEAR 0 1'
+      WRITE (g1d_unitctl,'(a5,i4,a20)') 'ZDEF ',g1d_nlayer,' LEVELS'
+      WRITE (g1d_unitctl,'(5(1x,f13.5))')
+     &      (zlayer(ilayer),ilayer=1,g1d_nlayer)
+
+c     Writing true timestep in g1d.ctl (in planet "minutes"= sol/(60*24)
+!      ivar =min( max(int(1440.*dtphys/daysec +0.5),1) , 99)   
+!      WRITE (g1d_unitctl,'(a4,2x,i10,a19,i2,a2)')
+!     &      'TDEF ',ndt,' LINEAR 01JAN2000 ', ivar,'MN '
+
+      ivar =min( max(int(1440.*dtphys*saveG1D/daysec +0.5),1) , 99)
+      ! not sure ivar is right, but it doesnt matter
+      WRITE (g1d_unitctl,'(a4,2x,i10,a19,i2,a2)')
+     &      'TDEF ',ndt/saveG1D,' LINEAR 01JAN2000 ', ivar,'MN '
+
+      WRITE (g1d_unitctl,'(a5,i5)') 'VARS ',g1d_nvar
+      DO ivar=1,g1d_nvar
+      WRITE (g1d_unitctl,'(a9,3x,i4,i3,1x,a39)') 
+     &       g1d_nomvar(ivar),g1d_dimvar(ivar),99,g1d_titrevar(ivar)
+      ENDDO
+      WRITE (g1d_unitctl,'(a7)') 'ENDVARS'
+      CLOSE (g1d_unitctl)
+c
+c.......................................................................
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+      RETURN
+      END
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/wstats.F90
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/wstats.F90	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/wstats.F90	(revision 222)
@@ -0,0 +1,429 @@
+subroutine wstats(ngrid,nom,titre,unite,dim,px)
+
+use mod_phys_lmdz_para, only : is_mpi_root, is_master, gather, klon_mpi_begin
+use mod_grid_phy_lmdz, only : klon_glo, Grid1Dto2D_glo
+
+implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comconst.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+integer,intent(in) :: ngrid
+character (len=*),intent(in) :: nom,titre,unite
+integer,intent(in) :: dim
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+real,intent(in) :: px(ngrid,llm)
+real, dimension(iip1,jjp1,llm) :: mean3d,sd3d,dx3
+real, dimension(iip1,jjp1) :: mean2d,sd2d,dx2
+character (len=50) :: namebis
+character (len=50), save :: firstvar
+integer :: ierr,varid,nbdim,nid
+integer :: meanid,sdid
+integer, dimension(4)  :: id,start,sizes
+logical, save :: firstcall=.TRUE.
+integer :: l,i,j,ig0
+integer,save :: indx
+
+integer, save :: step=0
+
+! Added to work in parallel mode
+#ifdef CPP_PARA
+real px3_glop(klon_glo,llm) ! to store a 3D data set on global physics grid
+real px3_glo(iim,jjp1,llm) ! to store a global 3D data set on global lonxlat grid
+real px2_glop(klon_glo) ! to store a 2D data set on global physics grid
+real px2_glo(iim,jjp1) ! to store a 2D data set on global lonxlat grid
+real px2(ngrid)
+real px3(ngrid,llm)
+#else
+! When not running in parallel mode:
+real px3_glop(ngrid,llm) ! to store a 3D data set on global physics grid
+real px3_glo(iim,jjp1,llm) ! to store a global 3D data set on global lonxlat grid
+real px2_glop(ngrid) ! to store a 2D data set on global physics grid
+real px2_glo(iim,jjp1) ! to store a 2D data set on global lonxlat grid
+#endif
+
+! 1. Initialization (creation of stats.nc file)
+if (firstcall) then
+   firstcall=.false.
+   firstvar=trim((nom))
+   call inistats(ierr)
+endif
+
+if (firstvar==nom) then ! If we're back to the first variable, increment time counter
+      step = step + 1
+endif
+
+if (mod(step,istats).ne.0) then
+  ! if its not time to write to file, exit
+   RETURN
+endif
+
+! collect fields on a global physics grid
+#ifdef CPP_PARA
+ if (dim.eq.3) then
+  px3(1:ngrid,1:llm)=px(1:ngrid,1:llm)
+  ! Gather fieds on a "global" (without redundant longitude) array
+  call Gather(px3,px3_glop)
+!$OMP MASTER
+  if (is_mpi_root) then
+    call Grid1Dto2D_glo(px3_glop,px3_glo)
+    ! copy dx3_glo() to dx3(:) and add redundant longitude
+    dx3(1:iim,:,:)=px3_glo(1:iim,:,:)
+    dx3(iip1,:,:)=dx3(1,:,:)
+  endif
+!$OMP END MASTER
+!$OMP BARRIER
+ else ! dim.eq.2
+  ! Gather fieds on a "global" (without redundant longitude) array
+  px2(:)=px(:,1)
+  call Gather(px2,px2_glop)
+!$OMP MASTER
+          if (is_mpi_root) then
+            call Grid1Dto2D_glo(px2_glop,px2_glo)
+            ! copy px2_glo() to dx2(:) and add redundant longitude
+            dx2(1:iim,:)=px2_glo(1:iim,:)
+            dx2(iip1,:)=dx2(1,:)
+          endif
+!$OMP END MASTER
+!$OMP BARRIER
+ endif
+#else
+  if (dim.eq.3) then
+    px3_glop(:,1:llm)=px(:,1:llm)
+!  Passage variable physique -->  variable dynamique
+    DO l=1,llm
+      DO i=1,iim
+         px3_glo(i,1,l)=px(1,l)
+         px3_glo(i,jjp1,l)=px(ngrid,l)
+      ENDDO
+      DO j=2,jjm
+         ig0= 1+(j-2)*iim
+         DO i=1,iim
+            px3_glo(i,j,l)=px(ig0+i,l)
+         ENDDO
+      ENDDO
+    ENDDO
+  else ! dim.eq.2
+    px2_glop(:)=px(:,1)
+!    Passage variable physique -->  physique dynamique
+   DO i=1,iim
+     px2_glo(i,1)=px(1,1)
+     px2_glo(i,jjp1)=px(ngrid,1)
+   ENDDO
+   DO j=2,jjm
+     ig0= 1+(j-2)*iim
+     DO i=1,iim
+        px2_glo(i,j)=px(ig0+i,1)
+     ENDDO
+   ENDDO
+  endif
+#endif
+
+! 2. Write field to file
+
+if (is_master) then
+! only master needs do this
+
+ierr = NF_OPEN("stats.nc",NF_WRITE,nid)
+
+namebis=trim(nom)
+
+! test: check if that variable already exists in file
+ierr= NF_INQ_VARID(nid,namebis,meanid)
+
+if (ierr.ne.NF_NOERR) then
+  ! variable not in file, create/define it
+   if (firstvar==nom) then 
+      indx=1
+      count(:)=0
+   endif
+
+
+!declaration de la variable
+
+! choix du nom des coordonnees
+   ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+   ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+   if (dim.eq.3) then
+      ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+      ierr= NF_INQ_DIMID(nid,"Time",id(4))
+      nbdim=4
+   else if (dim==2) then
+      ierr= NF_INQ_DIMID(nid,"Time",id(3))
+      nbdim=3
+   endif
+
+   write (*,*) "====================="
+   write (*,*) "STATS: creation de ",nom
+   namebis=trim(nom)
+   call def_var(nid,namebis,titre,unite,nbdim,id,meanid,ierr)
+   if (dim.eq.3) then
+     call inivar(nid,meanid,size(px3_glop,1),dim,indx,px3_glop,ierr)
+   else ! dim.eq.2
+     call inivar(nid,meanid,size(px2_glop,1),dim,indx,px2_glop,ierr)
+   endif
+   namebis=trim(nom)//"_sd"
+   call def_var(nid,namebis,trim(titre)//" total standard deviation over the season",unite,nbdim,id,sdid,ierr)
+   if (dim.eq.3) then
+     call inivar(nid,sdid,size(px3_glop,1),dim,indx,px3_glop,ierr)
+   else ! dim.eq.2
+     call inivar(nid,sdid,size(px2_glop,1),dim,indx,px2_glop,ierr)
+   endif
+
+   ierr= NF_CLOSE(nid)
+   return
+
+else
+   ! variable found in file
+   namebis=trim(nom)//"_sd"
+   ierr= NF_INQ_VARID(nid,namebis,sdid)
+
+endif
+
+if (firstvar==nom) then 
+   count(indx)=count(int(indx))+1
+   indx=indx+1
+   if (indx>istime) then
+      indx=1
+   endif
+endif
+
+if (count(indx)==0) then
+   ! very first time we write the variable to file
+   if (dim.eq.3) then
+      start=(/1,1,1,indx/)
+      sizes=(/iip1,jjp1,llm,1/)
+      mean3d(:,:,:)=0
+      sd3d(:,:,:)=0
+   else if (dim.eq.2) then
+      start=(/1,1,indx,0/)
+      sizes=(/iip1,jjp1,1,0/)
+      mean2d(:,:)=0
+      sd2d(:,:)=0
+   endif
+else
+   ! load values from file
+   if (dim.eq.3) then
+      start=(/1,1,1,indx/)
+      sizes=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,sizes,mean3d)
+      ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,sizes,sd3d)
+#else
+      ierr = NF_GET_VARA_REAL(nid,meanid,start,sizes,mean3d)
+      ierr = NF_GET_VARA_REAL(nid,sdid,start,sizes,sd3d)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+   else if (dim.eq.2) then
+      start=(/1,1,indx,0/)
+      sizes=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,sizes,mean2d)
+      ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,sizes,sd2d)
+#else
+      ierr = NF_GET_VARA_REAL(nid,meanid,start,sizes,mean2d)
+      ierr = NF_GET_VARA_REAL(nid,sdid,start,sizes,sd2d)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+   endif
+endif ! of if (count(indx)==0)
+
+
+! 2.1. Build dx* (data on lon-lat grid, with redundant longitude)
+
+if (dim.eq.3) then
+  dx3(1:iim,:,:)=px3_glo(:,:,:)
+  dx3(iip1,:,:)=dx3(1,:,:)
+else ! dim.eq.2
+  dx2(1:iim,:)=px2_glo(:,:)
+  dx2(iip1,:)=dx2(1,:)
+endif
+
+
+! 2.2. Add current values to previously stored sums
+
+if (dim.eq.3) then
+
+   mean3d(:,:,:)=mean3d(:,:,:)+dx3(:,:,:)
+   sd3d(:,:,:)=sd3d(:,:,:)+dx3(:,:,:)**2
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,sizes,mean3d)
+   ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,sizes,sd3d)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,meanid,start,sizes,mean3d)
+   ierr = NF_PUT_VARA_REAL(nid,sdid,start,sizes,sd3d)
+#endif
+
+else if (dim.eq.2) then
+
+   mean2d(:,:)= mean2d(:,:)+dx2(:,:)
+   sd2d(:,:)=sd2d(:,:)+dx2(:,:)**2
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,sizes,mean2d)
+   ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,sizes,sd2d)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,meanid,start,sizes,mean2d)
+   ierr = NF_PUT_VARA_REAL(nid,sdid,start,sizes,sd2d)
+#endif
+
+endif ! of if (dim.eq.3) elseif (dim.eq.2)
+
+  ierr= NF_CLOSE(nid)
+endif ! of if (is_master)
+
+end subroutine wstats
+
+!======================================================
+subroutine inivar(nid,varid,ngrid,dim,indx,px,ierr)
+
+implicit none
+
+include "dimensions.h"
+include "dimphys.h"
+include "netcdf.inc"
+
+integer, intent(in) :: nid,varid,dim,indx,ngrid
+real, dimension(ngrid,llm), intent(in) :: px
+integer, intent(out) :: ierr
+
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+
+integer :: l,i,j,ig0
+integer, dimension(4) :: start,sizes
+real, dimension(iip1,jjp1,llm) :: dx3
+real, dimension(iip1,jjp1) :: dx2
+
+if (dim.eq.3) then
+
+   start=(/1,1,1,indx/)
+   sizes=(/iip1,jjp1,llm,1/)
+
+!  Passage variable physique -->  variable dynamique
+
+   DO l=1,llm
+      DO i=1,iip1
+         dx3(i,1,l)=px(1,l)
+         dx3(i,jjp1,l)=px(ngrid,l)
+      ENDDO
+      DO j=2,jjm
+         ig0= 1+(j-2)*iim
+         DO i=1,iim
+            dx3(i,j,l)=px(ig0+i,l)
+         ENDDO
+         dx3(iip1,j,l)=dx3(1,j,l)
+      ENDDO
+   ENDDO
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,sizes,dx3)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,varid,start,sizes,dx3)
+#endif
+
+else if (dim.eq.2) then
+
+      start=(/1,1,indx,0/)
+      sizes=(/iip1,jjp1,1,0/)
+
+!    Passage variable physique -->  physique dynamique
+
+  DO i=1,iip1
+     dx2(i,1)=px(1,1)
+     dx2(i,jjp1)=px(ngrid,1)
+  ENDDO
+  DO j=2,jjm
+     ig0= 1+(j-2)*iim
+     DO i=1,iim
+        dx2(i,j)=px(ig0+i,1)
+     ENDDO
+     dx2(iip1,j)=dx2(1,j)
+  ENDDO
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,sizes,dx2)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,varid,start,sizes,dx2)
+#endif
+
+endif
+
+end subroutine inivar
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+subroutine def_var_stats(nid,name,title,units,nbdim,dimids,nvarid,ierr)
+
+! This subroutine defines variable 'name' in a (pre-existing and opened)
+! NetCDF file (known from its NetCDF ID 'nid').
+! The number of dimensions 'nbdim' of the variable, as well as the IDs of
+! corresponding dimensions must be set (in array 'dimids').
+! Upon successfull definition of the variable, 'nvarid' contains the
+! NetCDF ID of the variable.
+! The variables' attributes 'title' (Note that 'long_name' would be more
+! appropriate) and 'units' are also set. 
+
+implicit none
+
+#include "netcdf.inc"
+
+integer,intent(in) :: nid ! NetCDF file ID
+character(len=*),intent(in) :: name ! the variable's name
+character(len=*),intent(in) :: title ! 'title' attribute of variable
+character(len=*),intent(in) :: units ! 'units' attribute of variable
+integer,intent(in) :: nbdim ! number of dimensions of the variable
+integer,dimension(nbdim),intent(in) :: dimids ! NetCDF IDs of the dimensions
+                                              ! the variable is defined along
+integer,intent(out) :: nvarid ! NetCDF ID of the variable
+integer,intent(out) :: ierr ! returned NetCDF staus code
+
+! 1. Switch to NetCDF define mode 
+ierr=NF_REDEF(nid)
+
+! 2. Define the variable
+#ifdef NC_DOUBLE
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_DOUBLE,nbdim,dimids,nvarid)
+#else
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_FLOAT,nbdim,dimids,nvarid)
+#endif
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var_stats: Failed defining variable "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 3. Write attributes
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"title",&
+                     len_trim(adjustl(title)),adjustl(title))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var_stats: Failed writing title attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"units",&
+                     len_trim(adjustl(units)),adjustl(units))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var_stats: Failed writing units attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 4. Switch out of NetCDF define mode
+ierr = NF_ENDDEF(nid)
+
+end subroutine def_var_stats
+
Index: codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/zerophys.F
===================================================================
--- codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/zerophys.F	(revision 222)
+++ codes/icosagcm/branches/SATURN_DYNAMICO/LMDZ.COMMON/libf/phystd/zerophys.F	(revision 222)
@@ -0,0 +1,11 @@
+      SUBROUTINE zerophys(n,x)
+      IMPLICIT NONE
+      INTEGER n
+      REAL x(n)
+      INTEGER i
+
+      DO i=1,n
+         x(i)=0.
+      ENDDO
+      RETURN
+      END
